* committed: Ada updates
@ 2004-07-26 21:43 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-07-26 21:43 UTC (permalink / raw)
To: gcc-patches
I hoped I would be able to test these changes on the HEAD, but further
breakage have been introduced recently (some of them should be fixed
by Richard Kenner's proposed patches) that made this impossible.
Anyway, tested on i686-linux with a pre ssa compiler, and bootstrap+gnatlib
with -O0 -g (gnattools failed in gimplify.c on prj-part.o) on HEAD.
Arno
--
2004-07-26 Arnaud Charlet <charlet@act-europe.fr>
* sem_util.adb (Requires_Transient_Scope): Temporarily disable
optimization, not supported by the tree-ssa back-end.
2004-07-26 Olivier Hainque <hainque@act-europe.fr>
* s-mastop-irix.adb: Update comments.
* a-except.adb (Exception_Information): Raise Constraint_Error if
exception Id is Null_Id.
This is required behavior, which is more reliably and clearly checked
at the top level interface level.
2004-07-26 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb (Build_Array_Aggr_Code): Do not build the initialization
call if a component has no default_expression and the box is used.
* sem_aggr.adb (Resolve_Array_Aggregate): If a component has no
default_expression and you use box, it behaves as if you had declared a
stand-alone object.
(Resolve_Record_Aggregate): If a component has no default_expression and
you use box, it behaves as if you had declared a stand-alone object.
* sem_ch10.adb (Install_Siblings): Do not make visible the private
entities of private-with siblings.
2004-07-26 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Build_Underlying_Full_View): If this is the full view
for a component of an itype, set the parent pointer for analysis,
there is no list in which to insert it.
* sem_res.adb (Resolve): Call Rewrite_Renamed_Operator only for
bona-fide renamings, not for inherited operations.
* exp_ch4.adb (Expand_Allocator_Expression): If the allocator is an
actual for a formal that is an access parameter, create local
finalization list even if the expression is not an aggregate.
2004-07-26 Ed Schonberg <schonberg@gnat.com>
PR ada/16213
* sem_ch8.adb (Attribute_Renaming, Check_Library_Level_Renaming):
Diagnose properly illegal subprogram renamings that are library units.
2004-07-26 Ed Schonberg <schonberg@gnat.com>
PR ada/15588
* sem_util.adb (Is_OK_Variable_For_Out_Formal): If actual is a type
conversion rewritten as an unchecked conversion, check that original
expression is a variable.
* exp_ch4.adb (Expand_N_Type_Conversion): If rewriting as an
unchecked_conversion, create new node rather than rewriting in place,
to preserve original construct.
2004-07-26 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* gigi.h (gnat_expand_body): Deleted.
* Make-lang.in: (trans.o): Depends on function.h.
* misc.c: (gnat_expand_body): Moved to here.
* trans.c (gnat_expand_body_1): Deleted.
(gnat_expand_body): Moved from here.
(gnat_to_gnu): N_Implicit_Label_Declaration forces being in elab proc.
(add_stmt): Check for marked visited with global_bindings_p.
(gnat_gimplify_expr, case COMPONENT_REF): New case.
(gnat_gimplify_expr, case NULL_EXPR): Set TREE_NO_WARNING for temp.
* utils2.c (build_binary_op, case MODIFY_EXPR): Put LHS in a
VIEW_CONVERT_EXPR if not operation type.
* utils.c (update_pointer_to): Set DECL_ORIGINAL_FIELD for
fat pointer.
* decl.c, cuintp.c, gigi.h, misc.c, trans.c, utils.c, utils2.c: Minor
changes: reformatting of negation operators, removing unneeded
inequality comparison with zero, converting equality comparisons with
zero to negations, changing int/0/1 to bool/false/true, replace calls
to gigi_abort with abort, and various other similar changes.
2004-07-26 Vincent Celier <celier@gnat.com>
* gnatcmd.adb (GNATCmd): Add processing for new built-in command
"setup".
* make.adb (Gnatmake): Fail when a library is not present and there is
no object directory.
* mlib-prj.adb (Check_Library): No need to check if the library needs
to be rebuilt if there is no object directory, hence no object files
to build the library.
* opt.ads (Setup_Projects): New Boolean flag.
* prj-nmsc.adb (Locate_Directory): New parameter Project, Kind and
Location.
Create directory when Kind /= "" and in "gnat setup". Report error if
directory cannot be created.
(Ada_Check): Create library interface copy dir if it does not exist
and we are in "gnat setup".
(Find_Sources): No error if in "gnat setup" and no Ada sources were
found.
(Language_Independent_Check): Create object directory, exec directory
and/or library directory if they do not exist and we are in
"gnat setup".
* vms_conv.ads: (Command_Type): New command Setup.
* vms_conv.adb (Initialize): Add Setup component of Cammand_List.
* vms_data.ads: Add qualifiers/switches for new built-in command
"setup".
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-09-13 11:24 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-09-13 11:24 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 13716 bytes --]
In order to try to unblock the current situation with Ada vs middle-end
changes (in particular all of Richard's pending changes in gigi), I've
committed the following changes.
These changes have been tested either partially, or on a different GCC
back-end since Ada currently does not build, although they should improve
things.
The changelog entries explain what is changed and why.
I've also attached the dif as a text attachment even if the change is large,
since people have expressed concerns about gzip attachments.
Note that this update was pending before the recent discussions on Ada
took place. We are still discussing how to best address the concerns raised,
and this update should not be taken as anything else than a pending update
trying to unblock other Ada builds/updates.
Arno
--
2004-09-09 Vincent Celier <celier@gnat.com>
* a-direct.ads: Add pragma Ada_05
(Directory_Entry_Type): Give default value to component Kind to avoid
not initialized warnings.
* a-direct.adb (Current_Directory): Remove directory separator at the
end.
(Delete_Directory, Delete_Tree): Raise Name_Error if Directory is not
an existing directory.
(Fetch_Next_Entry): Give default value to variable Kind to avoid warning
(Size (String)): Function C_Size returns Long_Integer, not File_Size.
Convert the result to File_Size.
* prj.ads: (Project_Error): New exception
* prj-attr.adb: Except in procedure Initialize, Fail comes from
Prj.Com, not from Osint.
(Attrs, Package_Attributes): Tables moved to private part of spec
(Add_Attribute, Add_Unknown_Package): Moved to new child package
Prj.Attr.PM.
(Register_New_Package (Name, Attributes), Register_New_Attribute): Raise
Prj.Project_Error after call to Fail.
(Register_New_Package (Name, Id)): Set Id to Empty_Package after calling
Fail. Check that package name is not already in use.
* prj-attr.ads: Comment updates to indicate that all subprograms may be
used by tools, not only by the project manager, and to indicate that
exception Prj.Prj_Error may be raised in case of problem.
(Add_Unknown_Package, Add_Attribute): Moved to new child package
Prj.Attr.PM.
(Attrs, Package_Attributes): Table instantiations moved from the body to
the private part to be accessible from Prj.Attr.PM body.
* prj-dect.adb (Parse_Package_Declaration): Call Add_Unknown_Package
from new package Prj.Attr.PM.
(Parse_Attribute_Declaration): Call Add_Attribute from new package
Prj.Attr.PM.
* Makefile.in: Add prj-attr-pm.o to gnatmake object list
* gnatbind.adb (Gnatbind): Correct warning message (Elaboration_Check
instead of Elaboration_Checks).
* a-calend.adb: Minor reformatting
2004-09-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* gigi.h (maybe_pad_type): New declaration.
(create_subprog_type): New arg RETURNS_BY_TARGET_PTR.
* ada-tree.h: (TYPE_RETURNS_BY_TARGET_PTR_P): New macro.
* cuintp.c: Convert to use buildN.
* decl.c (maybe_pad_type): No longer static.
(gnat_to_gnu_entity, case E_Function): Handle case of returning by
target pointer.
Convert to use buildN.
* trans.c (call_to_gnu): Add arg GNU_TARGET; support
TYPE_RETURNS_BY_TARGET_PTR_P. All callers changed.
(gnat_to_gnu, case N_Assignment_Statement): Call call_to_gnu if call on
RHS.
(gnat_to_gnu, case N_Return): Handle TYPE_RETURN_BY_TARGET_PTR_P.
(gnat_gimplify_expr, case ADDR_EXPR): New case.
Convert to use buildN.
* utils2.c (gnat_build_constructor): Also set TREE_INVARIANT and
TREE_READONLY for const.
Convert to use buildN.
* utils.c (create_subprog_type): New operand RETURNS_BY_TARGET_PTR.
(create_var_decl): Refine when TREE_STATIC is set.
Convert to use buildN.
2004-09-09 Gary Dismukes <dismukes@gnat.com>
* gnat_ugn.texi: Delete text relating to checking of ali and object
consistency.
* a-except.adb (Rcheck_*): Add pragmas No_Return for each of these
routines.
2004-09-09 Jose Ruiz <ruiz@act-europe.fr>
* gnat_ugn.texi: Add Detect_Blocking to the list of configuration
pragmas recognized by GNAT.
* gnat_rm.texi: Document pragma Detect_Blocking.
* s-solita.adb (Timed_Delay_T): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
* s-taprob.adb (Lock): When pragma Detect_Blocking is active increase
the protected action nesting level.
(Lock_Read_Only): When pragma Detect_Blocking is active increase the
protected action nesting level.
(Unlock): When pragma Detect_Blocking is active decrease the protected
action nesting level.
* s-taskin.adb (Initialize_ATCB): Initialize to 0 the
Protected_Action_Nesting.
* s-taskin.ads: Adding the field Protected_Action_Nesting to the
Common_ATCB record. It contains the dynamic level of protected action
nesting for each task. It is needed for checking whether potentially
blocking operations are called from protected operations.
(Detect_Blocking): Adding a Boolean constant reflecting whether pragma
Detect_Blocking is active or not in the partition.
* s-tasren.adb (Call_Simple): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
(Task_Entry_Call): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation.
(Timed_Task_Entry_Call): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation.
* s-tassta.adb (Abort_Tasks): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
* s-tpoben.adb (Lock_Entries): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation, and increase
the protected action nesting level.
(Lock_Read_Only_Entries): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation, and increase the
protected action nesting level.
(Unlock_Entries): When pragma Detect_Blocking is active decrease the
protected action nesting level.
* s-tposen.adb (Lock_Entry): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation, and increase
the protected action nesting level.
(Lock_Read_Only_Entry): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation, and increase the
protected action nesting level.
(Protected_Single_Entry_Call): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
(Timed_Protected_Single_Entry_Call): When pragma Detect_Blocking is
active, raise Program_Error if called from a protected operation.
(Unlock_Entry): When pragma Detect_Blocking is active decrease the
protected action nesting level.
* sem_util.adb (Check_Potentially_Blocking_Operation): Remove the
insertion of the statement raising Program_Error. The run time
contains the required machinery for handling that.
* sem_util.ads: Change comment associated to procedure
Check_Potentially_Blocking_Operation.
This procedure does not insert a call for raising the exception because
that is currently done by the run time.
* raise.h (__gnat_set_globals): Pass the detect_blocking parameter.
* init.c: Add the global variable __gl_detect_blocking that indicates
whether pragma Detect_Blocking is active (1) or not (0). Needed for
making the pragma available at run time.
(__gnat_set_globals): Pass and update the detect_blocking parameter.
* lib-writ.adb (Write_ALI): Set the DB flag in the ali file if
pragma Detect_Blocking is active.
* lib-writ.ads: Document the Detect_Blocking flag (DB) in ali files.
* ali.adb (Scan_ALI): Set the Detect_Blocking value to true if the flag
DB is found in the ali file. Any unit compiled with pragma
Detect_Blocking active forces its effect in the whole partition.
* a-retide.adb (Delay_Until): Raise Program_Error if pragma
Detect_Blocking is active and delay is called from a protected
operation.
* bindgen.adb (Gen_Adainit_Ada): When generating the call to
__gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma
Detect_Blocking is active (0 otherwise).
(Gen_Adainit_C): When generating the call to __gnat_set_globals, pass 1
as Detect_Blocking parameter if pragma Detect_Blocking is active (0
otherwise).
2004-09-09 Thomas Quinot <quinot@act-europe.fr>
* gnat_rm.texi: Rename GNAT.Perfect_Hash.Generators to
GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash
package.
* s-parint.ads, s-parint.adb (Get_RAS_Info): New subprogram.
(Register_Receiving_Stub): Add Subp_Info formal parameter.
Update API in placeholder implemetation of s-parint to reflect changes
in distribution runtime library.
* sem_ch3.adb (Expand_Derived_Record): Rename to
Expand_Record_Extension.
* sem_disp.adb (Check_Controlling_Formals): Improve error message for
primitive operations of potentially distributed object types that have
non-controlling anonymous access formals.
* sem_dist.ads, sem_dist.adb (Build_RAS_Primitive_Specification): New
subprogram.
New implementation of expansion for remote access-to-subprogram types,
based on the RACW infrastructure.
This version of sem_dist is compatible with PolyORB/DSA as well as
GLADE.
* sem_prag.adb (Analyze_Pragma, case Pragma_Asynchronous): For a pragma
Asynchrronous that applies to a remote access-to-subprogram type, mark
the underlying RACW type as asynchronous.
* link.c: FreeBSD uses GNU ld: set __gnat_objlist_file_supported and
__gnat_using_gnu_linker to 1.
* Makefile.rtl, impunit.adb, g-perhas.ads, g-pehage.ads,
g-pehage.adb: Rename GNAT.Perfect_Hash.Generators to
GNAT.Perfect_Hash_Generators, and remove the empty
GNAT.Perfect_Hash package.
* atree.adb: Minor reformatting
* exp_ch3.adb (Expand_Derived_Record): Rename to
Expand_Record_Extension.
(Build_Record_Init_Proc.Build_Assignment): The default expression in
a component declaration must remain attached at that point in the
tree so New_Copy_Tree copies it if the enclosing record type is derived.
It is therefore necessary to take a copy of the expression when building
the corresponding assignment statement in the init proc.
As a side effect, in the case of a derived record type, we now see the
original expression, without any rewriting that could have occurred
during expansion of the ancestor type's init proc, and we do not need
to go back to Original_Node.
* exp_ch3.ads (Expand_Derived_Record): Rename to
Expand_Record_Extension.
* exp_dist.ads, exp_dist.adb (Underlying_RACW_Type): New subprogram.
Returns the RACW type used to implement a remote access-to-subprogram
type.
(Add_RAS_Proxy_And_Analyze, Build_Remote_Subprogram_Proxy_Type):
New subprograms. Used to create a proxy tagged object for a remote
subprogram. The proxy object is used as the designated object
for RAS values on the same partition (unless All_Calls_Remote applies).
(Build_Get_Unique_RP_Call): New subprogram. Build a call to
System.Partition_Interface.Get_Unique_Remote_Pointer.
(Add_RAS_Access_TSS, Add_RAS_Dereference_TSS):
Renamed from Add_RAS_*_Attribute.
(Add_Receiving_Stubs_To_Declarations): Generate a table of local
subprograms.
New implementation of expansion for remote access-to-subprogram types,
based on the RACW infrastructure.
* exp_dist.ads (Copy_Specification): Update comment to note that this
function can copy the specification from either a subprogram
specification or an access-to-subprogram type definition.
2004-09-09 Ed Schonberg <schonberg@gnat.com>
* sem_type.adb (Disambiguate): Handle properly an accidental ambiguity
in an instance, between an explicit subprogram an one inherited from a
type derived from an actual.
* exp_ch6.adb (Expand_N_Subprogram_Body): If polling is enabled, do not
add a polling call if the subprogram is to be inlined by the back-end,
to avoid repeated calls with multiple inlinings.
* checks.adb (Apply_Alignment_Check): If the expression in the address
clause is a call whose name is not a static entity (e.g. a dispatching
call), treat as dynamic.
2004-09-09 Robert Dewar <dewar@gnat.com>
* g-trasym.ads: Minor reformatting
* exp_ch3.adb (Component_Needs_Simple_Initialization): Don't except
packed arrays, since unused bits are expected to be zero for a
comparison.
2004-09-09 Eric Botcazou <ebotcazou@act-europe.fr>
* exp_pakd.ads: Fix an inacurracy and a couple of typos in the head
comment.
2004-09-09 Pascal Obry <obry@gnat.com>
* mdll.ads, mdll.adb (Build_Dynamic_Library): New parameter Map_File to
enable map file generation. Add the right option to generate the map
file if Map_File is set to True.
* gnatdll.adb (Gen_Map_File): New variable.
(Syntax): Add info about new -m (Map_File) option.
(Parse_Command_Line): Add support for -m option.
(gnatdll): Pass Gen_Map_File to Build_Dynamic_Library calls.
Minor reformatting.
2004-09-09 Laurent Pautet <pautet@act-europe.fr>
* gnatls.adb: Add a very verbose mode -V. Such mode is required by the
new gnatdist implementation.
Define a subpackage isolating the output routines specific to this
verbose mode.
2004-09-09 Joel Brobecker <brobecker@gnat.com>
* Makefile.rtl: (GNATRTL_NONTASKING_OBJS): Add g-dynhta.
* gnat_ugn.texi (Main Subprograms): Fix typo. Deduced, not deducted.
2004-09-09 Cyrille Comar <comar@act-europe.fr>
* opt.adb (Set_Opt_Config_Switches): Use Ada_Version_Runtime to compile
internal unit.
* opt.ads: Add Ada_Version_Runtime constant used to decide which
version of the language is used to compile the run time.
2004-09-09 Arnaud Charlet <charlet@act-europe.fr>
* sem_util.adb (Requires_Transient_Scope): Re-enable handling
of variable length temporaries for function return now that the
back-end and gigi support it.
[-- Attachment #2: difs.gnat --]
[-- Type: text/plain, Size: 363482 bytes --]
Index: a-calend.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-calend.adb,v
retrieving revision 1.5
diff -u -p -r1.5 a-calend.adb
--- a-calend.adb 19 Apr 2004 15:19:56 -0000 1.5
+++ a-calend.adb 9 Sep 2004 09:24:24 -0000
@@ -417,7 +417,7 @@ package body Ada.Calendar is
end if;
-- Check for Day value too large (one might expect mktime to do this
- -- check, as well as the basi checks we did with 'Valid, but it seems
+ -- check, as well as the basic checks we did with 'Valid, but it seems
-- that at least on some systems, this built-in check is too weak).
if Day > Days_In_Month (Month)
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.23
diff -u -p -r1.23 ada-tree.h
--- ada-tree.h 1 Sep 2004 11:51:49 -0000 1.23
+++ ada-tree.h 9 Sep 2004 09:24:24 -0000
@@ -131,6 +131,11 @@ struct lang_type GTY(()) {tree t; };
#define TYPE_RETURNS_BY_REF_P(NODE) \
TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE))
+/* For FUNCTION_TYPEs, nonzero if function returns by being passed a pointer
+ to a place to store its result. */
+#define TYPE_RETURNS_BY_TARGET_PTR_P(NODE) \
+ TYPE_LANG_FLAG_5 (FUNCTION_TYPE_CHECK (NODE))
+
/* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this
is a dummy type, made to correspond to a private or incomplete type. */
#define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE)
Index: a-except.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-except.adb,v
retrieving revision 1.16
diff -u -p -r1.16 a-except.adb
--- a-except.adb 26 Jul 2004 10:41:42 -0000 1.16
+++ a-except.adb 9 Sep 2004 09:24:24 -0000
@@ -516,6 +516,37 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
+ pragma No_Return (Rcheck_00);
+ pragma No_Return (Rcheck_01);
+ pragma No_Return (Rcheck_02);
+ pragma No_Return (Rcheck_03);
+ pragma No_Return (Rcheck_04);
+ pragma No_Return (Rcheck_05);
+ pragma No_Return (Rcheck_06);
+ pragma No_Return (Rcheck_07);
+ pragma No_Return (Rcheck_08);
+ pragma No_Return (Rcheck_09);
+ pragma No_Return (Rcheck_10);
+ pragma No_Return (Rcheck_11);
+ pragma No_Return (Rcheck_12);
+ pragma No_Return (Rcheck_13);
+ pragma No_Return (Rcheck_14);
+ pragma No_Return (Rcheck_15);
+ pragma No_Return (Rcheck_16);
+ pragma No_Return (Rcheck_17);
+ pragma No_Return (Rcheck_18);
+ pragma No_Return (Rcheck_19);
+ pragma No_Return (Rcheck_20);
+ pragma No_Return (Rcheck_21);
+ pragma No_Return (Rcheck_22);
+ pragma No_Return (Rcheck_23);
+ pragma No_Return (Rcheck_24);
+ pragma No_Return (Rcheck_25);
+ pragma No_Return (Rcheck_26);
+ pragma No_Return (Rcheck_27);
+ pragma No_Return (Rcheck_28);
+ pragma No_Return (Rcheck_29);
+
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
---------------------------------------------
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.20
diff -u -p -r1.20 ali.adb
--- ali.adb 13 Aug 2004 10:24:45 -0000 1.20
+++ ali.adb 9 Sep 2004 09:24:24 -0000
@@ -815,6 +815,12 @@ package body ALI is
Checkc ('E');
ALIs.Table (Id).Compile_Errors := True;
+ -- Processing for DB
+
+ elsif C = 'D' then
+ Checkc ('B');
+ Detect_Blocking := True;
+
-- Processing for FD/FG/FI
elsif C = 'F' then
Index: a-retide.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-retide.adb,v
retrieving revision 1.5
diff -u -p -r1.5 a-retide.adb
--- a-retide.adb 24 Apr 2003 17:53:53 -0000 1.5
+++ a-retide.adb 9 Sep 2004 09:24:24 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -31,13 +31,24 @@
-- --
------------------------------------------------------------------------------
+with Ada.Exceptions;
+-- Used for Raise_Exception
+
+with System.Tasking;
+-- Used for Task_Id
+
with System.Task_Primitives.Operations;
-- Used for Timed_Delay
+-- Self
package body Ada.Real_Time.Delays is
package STPO renames System.Task_Primitives.Operations;
+ ----------------
+ -- Local Data --
+ ----------------
+
Absolute_RT : constant := 2;
-----------------
@@ -45,8 +56,21 @@ package body Ada.Real_Time.Delays is
-----------------
procedure Delay_Until (T : Time) is
+ Self_Id : constant System.Tasking.Task_Id := STPO.Self;
+
begin
- STPO.Timed_Delay (STPO.Self, To_Duration (T), Absolute_RT);
+ -- If pragma Detect_Blocking is active, Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT);
+ end if;
end Delay_Until;
-----------------
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.14
diff -u -p -r1.14 atree.adb
--- atree.adb 19 Apr 2004 15:19:56 -0000 1.14
+++ atree.adb 9 Sep 2004 09:24:25 -0000
@@ -1429,7 +1429,6 @@ package body Atree is
Set_Field5
(New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
-
-- Adjust Sloc of new node if necessary
if New_Sloc /= No_Location then
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.24
diff -u -p -r1.24 bindgen.adb
--- bindgen.adb 1 Sep 2004 11:51:49 -0000 1.24
+++ bindgen.adb 9 Sep 2004 09:24:25 -0000
@@ -100,7 +100,8 @@ package body Bindgen is
-- Num_Interrupt_States : Integer;
-- Unreserve_All_Interrupts : Integer;
-- Exception_Tracebacks : Integer;
- -- Zero_Cost_Exceptions : Integer);
+ -- Zero_Cost_Exceptions : Integer;
+ -- Detect_Blocking : Integer);
-- Main_Priority is the priority value set by pragma Priority in the
-- main program. If no such pragma is present, the value is -1.
@@ -162,6 +163,11 @@ package body Bindgen is
-- this partition, and to zero if longjmp/setjmp exceptions are used.
-- the use of zero
+ -- Detect_Blocking indicates whether pragma Detect_Blocking is
+ -- active or not. A value of zero indicates that the pragma is not
+ -- present, while a value of 1 signals its presence in the
+ -- partition.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -524,12 +530,14 @@ package body Bindgen is
WBI (" Locking_Policy : Character;");
WBI (" Queuing_Policy : Character;");
WBI (" Task_Dispatching_Policy : Character;");
+
WBI (" Restrictions : System.Address;");
WBI (" Interrupt_States : System.Address;");
WBI (" Num_Interrupt_States : Integer;");
WBI (" Unreserve_All_Interrupts : Integer;");
WBI (" Exception_Tracebacks : Integer;");
- WBI (" Zero_Cost_Exceptions : Integer);");
+ WBI (" Zero_Cost_Exceptions : Integer;");
+ WBI (" Detect_Blocking : Integer);");
WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
-- Import entry point for elaboration time signal handler
@@ -630,6 +638,17 @@ package body Bindgen is
Set_String ("0");
end if;
+ Set_String (",");
+ Write_Statement_Buffer;
+
+ Set_String (" Detect_Blocking => ");
+
+ if Detect_Blocking then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
Set_String (");");
Write_Statement_Buffer;
@@ -863,10 +882,23 @@ package body Bindgen is
Set_String (" ");
Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
- Set_String (");");
+ Set_String (",");
Tab_To (24);
Set_String ("/* Zero_Cost_Exceptions */");
Write_Statement_Buffer;
+
+ Set_String (" ");
+
+ if Detect_Blocking then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
+ Set_String (");");
+ Tab_To (24);
+ Set_String ("/* Detect_Blocking */");
+ Write_Statement_Buffer;
WBI ("");
-- Install elaboration time signal handler
@@ -2427,7 +2459,7 @@ package body Bindgen is
WBI ("extern void __gnat_set_globals");
WBI (" (int, int, char, char, char, char,");
WBI (" const char *, const char *,");
- WBI (" int, int, int, int);");
+ WBI (" int, int, int, int, int);");
WBI ("extern void " & Ada_Final_Name.all & " (void);");
WBI ("extern void " & Ada_Init_Name.all & " (void);");
WBI ("extern void system__standard_library__adafinal (void);");
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.27
diff -u -p -r1.27 checks.adb
--- checks.adb 1 Sep 2004 11:51:49 -0000 1.27
+++ checks.adb 9 Sep 2004 09:24:25 -0000
@@ -492,6 +492,7 @@ package body Checks is
Expr := Expression (Expr);
elsif Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
Index: cuintp.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cuintp.c,v
retrieving revision 1.12
diff -u -p -r1.12 cuintp.c
--- cuintp.c 1 Sep 2004 11:51:50 -0000 1.12
+++ cuintp.c 9 Sep 2004 09:24:25 -0000
@@ -95,18 +95,18 @@ UI_To_gnu (Uint Input, tree type)
gnu_ret = build_cst_from_int (comp_type, First);
if (First < 0)
for (Idx++, Length--; Length; Idx++, Length--)
- gnu_ret = fold (build (MINUS_EXPR, comp_type,
- fold (build (MULT_EXPR, comp_type,
- gnu_ret, gnu_base)),
- build_cst_from_int (comp_type,
- Udigits_Ptr[Idx])));
+ gnu_ret = fold (build2 (MINUS_EXPR, comp_type,
+ fold (build2 (MULT_EXPR, comp_type,
+ gnu_ret, gnu_base)),
+ build_cst_from_int (comp_type,
+ Udigits_Ptr[Idx])));
else
for (Idx++, Length--; Length; Idx++, Length--)
- gnu_ret = fold (build (PLUS_EXPR, comp_type,
- fold (build (MULT_EXPR, comp_type,
- gnu_ret, gnu_base)),
- build_cst_from_int (comp_type,
- Udigits_Ptr[Idx])));
+ gnu_ret = fold (build2 (PLUS_EXPR, comp_type,
+ fold (build2 (MULT_EXPR, comp_type,
+ gnu_ret, gnu_base)),
+ build_cst_from_int (comp_type,
+ Udigits_Ptr[Idx])));
}
gnu_ret = convert (type, gnu_ret);
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.54
diff -u -p -r1.54 decl.c
--- decl.c 1 Sep 2004 11:51:50 -0000 1.54
+++ decl.c 9 Sep 2004 09:24:25 -0000
@@ -89,8 +89,6 @@ static bool is_variable_size (tree);
static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
bool, bool);
static tree make_packable_type (tree);
-static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *,
- bool, bool, bool);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
bool, bool);
@@ -877,13 +875,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_expr = gnu_address;
else
gnu_expr
- = build (COMPOUND_EXPR, gnu_type,
- build_binary_op
- (MODIFY_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_address),
- gnu_expr),
- gnu_address);
+ = build2 (COMPOUND_EXPR, gnu_type,
+ build_binary_op
+ (MODIFY_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ gnu_address),
+ gnu_expr),
+ gnu_address);
}
/* If it has an address clause and we are not defining it, mark it
@@ -1234,8 +1232,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
{
TYPE_MODULAR_P (gnu_type) = 1;
SET_TYPE_MODULUS (gnu_type, gnu_modulus);
- gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus,
- convert (gnu_type, integer_one_node)));
+ gnu_high = fold (build2 (MINUS_EXPR, gnu_type, gnu_modulus,
+ convert (gnu_type, integer_one_node)));
}
/* If we have to set TYPE_PRECISION different from its natural value,
@@ -1511,9 +1509,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* Build a reference to the template from a PLACEHOLDER_EXPR that
is the fat pointer. This will be used to access the individual
fields once we build them. */
- tem = build (COMPONENT_REF, gnu_ptr_template,
- build (PLACEHOLDER_EXPR, gnu_fat_type),
- TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
+ tem = build3 (COMPONENT_REF, gnu_ptr_template,
+ build0 (PLACEHOLDER_EXPR, gnu_fat_type),
+ TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
gnu_template_reference
= build_unary_op (INDIRECT_REF, gnu_template_type, tem);
TREE_READONLY (gnu_template_reference) = 1;
@@ -1559,10 +1557,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* We can't use build_component_ref here since the template
type isn't complete yet. */
- gnu_min = build (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_min_field, NULL_TREE);
- gnu_max = build (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_max_field, NULL_TREE);
+ gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
+ gnu_template_reference, gnu_min_field,
+ NULL_TREE);
+ gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
+ gnu_template_reference, gnu_max_field,
+ NULL_TREE);
TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
/* Make a range type with the new ranges, but using
@@ -1802,9 +1802,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
&& TREE_CODE (gnu_max) == INTEGER_CST
&& TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
&& (!TREE_OVERFLOW
- (fold (build (MINUS_EXPR, gnu_index_subtype,
- TYPE_MAX_VALUE (gnu_index_subtype),
- TYPE_MIN_VALUE (gnu_index_subtype))))))
+ (fold (build2 (MINUS_EXPR, gnu_index_subtype,
+ TYPE_MAX_VALUE (gnu_index_subtype),
+ TYPE_MIN_VALUE (gnu_index_subtype))))))
TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max)
= TREE_CONSTANT_OVERFLOW (gnu_min)
= TREE_CONSTANT_OVERFLOW (gnu_max) = 0;
@@ -2360,11 +2360,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
COMPONENT_REF which will be filled in below, once
the parent type can be safely built. */
- gnu_get_parent = build (COMPONENT_REF, void_type_node,
- build (PLACEHOLDER_EXPR, gnu_type),
- build_decl (FIELD_DECL, NULL_TREE,
- NULL_TREE),
- NULL_TREE);
+ gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
+ build0 (PLACEHOLDER_EXPR, gnu_type),
+ build_decl (FIELD_DECL, NULL_TREE,
+ NULL_TREE),
+ NULL_TREE);
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
@@ -2373,13 +2373,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
if (Present (Corresponding_Discriminant (gnat_field)))
save_gnu_tree
(gnat_field,
- build (COMPONENT_REF,
- get_unpadded_type (Etype (gnat_field)),
- gnu_get_parent,
- gnat_to_gnu_entity (Corresponding_Discriminant
- (gnat_field),
+ build3 (COMPONENT_REF,
+ get_unpadded_type (Etype (gnat_field)),
+ gnu_get_parent,
+ gnat_to_gnu_entity (Corresponding_Discriminant
+ (gnat_field),
NULL_TREE, 0),
- NULL_TREE),
+ NULL_TREE),
true);
gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
@@ -2418,10 +2418,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
corresponding GNAT defining identifier. Then add to the
list of fields. */
save_gnu_tree (gnat_field,
- build (COMPONENT_REF, TREE_TYPE (gnu_field),
- build (PLACEHOLDER_EXPR,
- DECL_CONTEXT (gnu_field)),
- gnu_field, NULL_TREE),
+ build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
+ build0 (PLACEHOLDER_EXPR,
+ DECL_CONTEXT (gnu_field)),
+ gnu_field, NULL_TREE),
true);
TREE_CHAIN (gnu_field) = gnu_field_list;
@@ -3243,6 +3243,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
bool volatile_flag = No_Return (gnat_entity);
bool returns_by_ref = false;
bool returns_unconstrained = false;
+ bool returns_by_target_ptr = false;
tree gnu_ext_name = create_concat_name (gnat_entity, 0);
bool has_copy_in_out = false;
int parmnum;
@@ -3323,9 +3324,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
|| Has_Foreign_Convention (gnat_entity)))
gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
- /* Look at all our parameters and get the type of
- each. While doing this, build a copy-out structure if
- we need one. */
+ /* If the return type is unconstrained, that means it must have a
+ maximum size. We convert the function into a procedure and its
+ caller will pass a pointer to an object of that maximum size as the
+ first parameter when we call the function. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
+ {
+ returns_by_target_ptr = true;
+ gnu_param_list
+ = create_param_decl (get_identifier ("TARGET"),
+ build_reference_type (gnu_return_type),
+ true);
+ gnu_return_type = void_type_node;
+ }
/* If the return type has a size that overflows, we cannot have
a function that returns that type. This usage doesn't make
@@ -3339,9 +3350,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
- TYPE_NEXT_VARIANT (gnu_return_type) = 0;
+ TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
}
+ /* Look at all our parameters and get the type of
+ each. While doing this, build a copy-out structure if
+ we need one. */
+
for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
@@ -3599,7 +3614,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
= create_subprog_type (gnu_return_type, gnu_param_list,
gnu_return_list, returns_unconstrained,
returns_by_ref,
- Function_Returns_With_DSP (gnat_entity));
+ Function_Returns_With_DSP (gnat_entity),
+ returns_by_target_ptr);
/* A subprogram (something that doesn't return anything) shouldn't
be considered Pure since there would be no reason for such a
@@ -4524,9 +4540,9 @@ elaborate_expression_1 (Node_Id gnat_exp
here. We have to hope it will be at the highest level of the
expression in these cases. */
if (TREE_CODE (gnu_expr) == FIELD_DECL)
- gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr),
- build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
- gnu_expr, NULL_TREE);
+ gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
+ build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
+ gnu_expr, NULL_TREE);
/* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
that is a constant, make a variable that is initialized to contain the
@@ -4576,7 +4592,7 @@ tree
make_aligning_type (tree type, int align, tree size)
{
tree record_type = make_node (RECORD_TYPE);
- tree place = build (PLACEHOLDER_EXPR, record_type);
+ tree place = build0 (PLACEHOLDER_EXPR, record_type);
tree size_addr_place = convert (sizetype,
build_unary_op (ADDR_EXPR, NULL_TREE,
place));
@@ -4701,7 +4717,7 @@ make_packable_type (tree type)
set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
type. */
-static tree
+tree
maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, const char *name_trailer,
bool is_user_type, bool definition, bool same_rm_size)
@@ -5587,7 +5603,7 @@ annotate_value (tree gnu_size)
temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
if (adjust)
- temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
+ temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
return annotate_value (temp);
}
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.23
diff -u -p -r1.23 exp_ch3.adb
--- exp_ch3.adb 9 Aug 2004 12:24:12 -0000 1.23
+++ exp_ch3.adb 9 Sep 2004 09:24:25 -0000
@@ -1400,17 +1400,10 @@ package body Exp_Ch3 is
(T : Entity_Id) return Boolean;
-- Determines if a component needs simple initialization, given its
-- type T. This is the same as Needs_Simple_Initialization except
- -- for the following differences. The types Tag and Vtable_Ptr,
- -- which are access types which would normally require simple
- -- initialization to null, do not require initialization as
- -- components, since they are explicitly initialized by other
- -- means. The other relaxation is for packed bit arrays that are
- -- associated with a modular type, which in some cases require
- -- zero initialization to properly support comparisons, except
- -- that comparison of such components always involves an explicit
- -- selection of only the component's specific bits (whether or not
- -- there are adjacent components or gaps), so zero initialization
- -- is never needed for components.
+ -- for the following difference: the types Tag and Vtable_Ptr, which
+ -- are access types which would normally require simple initialization
+ -- to null, do not require initialization as components, since they
+ -- are explicitly initialized by other means.
procedure Constrain_Array
(SI : Node_Id;
@@ -1457,16 +1450,14 @@ package body Exp_Ch3 is
Selector_Name => New_Occurrence_Of (Id, Loc));
Set_Assignment_OK (Lhs);
- -- Case of an access attribute applied to the current
- -- instance. Replace the reference to the type by a
- -- reference to the actual object. (Note that this
- -- handles the case of the top level of the expression
- -- being given by such an attribute, but doesn't cover
- -- uses nested within an initial value expression.
- -- Nested uses are unlikely to occur in practice,
- -- but theoretically possible. It's not clear how
- -- to handle them without fully traversing the
- -- expression. ???)
+ -- Case of an access attribute applied to the current instance.
+ -- Replace the reference to the type by a reference to the actual
+ -- object. (Note that this handles the case of the top level of
+ -- the expression being given by such an attribute, but does not
+ -- cover uses nested within an initial value expression. Nested
+ -- uses are unlikely to occur in practice, but are theoretically
+ -- possible. It is not clear how to handle them without fully
+ -- traversing the expression. ???
if Kind = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Unchecked_Access
@@ -1482,23 +1473,8 @@ package body Exp_Ch3 is
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- For a derived type the default value is copied from the component
- -- declaration of the parent. In the analysis of the init_proc for
- -- the parent the default value may have been expanded into a local
- -- variable, which is of course not usable here. We must copy the
- -- original expression and reanalyze.
-
- if Nkind (Exp) = N_Identifier
- and then not Comes_From_Source (Exp)
- and then Analyzed (Exp)
- and then not In_Open_Scopes (Scope (Entity (Exp)))
- and then Nkind (Original_Node (Exp)) = N_Aggregate
- then
- Exp := New_Copy_Tree (Original_Node (Exp));
- end if;
-
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check
+ -- type to force the corresponding run-time check.
if Ada_Version >= Ada_05
and then Can_Never_Be_Null (Etype (Id)) -- Lhs
@@ -1509,6 +1485,12 @@ package body Exp_Ch3 is
Analyze_And_Resolve (Exp, Etype (Id));
end if;
+ -- Take a copy of Exp to ensure that later copies of this
+ -- component_declaration in derived types see the original tree,
+ -- not a node rewritten during expansion of the init_proc.
+
+ Exp := New_Copy_Tree (Exp);
+
Res := New_List (
Make_Assignment_Statement (Loc,
Name => Lhs,
@@ -2243,8 +2225,7 @@ package body Exp_Ch3 is
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
- and then not Is_RTE (T, RE_Vtable_Ptr)
- and then not Is_Bit_Packed_Array (T);
+ and then not Is_RTE (T, RE_Vtable_Ptr);
end Component_Needs_Simple_Initialization;
---------------------
@@ -3049,9 +3030,9 @@ package body Exp_Ch3 is
end if;
end Check_Stream_Attributes;
- ---------------------------
- -- Expand_Derived_Record --
- ---------------------------
+ -----------------------------
+ -- Expand_Record_Extension --
+ -----------------------------
-- Add a field _parent at the beginning of the record extension. This is
-- used to implement inheritance. Here are some examples of expansion:
@@ -3075,7 +3056,7 @@ package body Exp_Ch3 is
-- D : Int;
-- end;
- procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is
+ procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
Indic : constant Node_Id := Subtype_Indication (Def);
Loc : constant Source_Ptr := Sloc (Def);
Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
@@ -3087,7 +3068,7 @@ package body Exp_Ch3 is
List_Constr : constant List_Id := New_List;
begin
- -- Expand_Tagged_Extension is called directly from the semantics, so
+ -- Expand_Record_Extension is called directly from the semantics, so
-- we must check to see whether expansion is active before proceeding
if not Expander_Active then
@@ -3170,7 +3151,7 @@ package body Exp_Ch3 is
end if;
Analyze (Comp_Decl);
- end Expand_Derived_Record;
+ end Expand_Record_Extension;
------------------------------------
-- Expand_N_Full_Type_Declaration --
@@ -5605,7 +5586,6 @@ package body Exp_Ch3 is
elsif Is_Access_Type (T)
or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T)))
-
or else (Is_Bit_Packed_Array (T)
and then Is_Modular_Integer_Type (Packed_Array_Type (T)))
then
Index: exp_ch3.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.ads,v
retrieving revision 1.8
diff -u -p -r1.8 exp_ch3.ads
--- exp_ch3.ads 7 Jun 2004 14:16:17 -0000 1.8
+++ exp_ch3.ads 9 Sep 2004 09:24:25 -0000
@@ -43,7 +43,7 @@ package Exp_Ch3 is
-- the master for that access type, now that it is known to denote an
-- object with tasks.
- procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id);
+ procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record.
procedure Build_Discr_Checking_Funcs (N : Node_Id);
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.33
diff -u -p -r1.33 exp_ch6.adb
--- exp_ch6.adb 1 Sep 2004 11:51:50 -0000 1.33
+++ exp_ch6.adb 9 Sep 2004 09:24:26 -0000
@@ -3043,7 +3043,8 @@ package body Exp_Ch6 is
-- Expand_N_Subprogram_Body --
------------------------------
- -- Add poll call if ATC polling is enabled
+ -- Add poll call if ATC polling is enabled, unless the body will be
+ -- inlined by the back-end.
-- Add return statement if last statement in body is not a return
-- statement (this makes things easier on Gigi which does not want
@@ -3272,14 +3273,6 @@ package body Exp_Ch6 is
L := Statements (Handled_Statement_Sequence (N));
end if;
- -- Need poll on entry to subprogram if polling enabled. We only
- -- do this for non-empty subprograms, since it does not seem
- -- necessary to poll for a dummy null subprogram.
-
- if Is_Non_Empty_List (L) then
- Generate_Poll_Call (First (L));
- end if;
-
-- Find entity for subprogram
Body_Id := Defining_Entity (N);
@@ -3290,6 +3283,23 @@ package body Exp_Ch6 is
Spec_Id := Body_Id;
end if;
+ -- Need poll on entry to subprogram if polling enabled. We only
+ -- do this for non-empty subprograms, since it does not seem
+ -- necessary to poll for a dummy null subprogram. Do not add polling
+ -- point if calls to this subprogram will be inlined by the back-end,
+ -- to avoid repeated polling points in nested inlinings.
+
+ if Is_Non_Empty_List (L) then
+ if Is_Inlined (Spec_Id)
+ and then Front_End_Inlining
+ and then Optimization_Level > 1
+ then
+ null;
+ else
+ Generate_Poll_Call (First (L));
+ end if;
+ end if;
+
-- If this is a Pure function which has any parameters whose root
-- type is System.Address, reset the Pure indication, since it will
-- likely cause incorrect code to be generated as the parameter is
Index: exp_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dist.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_dist.adb
--- exp_dist.adb 6 Jul 2004 13:57:30 -0000 1.13
+++ exp_dist.adb 9 Sep 2004 09:24:26 -0000
@@ -76,27 +76,63 @@ package body Exp_Dist is
-- to fake half a derivation to ensure that the subprograms do have
-- the same dispatching table.
+ First_RCI_Subprogram_Id : constant := 2;
+ -- RCI subprograms are numbered starting at 2. The RCI receiver for
+ -- an RCI package can thus identify calls received through remote
+ -- access-to-subprogram dereferences by the fact that they have a
+ -- (primitive) subprogram id of 0, and 1 is used for the internal
+ -- RAS information lookup operation.
+
-----------------------
-- Local subprograms --
-----------------------
+ procedure Add_RAS_Proxy_And_Analyze
+ (Decls : List_Id;
+ Vis_Decl : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : out Entity_Id);
+ -- Add the proxy type necessary to call the subprogram declared
+ -- by Vis_Decl through a remote access to subprogram type.
+ -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
+ -- applies, Standard_False otherwise. The new proxy type is appended
+ -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
+ -- designates an instance of the proxy object.
+
+ function Build_Remote_Subprogram_Proxy_Type
+ (Loc : Source_Ptr;
+ ACR_Expression : Node_Id) return Node_Id;
+ -- Build and return a tagged record type definition for an RCI
+ -- subprogram proxy type.
+ -- ACR_Expression is use as the initialization value for
+ -- the All_Calls_Remote component.
+
function Get_Subprogram_Id (E : Entity_Id) return Int;
-- Given a subprogram defined in a RCI package, get its subprogram id
-- which will be used for remote calls.
+ function Build_Get_Unique_RP_Call
+ (Loc : Source_Ptr;
+ Pointer : Entity_Id;
+ Stub_Type : Entity_Id) return List_Id;
+ -- Build a call to Get_Unique_Remote_Pointer (Pointer),
+ -- followed by a tag fixup (Get_Unique_Remote_Pointer may have
+ -- changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired
+ -- tag is that of Stub_Type).
+
procedure Build_General_Calling_Stubs
- (Decls : in List_Id;
- Statements : in List_Id;
- Target_Partition : in Entity_Id;
- RPC_Receiver : in Node_Id;
- Subprogram_Id : in Node_Id;
- Asynchronous : in Node_Id := Empty;
- Is_Known_Asynchronous : in Boolean := False;
- Is_Known_Non_Asynchronous : in Boolean := False;
- Is_Function : in Boolean;
- Spec : in Node_Id;
- Object_Type : in Entity_Id := Empty;
- Nod : in Node_Id);
+ (Decls : List_Id;
+ Statements : List_Id;
+ Target_Partition : Entity_Id;
+ RPC_Receiver : Node_Id;
+ Subprogram_Id : Node_Id;
+ Asynchronous : Node_Id := Empty;
+ Is_Known_Asynchronous : Boolean := False;
+ Is_Known_Non_Asynchronous : Boolean := False;
+ Is_Function : Boolean;
+ Spec : Node_Id;
+ Object_Type : Entity_Id := Empty;
+ Nod : Node_Id);
-- Build calling stubs for general purpose. The parameters are:
-- Decls : a place to put declarations
-- Statements : a place to put statements
@@ -124,8 +160,7 @@ package body Exp_Dist is
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id;
+ New_Name : Name_Id := No_Name) return Node_Id;
-- Build the calling stub for a given subprogram with the subprogram ID
-- being Subp_Id. If Stub_Type is given, then the "addr" field of
-- parameters of this type will be marshalled instead of the object
@@ -142,8 +177,7 @@ package body Exp_Dist is
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
- Parent_Primitive : Entity_Id := Empty)
- return Node_Id;
+ Parent_Primitive : Entity_Id := Empty) return Node_Id;
-- Build the receiving stub for a given subprogram. The subprogram
-- declaration is also built by this procedure, and the value returned
-- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
@@ -155,31 +189,32 @@ package body Exp_Dist is
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id)
- return Node_Id;
+ Result_Parameter : Entity_Id) return Node_Id;
-- Make a subprogram specification for an RPC receiver,
-- with the given defining unit name and formal parameters.
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
-- Return an ordered parameter list: unconstrained parameters are put
-- at the beginning of the list and constrained ones are put after. If
- -- there are no parameters, an empty list is returned.
+ -- there are no parameters, an empty list is returned. Special case:
+ -- the controlling formal of the equivalent RACW operation for a RAS
+ -- type is always left in first position.
procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id);
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id);
-- Add calling stubs to the declarative part
procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id);
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id);
-- Add receiving stubs to the declarative part
- procedure Add_RAS_Dereference_Attribute (N : in Node_Id);
- -- Add a subprogram body for RAS dereference
+ procedure Add_RAS_Dereference_TSS (N : Node_Id);
+ -- Add a subprogram body for RAS Dereference TSS
- procedure Add_RAS_Access_Attribute (N : in Node_Id);
- -- Add a subprogram body for RAS Access attribute
+ procedure Add_RAS_Access_TSS (N : Node_Id);
+ -- Add a subprogram body for RAS Access TSS
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- Return True if nothing prevents the program whose specification is
@@ -194,8 +229,7 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Entity_Id;
- Etyp : Entity_Id := Empty)
- return Node_Id;
+ Etyp : Entity_Id := Empty) return Node_Id;
-- Pack Object (of type Etyp) into Stream. If Etyp is not given,
-- then Etype (Object) will be used if present. If the type is
-- constrained, then 'Write will be used to output the object,
@@ -205,30 +239,16 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id;
+ Etyp : Entity_Id) return Node_Id;
-- Similar to above, with an arbitrary node instead of an entity
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id;
+ Etyp : Entity_Id) return Node_Id;
-- Similar to above, with Stream instead of Stream'Access
- function Copy_Specification
- (Loc : Source_Ptr;
- Spec : Node_Id;
- Object_Type : Entity_Id := Empty;
- Stub_Type : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id;
- -- Build a specification from another one. If Object_Type is not Empty
- -- and any access to Object_Type is found, then it is replaced by an
- -- access to Stub_Type. If New_Name is given, then it will be used as
- -- the name for the newly created spec.
-
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
@@ -237,8 +257,7 @@ package body Exp_Dist is
-- its constrained status.
function Is_RACW_Controlling_Formal
- (Parameter : Node_Id; Stub_Type : Entity_Id)
- return Boolean;
+ (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
-- Return True if the current parameter is a controlling formal argument
-- of type Stub_Type or access to Stub_Type.
@@ -301,9 +320,9 @@ package body Exp_Dist is
-- Mapping between a RCI subprogram and the corresponding calling stubs
procedure Add_Stub_Type
- (Designated_Type : in Entity_Id;
- RACW_Type : in Entity_Id;
- Decls : in List_Id;
+ (Designated_Type : Entity_Id;
+ RACW_Type : Entity_Id;
+ Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
Object_RPC_Receiver : out Entity_Id;
@@ -314,28 +333,28 @@ package body Exp_Dist is
-- anyhow and Existing is set to True.
procedure Add_RACW_Read_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Declarations : in List_Id);
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Declarations : List_Id);
-- Add Read attribute in Decls for the RACW type. The Read attribute
-- is added right after the RACW_Type declaration while the body is
-- inserted after Declarations.
procedure Add_RACW_Write_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id);
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id);
-- Same thing for the Write attribute
procedure Add_RACW_Read_Write_Attributes
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id);
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id);
-- Add Read and Write attributes declarations and bodies for a given
-- RACW type. The declarations are added just after the declaration
-- of the RACW type itself, while the bodies are inserted at the end
@@ -343,8 +362,7 @@ package body Exp_Dist is
function RCI_Package_Locator
(Loc : Source_Ptr;
- Package_Spec : Node_Id)
- return Node_Id;
+ Package_Spec : Node_Id) return Node_Id;
-- Instantiate the generic package RCI_Info in order to locate the
-- RCI package whose spec is given as argument.
@@ -361,8 +379,7 @@ package body Exp_Dist is
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
- Stream : Entity_Id)
- return Node_Id;
+ Stream : Entity_Id) return Node_Id;
-- Return a function with the following form:
-- function R return Var_Type is
-- begin
@@ -392,16 +409,16 @@ package body Exp_Dist is
---------------------------------------
procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id)
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id)
is
- Current_Subprogram_Number : Int := 0;
- Current_Declaration : Node_Id;
+ Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
+ -- Subprogram id 0 is reserved for calls received from
+ -- remote access-to-subprogram dereferences.
+ Current_Declaration : Node_Id;
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
-
RCI_Instantiation : Node_Id;
-
Subp_Stubs : Node_Id;
begin
@@ -424,9 +441,7 @@ package body Exp_Dist is
-- do the correct dispatching.
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
-
while Current_Declaration /= Empty loop
-
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
@@ -453,14 +468,13 @@ package body Exp_Dist is
Next (Current_Declaration);
end loop;
-
end Add_Calling_Stubs_To_Declarations;
-----------------------
-- Add_RACW_Features --
-----------------------
- procedure Add_RACW_Features (RACW_Type : in Entity_Id)
+ procedure Add_RACW_Features (RACW_Type : Entity_Id)
is
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
@@ -554,7 +568,7 @@ package body Exp_Dist is
Loc : constant Source_Ptr := Sloc (Insertion_Node);
Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Designated_Type);
+ Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
@@ -593,9 +607,7 @@ package body Exp_Dist is
Current_Primitive_Elmt :=
First_Elmt (Primitive_Operations (Designated_Type));
-
while Current_Primitive_Elmt /= No_Elmt loop
-
Current_Primitive := Node (Current_Primitive_Elmt);
-- Copy the primitive of all the parents, except predefined
@@ -748,10 +760,10 @@ package body Exp_Dist is
-----------------------------
procedure Add_RACW_Read_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Declarations : in List_Id)
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
@@ -777,6 +789,9 @@ package body Exp_Dist is
Source_Address : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
+ Local_Stub : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('L'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
@@ -836,9 +851,20 @@ package body Exp_Dist is
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
Make_Object_Declaration (Loc,
+ Defining_Identifier => Local_Stub,
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
+
+ Make_Object_Declaration (Loc,
Defining_Identifier => Stubbed_Result,
Object_Definition =>
- New_Occurrence_Of (Stub_Type_Access, Loc)));
+ New_Occurrence_Of (Stub_Type_Access, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Local_Stub, Loc),
+ Attribute_Name =>
+ Name_Unchecked_Access)));
-- Read the source Partition_ID and RPC_Receiver from incoming stream
@@ -869,6 +895,10 @@ package body Exp_Dist is
Stream_Parameter,
New_Occurrence_Of (Source_Address, Loc))));
+ -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
+
+ Set_Etype (Stubbed_Result, Stub_Type_Access);
+
-- If the Address is Null_Address, then return a null object
Append_To (Statements,
@@ -901,12 +931,6 @@ package body Exp_Dist is
Remote_Statements := New_List (
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Stubbed_Result, Loc),
- Expression =>
- Make_Allocator (Loc,
- New_Occurrence_Of (Stub_Type, Loc))),
-
- Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
Selector_Name => Make_Identifier (Loc, Name_Origin)),
@@ -935,13 +959,18 @@ package body Exp_Dist is
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
- Append_To (Remote_Statements,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
- New_Occurrence_Of (Stubbed_Result, Loc)))));
+ Append_List_To (Remote_Statements,
+ Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
+ -- ??? Issue with asynchronous calls here: the Asynchronous
+ -- flag is set on the stub type if, and only if, the RACW type
+ -- has a pragma Asynchronous. This is incorrect for RACWs that
+ -- implement RAS types, because in that case the /designated
+ -- subprogram/ (not the type) might be asynchronous, and
+ -- that causes the stub to need to be asynchronous too.
+ -- A solution is to transport a RAS as a struct containing
+ -- a RACW and an asynchronous flag, and to properly alter
+ -- the Asynchronous component in the stub type in the RAS's
+ -- Input TSS.
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
@@ -991,11 +1020,11 @@ package body Exp_Dist is
------------------------------------
procedure Add_RACW_Read_Write_Attributes
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id)
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id)
is
begin
Add_RACW_Write_Attribute
@@ -1017,18 +1046,22 @@ package body Exp_Dist is
------------------------------
procedure Add_RACW_Write_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id)
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
+
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
+ RPC_Receiver : Node_Id;
+
Statements : List_Id;
Local_Statements : List_Id;
Remote_Statements : List_Id;
@@ -1056,6 +1089,26 @@ package body Exp_Dist is
-- Build the code fragment corresponding to the marshalling of a
-- local object.
+ if Is_RAS then
+
+ -- For a RAS, the RPC receiver is that of the RCI unit,
+ -- not that of the corresponding distributed object type.
+ -- We retrieve its address from the local proxy object.
+
+ RPC_Receiver := Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Receiver));
+
+ else
+ RPC_Receiver := Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Object_RPC_Receiver, Loc),
+ Attribute_Name =>
+ Name_Address);
+ end if;
+
Local_Statements := New_List (
Pack_Entity_Into_Stream_Access (Loc,
@@ -1064,21 +1117,18 @@ package body Exp_Dist is
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64),
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
- Attribute_Name => Name_Address)),
+ Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
Etyp => RTE (RE_Unsigned_64)),
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Prefix => Object),
- Attribute_Name => Name_Address)),
- Etyp => RTE (RE_Unsigned_64)));
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => OK_Convert_To (RTE (RE_Unsigned_64),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Object),
+ Attribute_Name => Name_Address)),
+ Etyp => RTE (RE_Unsigned_64)));
-- Build the code fragment corresponding to the marshalling of
-- a remote object.
@@ -1180,34 +1230,79 @@ package body Exp_Dist is
Append_To (Declarations, Body_Node);
end Add_RACW_Write_Attribute;
- ------------------------------
- -- Add_RAS_Access_Attribute --
- ------------------------------
+ ------------------------
+ -- Add_RAS_Access_TSS --
+ ------------------------
+
+ procedure Add_RAS_Access_TSS (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- procedure Add_RAS_Access_Attribute (N : in Node_Id) is
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
-- Ras_Type is the access to subprogram type while Fat_Type points to
-- the record type corresponding to a remote access to subprogram type.
- Proc_Decls : constant List_Id := New_List;
- Proc_Statements : constant List_Id := New_List;
+ RACW_Type : constant Entity_Id :=
+ Underlying_RACW_Type (Ras_Type);
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
+
+ Stub_Elements : constant Stub_Structure :=
+ Stubs_Table.Get (Desig);
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+
+ Proc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
+ Proc_Spec : Node_Id;
+
+ -- Formal parameters
- Proc_Spec : Node_Id;
- Proc : Node_Id;
- Local_Addr : Entity_Id;
- Package_Name : Entity_Id;
- Subp_Id : Entity_Id;
- Asynch_P : Entity_Id;
- Origin : Entity_Id;
- Return_Value : Entity_Id;
+ Package_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_P);
+ -- Target package
- All_Calls_Remote : Entity_Id;
+ Subp_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_S);
+ -- Target subprogram
+
+ Asynch_P : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Asynchronous);
+ -- Is the procedure to which the 'Access applies asynchronous?
+
+ All_Calls_Remote : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_All_Calls_Remote);
-- True if an All_Calls_Remote pragma applies to the RCI unit
- -- that contains the subprogram (currently unused, all RAS
- -- dereferences are handled through the PCS).
+ -- that contains the subprogram.
- Loc : constant Source_Ptr := Sloc (N);
+ -- Common local variables
+
+ Proc_Decls : List_Id;
+ Proc_Statements : List_Id;
+
+ Origin : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ -- Additional local variables for the local case
+
+ Proxy_Addr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ -- Additional local variables for the remote case
+
+ Local_Stub : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('L'));
+
+ Stub_Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
function Set_Field
(Field_Name : Name_Id;
@@ -1228,26 +1323,17 @@ package body Exp_Dist is
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Return_Value, Loc),
+ Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
Selector_Name => Make_Identifier (Loc, Field_Name)),
Expression => Value);
end Set_Field;
- -- Start of processing for Add_RAS_Access_Attribute
+ -- Start of processing for Add_RAS_Access_TSS
begin
- Local_Addr := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
- Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
- Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
- Origin := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- All_Calls_Remote :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
-
- -- Create the object which will be returned of type Fat_Type
+ Proc_Decls := New_List (
- Append_List_To (Proc_Decls, New_List (
+ -- Common declarations
Make_Object_Declaration (Loc,
Defining_Identifier => Origin,
@@ -1261,41 +1347,75 @@ package body Exp_Dist is
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))),
+ -- Declaration use only in the local case: proxy address
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Proxy_Addr,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+
+ -- Declarations used only in the remote case: stub object and
+ -- stub pointer.
+
Make_Object_Declaration (Loc,
- Defining_Identifier => Return_Value,
+ Defining_Identifier => Local_Stub,
+ Aliased_Present => True,
Object_Definition =>
- New_Occurrence_Of (Fat_Type, Loc))));
+ New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Stub_Ptr,
+ Object_Definition =>
+ New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Local_Stub, Loc),
+ Attribute_Name => Name_Unchecked_Access)));
- -- Initialize the fields of the record type with the appropriate data
+ Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
+ -- Build_Get_Unique_RP_Call needs this information.
+
+ -- Note: Here we assume that the Fat_Type is a record
+ -- containing just a pointer to a proxy or stub object.
+
+ Proc_Statements := New_List (
+
+ -- Get_RAS_Info (Pkg, Subp, PA);
+ -- if Origin = Local_Partition_Id and then not All_Calls_Remote then
+ -- return Fat_Type!(PA);
+ -- end if;
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc),
+ New_Occurrence_Of (Subp_Id, Loc),
+ New_Occurrence_Of (Proxy_Addr, Loc))),
- Append_List_To (Proc_Statements, New_List (
Make_Implicit_If_Statement (N,
Condition =>
Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Not (Loc,
- New_Occurrence_Of (All_Calls_Remote, Loc)),
- Right_Opnd =>
+ Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Origin, Loc),
Right_Opnd =>
Make_Function_Call (Loc,
New_Occurrence_Of (
- RTE (RE_Get_Local_Partition_Id), Loc)))),
-
+ RTE (RE_Get_Local_Partition_Id), Loc))),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ New_Occurrence_Of (All_Calls_Remote, Loc))),
Then_Statements => New_List (
- Set_Field (Name_Ras,
- OK_Convert_To (RTE (RE_Unsigned_64),
- New_Occurrence_Of (Local_Addr, Loc)))),
-
- Else_Statements => New_List (
- Set_Field (Name_Ras,
- Make_Integer_Literal (Loc, Uint_0)))),
+ Make_Return_Statement (Loc,
+ Unchecked_Convert_To (Fat_Type,
+ OK_Convert_To (RTE (RE_Address),
+ New_Occurrence_Of (Proxy_Addr, Loc)))))),
Set_Field (Name_Origin,
- Unchecked_Convert_To (Standard_Integer,
- New_Occurrence_Of (Origin, Loc))),
+ New_Occurrence_Of (Origin, Loc)),
Set_Field (Name_Receiver,
Make_Function_Call (Loc,
@@ -1304,33 +1424,36 @@ package body Exp_Dist is
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))),
- Set_Field (Name_Subp_Id,
- New_Occurrence_Of (Subp_Id, Loc)),
+ Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
- Set_Field (Name_Async,
- New_Occurrence_Of (Asynch_P, Loc))));
+ Set_Field (Name_Asynchronous,
+ Make_Or_Else (Loc,
+ New_Occurrence_Of (Asynch_P, Loc),
+ New_Occurrence_Of (Boolean_Literals (
+ Is_Asynchronous (Ras_Type)), Loc))));
+ -- E.4.1(9) A remote call is asynchronous if it is a call to
+ -- a procedure, or a call through a value of an access-to-procedure
+ -- type, to which a pragma Asynchronous applies.
+ -- Parameter Asynch_P is true when the procedure is asynchronous;
+ -- Expression Asynch_T is true when the type is asynchronous.
+
+ Append_List_To (Proc_Statements,
+ Build_Get_Unique_RP_Call
+ (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
-- Return the newly created value
Append_To (Proc_Statements,
Make_Return_Statement (Loc,
Expression =>
- New_Occurrence_Of (Return_Value, Loc)));
-
- Proc :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
+ Unchecked_Convert_To (Fat_Type,
+ New_Occurrence_Of (Stub_Ptr, Loc))));
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier => Local_Addr,
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
-
- Make_Parameter_Specification (Loc,
Defining_Identifier => Package_Name,
Parameter_Type =>
New_Occurrence_Of (Standard_String, Loc)),
@@ -1338,7 +1461,7 @@ package body Exp_Dist is
Make_Parameter_Specification (Loc,
Defining_Identifier => Subp_Id,
Parameter_Type =>
- New_Occurrence_Of (Standard_Natural, Loc)),
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynch_P,
@@ -1368,139 +1491,127 @@ package body Exp_Dist is
Statements => Proc_Statements)));
Set_TSS (Fat_Type, Proc);
+ end Add_RAS_Access_TSS;
- end Add_RAS_Access_Attribute;
-
- -----------------------------------
- -- Add_RAS_Dereference_Attribute --
- -----------------------------------
+ -----------------------------
+ -- Add_RAS_Dereference_TSS --
+ -----------------------------
- procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is
+ procedure Add_RAS_Dereference_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Type_Def : constant Node_Id := Type_Definition (N);
- Ras_Type : constant Entity_Id := Defining_Identifier (N);
-
- Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
+ RAS_Type : constant Entity_Id := Defining_Identifier (N);
+ Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
+ RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
+ Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
- Proc_Decls : constant List_Id := New_List;
- Proc_Statements : constant List_Id := New_List;
+ Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
- Inner_Decls : constant List_Id := New_List;
- Inner_Statements : constant List_Id := New_List;
+ RACW_Primitive_Name : Node_Id;
- Direct_Statements : constant List_Id := New_List;
+ Proc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
- Proc : Node_Id;
Proc_Spec : Node_Id;
- Param_Specs : constant List_Id := New_List;
+ Param_Specs : List_Id;
Param_Assoc : constant List_Id := New_List;
+ Stmts : constant List_Id := New_List;
- Pointer : Node_Id;
-
- Converted_Ras : Node_Id;
- Target_Partition : Node_Id;
- RPC_Receiver : Node_Id;
- Subprogram_Id : Node_Id;
- Asynchronous : Node_Id;
+ RAS_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
+ Is_Degenerate : Boolean;
+ -- Set to True if the subprogram_specification for this RAS has
+ -- an anonymous access parameter (see Process_Remote_AST_Declaration).
+
Spec : constant Node_Id := Type_Def;
Current_Parameter : Node_Id;
begin
- -- The way to do it is test if the Ras field is non-null and then if
- -- the Origin field is equal to the current partition ID (which is in
- -- fact Current_Package'Partition_ID). If this is the case, then it
- -- is safe to dereference the Ras field directly rather than
- -- performing a remote call.
+ Param_Specs := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => RAS_Parameter,
+ In_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (Fat_Type, Loc)));
- Pointer :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Is_Degenerate := False;
+ Current_Parameter := First (Parameter_Specifications (Type_Def));
+ Parameters : while Current_Parameter /= Empty loop
+ if Nkind (Parameter_Type (Current_Parameter))
+ = N_Access_Definition
+ then
+ Is_Degenerate := True;
+ end if;
+ Append_To (Param_Specs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Current_Parameter))),
+ In_Present => In_Present (Current_Parameter),
+ Out_Present => Out_Present (Current_Parameter),
+ Parameter_Type =>
+ New_Copy_Tree (Parameter_Type (Current_Parameter)),
+ Expression =>
+ New_Copy_Tree (Expression (Current_Parameter))));
+
+ Append_To (Param_Assoc,
+ Make_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Current_Parameter))));
- Target_Partition :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Next (Current_Parameter);
+ end loop Parameters;
- Append_To (Proc_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Target_Partition,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Partition_ID),
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin)))));
-
- RPC_Receiver :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Receiver));
-
- Subprogram_Id :=
- Unchecked_Convert_To (RTE (RE_Subprogram_Id),
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Subp_Id)));
-
- -- A function is never asynchronous. A procedure may or may not be
- -- asynchronous depending on whether a pragma Asynchronous applies
- -- on it. Since a RAST may point onto various subprograms, this is
- -- only known at runtime so both versions (synchronous and asynchronous)
- -- must be built every times it is not a function.
+ if Is_Degenerate then
+ Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
- if Is_Function then
- Asynchronous := Empty;
+ -- Generate a dummy body recursing on the Dereference TSS, since
+ -- actually it will never be executed.
+
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
else
- Asynchronous :=
+ Prepend_To (Param_Assoc,
+ Unchecked_Convert_To (RACW_Type,
+ New_Occurrence_Of (RAS_Parameter, Loc)));
+
+ RACW_Primitive_Name :=
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
+ Prefix =>
+ New_Occurrence_Of (Scope (RACW_Type), Loc),
Selector_Name =>
- Make_Identifier (Loc, Name_Async));
-
+ Make_Identifier (Loc, Name_Call));
end if;
- if Present (Parameter_Specifications (Type_Def)) then
- Current_Parameter := First (Parameter_Specifications (Type_Def));
-
- while Current_Parameter /= Empty loop
- Append_To (Param_Specs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars =>
- Chars (Defining_Identifier (Current_Parameter))),
- In_Present => In_Present (Current_Parameter),
- Out_Present => Out_Present (Current_Parameter),
- Parameter_Type =>
- New_Copy_Tree (Parameter_Type (Current_Parameter)),
- Expression =>
- New_Copy_Tree (Expression (Current_Parameter))));
-
- Append_To (Param_Assoc,
- Make_Identifier (Loc,
- Chars => Chars (Defining_Identifier (Current_Parameter))));
+ if Is_Function then
+ Append_To (Stmts,
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc)));
- Next (Current_Parameter);
- end loop;
+ else
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc));
end if;
- Proc :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference));
+ -- Build the complete subprogram.
if Is_Function then
Proc_Spec :=
@@ -1512,7 +1623,6 @@ package body Exp_Dist is
Entity (Subtype_Mark (Spec)), Loc));
Set_Ekind (Proc, E_Function);
-
Set_Etype (Proc,
New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
@@ -1526,96 +1636,213 @@ package body Exp_Dist is
Set_Etype (Proc, Standard_Void_Type);
end if;
- -- Build the calling stubs for the dereference of the RAS
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification => Proc_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)));
- Build_General_Calling_Stubs
- (Decls => Inner_Decls,
- Statements => Inner_Statements,
- Target_Partition => Target_Partition,
- RPC_Receiver => RPC_Receiver,
- Subprogram_Id => Subprogram_Id,
- Asynchronous => Asynchronous,
- Is_Known_Non_Asynchronous => Is_Function,
- Is_Function => Is_Function,
- Spec => Proc_Spec,
- Nod => N);
-
- Converted_Ras :=
- Unchecked_Convert_To (Ras_Type,
- OK_Convert_To (RTE (RE_Address),
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pointer, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Ras))));
+ Set_TSS (Fat_Type, Proc);
+ end Add_RAS_Dereference_TSS;
- if Is_Function then
- Append_To (Direct_Statements,
- Make_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix => Converted_Ras),
- Parameter_Associations => Param_Assoc)));
+ -------------------------------
+ -- Add_RAS_Proxy_And_Analyze --
+ -------------------------------
- else
- Append_To (Direct_Statements,
+ procedure Add_RAS_Proxy_And_Analyze
+ (Decls : List_Id;
+ Vis_Decl : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : out Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Vis_Decl);
+
+ Subp_Name : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Vis_Decl));
+
+ Pkg_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (Subp_Name), 'P', -1));
+
+ Proxy_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (
+ Related_Id => Chars (Subp_Name),
+ Suffix => 'P'));
+
+ Proxy_Type_Full_View : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars (Proxy_Type));
+
+ Subp_Decl_Spec : constant Node_Id :=
+ Build_RAS_Primitive_Specification
+ (Subp_Spec => Specification (Vis_Decl),
+ Remote_Object_Type => Proxy_Type);
+
+ Subp_Body_Spec : constant Node_Id :=
+ Build_RAS_Primitive_Specification
+ (Subp_Spec => Specification (Vis_Decl),
+ Remote_Object_Type => Proxy_Type);
+
+ Vis_Decls : constant List_Id := New_List;
+ Pvt_Decls : constant List_Id := New_List;
+ Actuals : constant List_Id := New_List;
+ Formal : Node_Id;
+ Perform_Call : Node_Id;
+
+ begin
+ -- type subpP is tagged limited private;
+
+ Append_To (Vis_Decls,
+ Make_Private_Type_Declaration (Loc,
+ Defining_Identifier => Proxy_Type,
+ Tagged_Present => True,
+ Limited_Present => True));
+
+ -- [subprogram] Call
+ -- (Self : access subpP;
+ -- ...other-formals...)
+ -- [return T];
+
+ Append_To (Vis_Decls,
+ Make_Subprogram_Declaration (Loc,
+ Specification => Subp_Decl_Spec));
+
+ -- A : constant System.Address;
+
+ Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
+
+ Append_To (Vis_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Proxy_Object_Addr,
+ Constant_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)));
+
+ -- private
+
+ -- type subpP is tagged limited record
+ -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
+ -- ...
+ -- end record;
+
+ Append_To (Pvt_Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Proxy_Type_Full_View,
+ Type_Definition =>
+ Build_Remote_Subprogram_Proxy_Type (Loc,
+ New_Occurrence_Of (All_Calls_Remote_E, Loc))));
+
+ -- Trick semantic analysis into swapping the public and
+ -- full view when freezing the public view.
+
+ Set_Comes_From_Source (Proxy_Type_Full_View, True);
+
+
+ -- procedure Call
+ -- (Self : access O;
+ -- ...other-formals...) is
+ -- begin
+ -- P (...other-formals...);
+ -- end Call;
+
+ -- function Call
+ -- (Self : access O;
+ -- ...other-formals...)
+ -- return T is
+ -- begin
+ -- return F (...other-formals...);
+ -- end Call;
+
+ if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
+ Perform_Call :=
Make_Procedure_Call_Statement (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix => Converted_Ras),
- Parameter_Associations => Param_Assoc));
+ Name =>
+ New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations =>
+ Actuals);
+ else
+ Perform_Call :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations =>
+ Actuals));
end if;
- Prepend_To (Param_Specs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Pointer,
- In_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (Fat_Type, Loc)));
-
- Append_To (Proc_Statements,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pointer, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Ras)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Uint_0)),
+ Formal := First (Parameter_Specifications (Subp_Decl_Spec));
+ pragma Assert (Present (Formal));
+ Next (Formal);
+
+ while Present (Formal) loop
+ Append_To (Actuals, New_Occurrence_Of (
+ Defining_Identifier (Formal), Loc));
+ Next (Formal);
+ end loop;
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Target_Partition, Loc),
- Right_Opnd =>
- Make_Function_Call (Loc,
- New_Occurrence_Of (
- RTE (RE_Get_Local_Partition_Id), Loc)))),
+ -- O : aliased subpP;
- Then_Statements =>
- Direct_Statements,
+ Append_To (Pvt_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Name_uO),
+ Aliased_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (Proxy_Type, Loc)));
- Else_Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => Inner_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Inner_Statements)))));
+ -- A : constant System.Address := O'Address;
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification => Proc_Spec,
- Declarations => Proc_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Proc_Statements)));
+ Append_To (Pvt_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Proxy_Object_Addr)),
+ Constant_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (
+ Defining_Identifier (Last (Pvt_Decls)), Loc),
+ Attribute_Name =>
+ Name_Address)));
- Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec));
+ Append_To (Decls,
+ Make_Package_Declaration (Loc,
+ Specification => Make_Package_Specification (Loc,
+ Defining_Unit_Name => Pkg_Name,
+ Visible_Declarations => Vis_Decls,
+ Private_Declarations => Pvt_Decls,
+ End_Label => Empty)));
+ Analyze (Last (Decls));
- end Add_RAS_Dereference_Attribute;
+ Append_To (Decls,
+ Make_Package_Body (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Pkg_Name)),
+ Declarations => New_List (
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Subp_Body_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Perform_Call))))));
+ Analyze (Last (Decls));
+ end Add_RAS_Proxy_And_Analyze;
-----------------------
-- Add_RAST_Features --
@@ -1633,8 +1860,8 @@ package body Exp_Dist is
return;
end if;
- Add_RAS_Dereference_Attribute (Vis_Decl);
- Add_RAS_Access_Attribute (Vis_Decl);
+ Add_RAS_Dereference_TSS (Vis_Decl);
+ Add_RAS_Access_TSS (Vis_Decl);
end Add_RAST_Features;
-----------------------------------------
@@ -1642,8 +1869,8 @@ package body Exp_Dist is
-----------------------------------------
procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id)
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
@@ -1658,20 +1885,78 @@ package body Exp_Dist is
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
- Subp_Id : Node_Id;
+ Lookup_RAS_Info : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ -- A remote subprogram is created to allow peers to look up
+ -- RAS information using subprogram ids.
+
+ Subp_Id : Node_Id;
-- Subprogram_Id as read from the incoming stream
Current_Declaration : Node_Id;
- Current_Subprogram_Number : Int := 0;
+ Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Current_Stubs : Node_Id;
- Actuals : List_Id;
+ Subp_Info_Array : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+
+ Subp_Info_List : constant List_Id := New_List;
Dummy_Register_Name : Name_Id;
Dummy_Register_Spec : Node_Id;
Dummy_Register_Decl : Node_Id;
Dummy_Register_Body : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : Entity_Id;
+
+ procedure Append_Stubs_To
+ (RPC_Receiver_Cases : List_Id;
+ Declaration : Node_Id;
+ Stubs : Node_Id;
+ Subprogram_Number : Int);
+ -- Add one case to the specified RPC receiver case list
+ -- associating Subprogram_Number with the subprogram declared
+ -- by Declaration, for which we have receiving stubs in Stubs.
+
+ procedure Append_Stubs_To
+ (RPC_Receiver_Cases : List_Id;
+ Declaration : Node_Id;
+ Stubs : Node_Id;
+ Subprogram_Number : Int)
+ is
+ Actuals : constant List_Id :=
+ New_List (New_Occurrence_Of (Stream_Parameter, Loc));
+ begin
+ if Nkind (Specification (Declaration)) = N_Function_Specification
+ or else not
+ Is_Asynchronous (Defining_Entity (Specification (Declaration)))
+ then
+ -- An asynchronous procedure does not want an output parameter
+ -- since no result and no exception will ever be returned.
+
+ Append_To (Actuals,
+ New_Occurrence_Of (Result_Parameter, Loc));
+ end if;
+
+ Append_To (RPC_Receiver_Cases,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_List (
+ Make_Integer_Literal (Loc, Subprogram_Number)),
+
+ Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (
+ Defining_Entity (Stubs), Loc),
+ Parameter_Associations =>
+ Actuals))));
+ end Append_Stubs_To;
+
+ -- Start of processing for Add_Receiving_Stubs_To_Declarations
+
begin
-- Building receiving stubs consist in several operations:
@@ -1724,14 +2009,78 @@ package body Exp_Dist is
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Subp_Id, Loc))));
+ -- A null subp_id denotes a call through a RAS, in which case the
+ -- next Uint_64 element in the stream is the address of the local
+ -- proxy object, from which we can retrieve the actual subprogram id.
+
+ Append_To (Pkg_RPC_Receiver_Statements,
+ Make_Implicit_If_Statement (Pkg_Spec,
+ Condition =>
+ Make_Op_Eq (Loc,
+ New_Occurrence_Of (Subp_Id, Loc),
+ Make_Integer_Literal (Loc, 0)),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Subp_Id, Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
+ OK_Convert_To (RTE (RE_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
+ Attribute_Name =>
+ Name_Input,
+ Expressions => New_List (
+ New_Occurrence_Of (Stream_Parameter, Loc))))),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Subp_Id))))));
+
+ All_Calls_Remote_E := Boolean_Literals (
+ Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
+
+ -- Build a subprogram for RAS information lookups
+
+ Current_Declaration :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Lookup_RAS_Info,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Subp_Id),
+ In_Present =>
+ True,
+ Parameter_Type =>
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
+ Append_To (Decls, Current_Declaration);
+ Analyze (Current_Declaration);
+
+ Current_Stubs := Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Current_Declaration,
+ Asynchronous => False);
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration =>
+ Current_Declaration,
+ Stubs =>
+ Current_Stubs,
+ Subprogram_Number => 1);
+
-- For each subprogram, the receiving stub will be built and a
-- case statement will be made on the Subprogram_Id to dispatch
-- to the right subprogram.
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
-
while Current_Declaration /= Empty loop
-
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
@@ -1739,6 +2088,8 @@ package body Exp_Dist is
Get_Subprogram_Id (Defining_Unit_Name (Specification (
Current_Declaration))));
+ -- Build receiving stub
+
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
@@ -1750,40 +2101,44 @@ package body Exp_Dist is
(Current_Declaration))));
Append_To (Decls, Current_Stubs);
-
Analyze (Current_Stubs);
- Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc));
+ -- Build RAS proxy
- if Nkind (Specification (Current_Declaration))
- = N_Function_Specification
- or else
- not Is_Asynchronous (
- Defining_Entity (Specification (Current_Declaration)))
- then
- -- An asynchronous procedure does not want an output parameter
- -- since no result and no exception will ever be returned.
-
- Append_To (Actuals,
- New_Occurrence_Of (Result_Parameter, Loc));
-
- end if;
-
- Append_To (Pkg_RPC_Receiver_Cases,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices =>
- New_List (
- Make_Integer_Literal (Loc, Current_Subprogram_Number)),
-
- Statements =>
- New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (
- Defining_Entity (Current_Stubs), Loc),
- Parameter_Associations =>
- Actuals))));
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl =>
+ Current_Declaration,
+ All_Calls_Remote_E =>
+ All_Calls_Remote_E,
+ Proxy_Object_Addr =>
+ Proxy_Object_Addr);
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the
+ -- subprograms table for this receiver. The aggregate
+ -- below must be kept consistent with the declaration
+ -- of type RCI_Subp_Info in System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc,
+ Current_Subprogram_Number)),
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Identifier (Loc, Name_Addr)),
+ Expression =>
+ New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration =>
+ Current_Declaration,
+ Stubs =>
+ Current_Stubs,
+ Subprogram_Number =>
+ Current_Subprogram_Number);
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
@@ -1811,6 +2166,53 @@ package body Exp_Dist is
New_Occurrence_Of (Subp_Id, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Info_Array,
+ Constant_Present => True,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc,
+ First_RCI_Subprogram_Id),
+ High_Bound =>
+ Make_Integer_Literal (Loc,
+ First_RCI_Subprogram_Id
+ + List_Length (Subp_Info_List) - 1))))),
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => Subp_Info_List)));
+ Analyze (Last (Decls));
+
+ Append_To (Decls,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => OK_Convert_To (RTE (RE_Unsigned_64),
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Expressions => New_List (
+ Convert_To (Standard_Integer,
+ Make_Identifier (Loc, Name_Subp_Id)))),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Addr))))))));
+ Analyze (Last (Decls));
+
Pkg_RPC_Receiver_Body :=
Make_Subprogram_Body (Loc,
Specification => Pkg_RPC_Receiver_Spec,
@@ -1867,7 +2269,17 @@ package body Exp_Dist is
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
- Name_Version))))));
+ Name_Version),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Length))))));
Append_To (Decls, Dummy_Register_Body);
Analyze (Dummy_Register_Body);
@@ -1878,9 +2290,9 @@ package body Exp_Dist is
-------------------
procedure Add_Stub_Type
- (Designated_Type : in Entity_Id;
- RACW_Type : in Entity_Id;
- Decls : in List_Id;
+ (Designated_Type : Entity_Id;
+ RACW_Type : Entity_Id;
+ Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
Object_RPC_Receiver : out Entity_Id;
@@ -1992,6 +2404,7 @@ package body Exp_Dist is
Defining_Identifier => Stub_Type_Access,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
Append_To (Decls, Stub_Type_Access_Declaration);
@@ -2152,19 +2565,16 @@ package body Exp_Dist is
Subprogram_Id)));
Current_Parameter := First (Ordered_Parameters_List);
-
while Current_Parameter /= Empty loop
-
declare
Typ : constant Node_Id :=
- Parameter_Type (Current_Parameter);
+ Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Constrained : Boolean;
Value : Node_Id;
Extra_Parameter : Entity_Id;
begin
-
if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
-- In the case of a controlling formal argument, we marshall
@@ -2370,19 +2780,18 @@ package body Exp_Dist is
-- have changed since they are remote, so we do not read them
-- from the stream.
- Current_Parameter :=
- First (Ordered_Parameters_List);
-
+ Current_Parameter := First (Ordered_Parameters_List);
while Current_Parameter /= Empty loop
-
declare
Typ : constant Node_Id :=
- Parameter_Type (Current_Parameter);
+ Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Value : Node_Id;
+
begin
- Value := New_Occurrence_Of
- (Defining_Identifier (Current_Parameter), Loc);
+ Value :=
+ New_Occurrence_Of
+ (Defining_Identifier (Current_Parameter), Loc);
if Nkind (Typ) = N_Access_Definition then
Value := Make_Explicit_Dereference (Loc, Value);
@@ -2392,7 +2801,7 @@ package body Exp_Dist is
end if;
if (Out_Present (Current_Parameter)
- or else Nkind (Typ) = N_Access_Definition)
+ or else Nkind (Typ) = N_Access_Definition)
and then Etyp /= Object_Type
then
Append_To (Non_Asynchronous_Statements,
@@ -2434,6 +2843,7 @@ package body Exp_Dist is
Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_True, Loc))));
+
Prepend_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
@@ -2443,6 +2853,7 @@ package body Exp_Dist is
Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_False, Loc))));
+
Append_To (Statements,
Make_Implicit_If_Statement (Nod,
Condition => Asynchronous,
@@ -2451,6 +2862,86 @@ package body Exp_Dist is
end if;
end Build_General_Calling_Stubs;
+ ------------------------------
+ -- Build_Get_Unique_RP_Call --
+ ------------------------------
+
+ function Build_Get_Unique_RP_Call
+ (Loc : Source_Ptr;
+ Pointer : Entity_Id;
+ Stub_Type : Entity_Id) return List_Id
+ is
+ begin
+ return New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
+ New_Occurrence_Of (Pointer, Loc)))),
+
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pointer, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Tag_Component
+ (Designated_Type (Etype (Pointer))), Loc)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stub_Type, Loc),
+ Attribute_Name =>
+ Name_Tag)));
+
+ -- Note: The assignment to Pointer._Tag is safe here because
+ -- we carefully ensured that Stub_Type has exactly the same layout
+ -- as System.Partition_Interface.RACW_Stub_Type.
+
+ end Build_Get_Unique_RP_Call;
+
+ ----------------------------------------
+ -- Build_Remote_Subprogram_Proxy_Type --
+ ----------------------------------------
+
+ function Build_Remote_Subprogram_Proxy_Type
+ (Loc : Source_Ptr;
+ ACR_Expression : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Record_Definition (Loc,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Component_List =>
+ Make_Component_List (Loc,
+
+ Component_Items => New_List (
+ Make_Component_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Name_All_Calls_Remote),
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ ACR_Expression),
+
+ Make_Component_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Name_Receiver),
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)),
+ New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
+
+ Make_Component_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Name_Subp_Id),
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
+ end Build_Remote_Subprogram_Proxy_Type;
+
-----------------------------------
-- Build_Ordered_Parameters_List --
-----------------------------------
@@ -2460,6 +2951,9 @@ package body Exp_Dist is
Unconstrained_List : List_Id;
Current_Parameter : Node_Id;
+ First_Parameter : Node_Id;
+ For_RAS : Boolean := False;
+
begin
if not Present (Parameter_Specifications (Spec)) then
return New_List;
@@ -2467,17 +2961,24 @@ package body Exp_Dist is
Constrained_List := New_List;
Unconstrained_List := New_List;
+ First_Parameter := First (Parameter_Specifications (Spec));
+
+ if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
+ and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
+ then
+ For_RAS := True;
+ end if;
-- Loop through the parameters and add them to the right list
- Current_Parameter := First (Parameter_Specifications (Spec));
+ Current_Parameter := First_Parameter;
while Current_Parameter /= Empty loop
-
- if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
+ if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
or else
- Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
+ Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
or else
- Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))
+ Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
+ and then not (For_RAS and then Current_Parameter = First_Parameter)
then
Append_To (Constrained_List, New_Copy (Current_Parameter));
else
@@ -2492,7 +2993,6 @@ package body Exp_Dist is
Append_List_To (Unconstrained_List, Constrained_List);
return Unconstrained_List;
-
end Build_Ordered_Parameters_List;
----------------------------------
@@ -2512,7 +3012,6 @@ package body Exp_Dist is
declare
Dist_OK : Entity_Id;
pragma Warnings (Off, Dist_OK);
-
begin
Dist_OK := RTE (RE_Params_Stream_Type);
end;
@@ -2549,8 +3048,7 @@ package body Exp_Dist is
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id)
- return Node_Id
+ Result_Parameter : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
@@ -2586,8 +3084,7 @@ package body Exp_Dist is
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id
+ New_Name : Name_Id := No_Name) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
@@ -2609,7 +3106,7 @@ package body Exp_Dist is
Spec_To_Use : Node_Id;
- procedure Insert_Partition_Check (Parameter : in Node_Id);
+ procedure Insert_Partition_Check (Parameter : Node_Id);
-- Check that the parameter has been elaborated on the same partition
-- than the controlling parameter (E.4(19)).
@@ -2617,7 +3114,7 @@ package body Exp_Dist is
-- Insert_Partition_Check --
----------------------------
- procedure Insert_Partition_Check (Parameter : in Node_Id) is
+ procedure Insert_Partition_Check (Parameter : Node_Id) is
Parameter_Entity : constant Entity_Id :=
Defining_Identifier (Parameter);
Condition : Node_Id;
@@ -2633,7 +3130,7 @@ package body Exp_Dist is
-- then
-- raise Constraint_Error;
-- end if;
- --
+
-- Condition contains the reversed condition. Also, Parameter is
-- dereferenced if it is an access type. We do not check that
-- Parameter is in Stub_Type since such a check has been inserted
@@ -2827,8 +3324,7 @@ package body Exp_Dist is
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
- Parent_Primitive : Entity_Id := Empty)
- return Node_Id
+ Parent_Primitive : Entity_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
@@ -2935,6 +3431,7 @@ package body Exp_Dist is
declare
Etyp : Entity_Id;
+ RACW_Controlling : Boolean;
Constrained : Boolean;
Object : Entity_Id;
Expr : Node_Id := Empty;
@@ -2943,9 +3440,11 @@ package body Exp_Dist is
Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Set_Ekind (Object, E_Variable);
- if
- Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
- then
+ RACW_Controlling :=
+ Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
+
+ if RACW_Controlling then
+
-- We have a controlling formal parameter. Read its address
-- rather than a real object. The address is in Unsigned_64
-- form.
@@ -2959,8 +3458,9 @@ package body Exp_Dist is
Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
if In_Present (Current_Parameter)
- or else not Out_Present (Current_Parameter)
- or else not Constrained
+ or else not Out_Present (Current_Parameter)
+ or else not Constrained
+ or else RACW_Controlling
then
-- If an input parameter is contrained, then its reading is
-- deferred until the beginning of the subprogram body. If
@@ -2968,7 +3468,7 @@ package body Exp_Dist is
-- the object declaration and the variable is set using
-- 'Input instead of 'Read.
- if Constrained then
+ if Constrained and then not RACW_Controlling then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
@@ -3024,7 +3524,6 @@ package body Exp_Dist is
if
Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
then
-
if Nkind (Parameter_Type (Current_Parameter)) /=
N_Access_Definition
then
@@ -3038,6 +3537,7 @@ package body Exp_Dist is
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc))))));
+
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
@@ -3049,6 +3549,7 @@ package body Exp_Dist is
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc)))));
end if;
+
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
@@ -3178,7 +3679,6 @@ package body Exp_Dist is
Parameter_Associations => Parameter_List));
Append_List_To (Statements, After_Statements);
-
end if;
if Asynchronous and then not Dynamically_Asynchronous then
@@ -3266,7 +3766,6 @@ package body Exp_Dist is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements,
Exception_Handlers => New_List (Excep_Handler)));
-
end Build_Subprogram_Receiving_Stubs;
------------------------
@@ -3278,14 +3777,14 @@ package body Exp_Dist is
Spec : Node_Id;
Object_Type : Entity_Id := Empty;
Stub_Type : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id
+ New_Name : Name_Id := No_Name) return Node_Id
is
Parameters : List_Id := No_List;
- Current_Parameter : Node_Id;
- Current_Type : Node_Id;
- Current_Etype : Entity_Id;
+ Current_Parameter : Node_Id;
+ Current_Identifier : Entity_Id;
+ Current_Type : Node_Id;
+ Current_Etype : Entity_Id;
Name_For_New_Spec : Name_Id;
@@ -3293,34 +3792,35 @@ package body Exp_Dist is
begin
if New_Name = No_Name then
+ pragma Assert (Nkind (Spec) = N_Function_Specification
+ or else Nkind (Spec) = N_Procedure_Specification);
+
Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
else
Name_For_New_Spec := New_Name;
end if;
if Present (Parameter_Specifications (Spec)) then
-
Parameters := New_List;
Current_Parameter := First (Parameter_Specifications (Spec));
-
while Current_Parameter /= Empty loop
-
- Current_Type := Parameter_Type (Current_Parameter);
+ Current_Identifier := Defining_Identifier (Current_Parameter);
+ Current_Type := Parameter_Type (Current_Parameter);
if Nkind (Current_Type) = N_Access_Definition then
Current_Etype := Entity (Subtype_Mark (Current_Type));
- if Object_Type = Empty then
+ if Present (Object_Type) then
+ pragma Assert (
+ Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Current_Etype, Loc));
+ Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
else
- pragma Assert
- (Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
- Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
+ Subtype_Mark =>
+ New_Occurrence_Of (Current_Etype, Loc));
end if;
else
@@ -3336,7 +3836,7 @@ package body Exp_Dist is
end if;
New_Identifier := Make_Defining_Identifier (Loc,
- Chars (Defining_Identifier (Current_Parameter)));
+ Chars (Current_Identifier));
Append_To (Parameters,
Make_Parameter_Specification (Loc,
@@ -3351,25 +3851,29 @@ package body Exp_Dist is
end loop;
end if;
- if Nkind (Spec) = N_Function_Specification then
- return
- Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars => Name_For_New_Spec),
- Parameter_Specifications => Parameters,
- Subtype_Mark =>
- New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+ case Nkind (Spec) is
- else
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars => Name_For_New_Spec),
- Parameter_Specifications => Parameters);
- end if;
+ when N_Function_Specification | N_Access_Function_Definition =>
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_For_New_Spec),
+ Parameter_Specifications => Parameters,
+ Subtype_Mark =>
+ New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+
+ when N_Procedure_Specification | N_Access_Procedure_Definition =>
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_For_New_Spec),
+ Parameter_Specifications => Parameters);
+ when others =>
+ raise Program_Error;
+ end case;
end Copy_Specification;
---------------------------
@@ -3398,7 +3902,7 @@ package body Exp_Dist is
-- Expand_All_Calls_Remote_Subprogram_Call --
---------------------------------------------
- procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is
+ procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
Loc : constant Source_Ptr := Sloc (N);
@@ -3468,7 +3972,7 @@ package body Exp_Dist is
-- Expand_Calling_Stubs_Bodies --
---------------------------------
- procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is
+ procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : constant Node_Id := Specification (Unit_Node);
Decls : constant List_Id := Visible_Declarations (Spec);
@@ -3483,7 +3987,7 @@ package body Exp_Dist is
-- Expand_Receiving_Stubs_Bodies --
-----------------------------------
- procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is
+ procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : Node_Id;
Decls : List_Id;
Temp : List_Id;
@@ -3543,7 +4047,7 @@ package body Exp_Dist is
function Get_Subprogram_Id (E : Entity_Id) return Int is
Current_Declaration : Node_Id;
- Result : Int := 0;
+ Result : Int := First_RCI_Subprogram_Id;
begin
pragma Assert
@@ -3698,8 +4202,7 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Entity_Id;
- Etyp : Entity_Id := Empty)
- return Node_Id
+ Etyp : Entity_Id := Empty) return Node_Id
is
Typ : Entity_Id;
@@ -3725,8 +4228,7 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id
+ Etyp : Entity_Id) return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
@@ -3754,8 +4256,7 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id
+ Etyp : Entity_Id) return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
@@ -3777,10 +4278,9 @@ package body Exp_Dist is
-- RACW_Type_Is_Asynchronous --
-------------------------------
- procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is
+ procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (N /= Empty);
-
begin
Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
end RACW_Type_Is_Asynchronous;
@@ -3791,8 +4291,7 @@ package body Exp_Dist is
function RCI_Package_Locator
(Loc : Source_Ptr;
- Package_Spec : Node_Id)
- return Node_Id
+ Package_Spec : Node_Id) return Node_Id
is
Inst : constant Node_Id :=
Make_Package_Instantiation (Loc,
@@ -3819,7 +4318,7 @@ package body Exp_Dist is
-----------------------------------------------
procedure Remote_Types_Tagged_Full_View_Encountered
- (Full_View : in Entity_Id)
+ (Full_View : Entity_Id)
is
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Full_View);
@@ -3848,4 +4347,26 @@ package body Exp_Dist is
return Unit_Name;
end Scope_Of_Spec;
+ --------------------------
+ -- Underlying_RACW_Type --
+ --------------------------
+
+ function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
+ Record_Type : Entity_Id;
+
+ begin
+ if Ekind (RAS_Typ) = E_Record_Type then
+ Record_Type := RAS_Typ;
+ else
+ pragma Assert (Present (Equivalent_Type (RAS_Typ)));
+ Record_Type := Equivalent_Type (RAS_Typ);
+ end if;
+
+ return
+ Etype (Subtype_Indication (
+ Component_Definition (
+ First (Component_Items (Component_List (
+ Type_Definition (Declaration_Node (Record_Type))))))));
+ end Underlying_RACW_Type;
+
end Exp_Dist;
Index: exp_dist.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dist.ads,v
retrieving revision 1.5
diff -u -p -r1.5 exp_dist.ads
--- exp_dist.ads 19 Apr 2004 15:19:58 -0000 1.5
+++ exp_dist.ads 9 Sep 2004 09:24:26 -0000
@@ -83,4 +83,21 @@ package Exp_Dist is
E : Entity_Id) return Node_Id;
-- Build a literal representing the remote subprogram identifier of E
+ function Copy_Specification
+ (Loc : Source_Ptr;
+ Spec : Node_Id;
+ Object_Type : Entity_Id := Empty;
+ Stub_Type : Entity_Id := Empty;
+ New_Name : Name_Id := No_Name) return Node_Id;
+ -- Build a subprogram specification from another one, or from
+ -- an access-to-subprogram definition. If Object_Type is not Empty
+ -- and any access to Object_Type is found, then it is replaced by an
+ -- access to Stub_Type. If New_Name is given, then it will be used as
+ -- the name for the newly created spec.
+
+ function Underlying_RACW_Type
+ (RAS_Typ : Entity_Id) return Entity_Id;
+ -- Given a remote access-to-subprogram type or its equivalent
+ -- record type, return the RACW type generated to implement it.
+
end Exp_Dist;
Index: exp_pakd.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_pakd.ads,v
retrieving revision 1.4
diff -u -p -r1.4 exp_pakd.ads
--- exp_pakd.ads 24 Apr 2003 17:54:01 -0000 1.4
+++ exp_pakd.ads 9 Sep 2004 09:24:26 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -119,9 +119,9 @@ package Exp_Pakd is
-- a packed array. There are two reasonable rules for deciding this:
-- Store the first bit at right end (low order) word. This means
- -- that the scaled subscript can be used directly as a right shift
+ -- that the scaled subscript can be used directly as a left shift
-- count (if we put bit 0 at the left end, then we need an extra
- -- subtract to compute the shift count.
+ -- subtract to compute the shift count).
-- Layout the bits so that if the packed boolean array is overlaid on
-- a record, using unchecked conversion, then bit 0 of the array is
@@ -156,7 +156,7 @@ package Exp_Pakd is
-- that a worthwhile price to pay for the consistency.
-- One more important point arises in the case where we have a constrained
- -- subtype of an unconstrained array. Take the case of 20-bits. For the
+ -- subtype of an unconstrained array. Take the case of 20 bits. For the
-- unconstrained representation, we would use an array of bytes:
-- Little-endian case
Index: gigi.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gigi.h,v
retrieving revision 1.30
diff -u -p -r1.30 gigi.h
--- gigi.h 26 Jul 2004 10:41:46 -0000 1.30
+++ gigi.h 9 Sep 2004 09:24:26 -0000
@@ -114,6 +114,22 @@ extern tree maybe_variable (tree);
position so that it is aligned to ALIGN bits and is SIZE bytes long. */
extern tree make_aligning_type (tree, int, tree);
+/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
+ if needed. We have already verified that SIZE and TYPE are large enough.
+
+ GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
+ to issue a warning.
+
+ IS_USER_TYPE is true if we must be sure we complete the original type.
+
+ DEFINITION is true if this type is being defined.
+
+ SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
+ set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
+ type. */
+extern tree maybe_pad_type (tree, tree, unsigned int, Entity_Id,
+ const char *, bool, bool, bool);
+
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
extern tree choices_to_gnu (tree, Node_Id);
@@ -446,8 +462,10 @@ extern void finish_record_type (tree, tr
RETURNS_UNCONSTRAINED is true if the function returns an unconstrained
object. RETURNS_BY_REF is true if the function returns by reference.
RETURNS_WITH_DSP is true if the function is to return with a
- depressed stack pointer. */
-extern tree create_subprog_type (tree, tree, tree, bool, bool, bool);
+ depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function
+ is to be passed (as its first parameter) the address of the place to copy
+ its result. */
+extern tree create_subprog_type (tree, tree, tree, bool, bool, bool, bool);
/* Return a copy of TYPE, but safe to modify in any way. */
extern tree copy_type (tree);
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.15
diff -u -p -r1.15 gnatbind.adb
--- gnatbind.adb 11 Jun 2004 10:47:29 -0000 1.15
+++ gnatbind.adb 9 Sep 2004 09:24:26 -0000
@@ -605,7 +605,7 @@ begin
Error_Msg
("?may result in missing run-time elaboration checks");
Error_Msg
- ("?use -gnatE, pragma Suppress (Elaboration_Checks) instead");
+ ("?use -gnatE, pragma Suppress (Elaboration_Check) instead");
end if;
-- Quit if some file needs compiling
Index: gnatdll.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatdll.adb,v
retrieving revision 1.7
diff -u -p -r1.7 gnatdll.adb
--- gnatdll.adb 24 Apr 2003 17:54:04 -0000 1.7
+++ gnatdll.adb 9 Sep 2004 09:24:26 -0000
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T D L L --
+-- G N A T D L L --
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
@@ -27,25 +27,20 @@
-- GNATDLL is a Windows specific tool for building a DLL.
-- Both relocatable and non-relocatable DLL's are supported
-with Ada.Text_IO;
-with Ada.Strings.Unbounded;
-with Ada.Exceptions;
-with Ada.Command_Line;
-with GNAT.OS_Lib;
-with GNAT.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Command_Line; use GNAT.Command_Line;
with Gnatvsn;
-with MDLL.Fil;
-with MDLL.Utl;
+with MDLL.Fil; use MDLL.Fil;
+with MDLL.Utl; use MDLL.Utl;
procedure Gnatdll is
- use GNAT;
- use Ada;
- use MDLL;
- use Ada.Strings.Unbounded;
-
- use type OS_Lib.Argument_List;
+ use type GNAT.OS_Lib.Argument_List;
procedure Syntax;
-- Print out usage
@@ -59,7 +54,7 @@ procedure Gnatdll is
procedure Check_Context;
-- Check the context before runing any commands to build the library
- Syntax_Error : exception;
+ Syntax_Error : exception;
-- Raised when a syntax error is detected, in this case a usage info will
-- be displayed.
@@ -76,31 +71,33 @@ procedure Gnatdll is
Default_DLL_Address : constant String := "0x11000000";
-- Default address for non relocatable DLL (Win32)
- Lib_Filename : Unbounded_String := Null_Unbounded_String;
+ Lib_Filename : Unbounded_String := Null_Unbounded_String;
-- The DLL filename that will be created (.dll)
- Def_Filename : Unbounded_String := Null_Unbounded_String;
+ Def_Filename : Unbounded_String := Null_Unbounded_String;
-- The definition filename (.def)
- List_Filename : Unbounded_String := Null_Unbounded_String;
+ List_Filename : Unbounded_String := Null_Unbounded_String;
-- The name of the file containing the objects file to put into the DLL
- DLL_Address : Unbounded_String :=
- To_Unbounded_String (Default_DLL_Address);
+ DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address);
-- The DLL's base address
- Objects_Files : Argument_List_Access := Null_Argument_List_Access;
+ Gen_Map_File : Boolean := False;
+ -- Set to True if a map file is to be generated
+
+ Objects_Files : Argument_List_Access := MDLL.Null_Argument_List_Access;
-- List of objects to put inside the library
- Ali_Files : Argument_List_Access := Null_Argument_List_Access;
+ Ali_Files : Argument_List_Access := MDLL.Null_Argument_List_Access;
-- For each Ada file specified, we keep arecord of the corresponding
-- ALI file. This list of SLI files is used to build the binder program.
- Options : Argument_List_Access := Null_Argument_List_Access;
- -- A list of options set in the command line.
+ Options : Argument_List_Access := MDLL.Null_Argument_List_Access;
+ -- A list of options set in the command line
- Largs_Options : Argument_List_Access := Null_Argument_List_Access;
- Bargs_Options : Argument_List_Access := Null_Argument_List_Access;
+ Largs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access;
+ Bargs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access;
-- GNAT linker and binder args options
type Build_Mode_State is (Import_Lib, Dynamic_Lib, Dynamic_Lib_Only, Nil);
@@ -109,8 +106,8 @@ procedure Gnatdll is
-- Dynamic_Lib_Only means that only the DLL will be created (no import
-- library).
- Build_Mode : Build_Mode_State := Nil;
- -- Will be set when parsing the command line.
+ Build_Mode : Build_Mode_State := Nil;
+ -- Will be set when parsing the command line
Must_Build_Relocatable : Boolean := True;
-- True means build a relocatable DLL, will be set to False if a
@@ -121,10 +118,7 @@ procedure Gnatdll is
------------
procedure Syntax is
- use Text_IO;
-
- procedure P (Str : in String) renames Text_IO.Put_Line;
-
+ procedure P (Str : String) renames Put_Line;
begin
P ("Usage : gnatdll [options] [list-of-files]");
New_Line;
@@ -148,6 +142,7 @@ procedure Gnatdll is
P (" -a[addr] Build non-relocatable DLL at address <addr>");
P (" if <addr> is not specified use "
& Default_DLL_Address);
+ P (" -m Generate map file");
P (" -n No-import - do not create the import library");
P (" -bargs opts opts are passed to the binder");
P (" -largs opts opts are passed to the linker");
@@ -159,9 +154,9 @@ procedure Gnatdll is
procedure Check (Filename : in String) is
begin
- if not OS_Lib.Is_Regular_File (Filename) then
- Exceptions.Raise_Exception (Context_Error'Identity,
- "Error: " & Filename & " not found.");
+ if not Is_Regular_File (Filename) then
+ Raise_Exception
+ (Context_Error'Identity, "Error: " & Filename & " not found.");
end if;
end Check;
@@ -186,29 +181,29 @@ procedure Gnatdll is
-- No, a better choice would be to use tables ???
-- Limits on what???
- Ofiles : OS_Lib.Argument_List (1 .. Max_Files);
+ Ofiles : Argument_List (1 .. Max_Files);
O : Positive := Ofiles'First;
-- List of object files to put in the library. O is the next entry
-- to be used.
- Afiles : OS_Lib.Argument_List (1 .. Max_Files);
+ Afiles : Argument_List (1 .. Max_Files);
A : Positive := Afiles'First;
- -- List of ALI files. A is the next entry to be used.
+ -- List of ALI files. A is the next entry to be used
- Gopts : OS_Lib.Argument_List (1 .. Max_Options);
+ Gopts : Argument_List (1 .. Max_Options);
G : Positive := Gopts'First;
- -- List of gcc options. G is the next entry to be used.
+ -- List of gcc options. G is the next entry to be used
- Lopts : OS_Lib.Argument_List (1 .. Max_Options);
+ Lopts : Argument_List (1 .. Max_Options);
L : Positive := Lopts'First;
-- A list of -largs options (L is next entry to be used)
- Bopts : OS_Lib.Argument_List (1 .. Max_Options);
+ Bopts : Argument_List (1 .. Max_Options);
B : Positive := Bopts'First;
-- A list of -bargs options (B is next entry to be used)
Build_Import : Boolean := True;
- -- Set to Fals if option -n if specified (no-import).
+ -- Set to Fals if option -n if specified (no-import)
--------------
-- Add_File --
@@ -216,7 +211,7 @@ procedure Gnatdll is
procedure Add_File (Filename : in String) is
begin
- if Fil.Is_Ali (Filename) then
+ if Is_Ali (Filename) then
Check (Filename);
@@ -226,7 +221,7 @@ procedure Gnatdll is
Afiles (A) := new String'(Filename);
A := A + 1;
- elsif Fil.Is_Obj (Filename) then
+ elsif Is_Obj (Filename) then
Check (Filename);
@@ -238,7 +233,7 @@ procedure Gnatdll is
else
-- Unknown file type
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"don't know what to do with " & Filename & " !");
end if;
@@ -249,19 +244,19 @@ procedure Gnatdll is
-------------------------
procedure Add_Files_From_List (List_Filename : in String) is
- File : Text_IO.File_Type;
+ File : File_Type;
Buffer : String (1 .. 500);
Last : Natural;
begin
- Text_IO.Open (File, Text_IO.In_File, List_Filename);
+ Open (File, In_File, List_Filename);
- while not Text_IO.End_Of_File (File) loop
- Text_IO.Get_Line (File, Buffer, Last);
+ while not End_Of_File (File) loop
+ Get_Line (File, Buffer, Last);
Add_File (Buffer (1 .. Last));
end loop;
- Text_IO.Close (File);
+ Close (File);
end Add_Files_From_List;
-- Start of processing for Parse_Command_Line
@@ -272,7 +267,7 @@ procedure Gnatdll is
-- scan gnatdll switches
loop
- case Getopt ("g h v q k a? b: d: e: l: n I:") is
+ case Getopt ("g h v q k a? b: d: e: l: n m I:") is
when ASCII.Nul =>
exit;
@@ -290,7 +285,7 @@ procedure Gnatdll is
MDLL.Verbose := True;
if MDLL.Quiet then
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"impossible to use -q and -v together.");
end if;
@@ -301,7 +296,7 @@ procedure Gnatdll is
MDLL.Quiet := True;
if MDLL.Verbose then
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"impossible to use -v and -q together.");
end if;
@@ -343,11 +338,15 @@ procedure Gnatdll is
if Def_Filename = Null_Unbounded_String then
Def_Filename := To_Unbounded_String
- (Fil.Ext_To (Parameter, "def"));
+ (Ext_To (Parameter, "def"));
end if;
Build_Mode := Dynamic_Lib;
+ when 'm' =>
+
+ Gen_Map_File := True;
+
when 'n' =>
Build_Import := False;
@@ -361,7 +360,6 @@ procedure Gnatdll is
when others =>
raise Invalid_Switch;
-
end case;
end loop;
@@ -382,14 +380,12 @@ procedure Gnatdll is
loop
case Getopt ("*") is
-
when ASCII.Nul =>
exit;
when others =>
Lopts (L) := new String'(Full_Switch);
L := L + 1;
-
end case;
end loop;
@@ -416,12 +412,10 @@ procedure Gnatdll is
Add_Files_From_List (To_String (List_Filename));
end if;
- -- Check if the set of parameters are compatible.
+ -- Check if the set of parameters are compatible
- if Build_Mode = Nil and then not Help and then not Verbose then
- Exceptions.Raise_Exception
- (Syntax_Error'Identity,
- "nothing to do.");
+ if Build_Mode = Nil and then not Help and then not MDLL.Verbose then
+ Raise_Exception (Syntax_Error'Identity, "nothing to do.");
end if;
-- -n option but no file specified
@@ -430,7 +424,7 @@ procedure Gnatdll is
and then A = Afiles'First
and then O = Ofiles'First
then
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"-n specified but there are no objects to build the library.");
end if;
@@ -445,41 +439,49 @@ procedure Gnatdll is
Build_Mode := Import_Lib;
end if;
- -- Check if only a dynamic library must be built.
+ -- If map file is to be generated, add linker option here
+
+ if Gen_Map_File and then Build_Mode = Import_Lib then
+ Raise_Exception
+ (Syntax_Error'Identity,
+ "Can't generate a map file for an import library.");
+ end if;
+
+ -- Check if only a dynamic library must be built
if Build_Mode = Dynamic_Lib and then not Build_Import then
Build_Mode := Dynamic_Lib_Only;
end if;
if O /= Ofiles'First then
- Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1));
+ Objects_Files := new Argument_List'(Ofiles (1 .. O - 1));
end if;
if A /= Afiles'First then
- Ali_Files := new OS_Lib.Argument_List'(Afiles (1 .. A - 1));
+ Ali_Files := new Argument_List'(Afiles (1 .. A - 1));
end if;
if G /= Gopts'First then
- Options := new OS_Lib.Argument_List'(Gopts (1 .. G - 1));
+ Options := new Argument_List'(Gopts (1 .. G - 1));
end if;
if L /= Lopts'First then
- Largs_Options := new OS_Lib.Argument_List'(Lopts (1 .. L - 1));
+ Largs_Options := new Argument_List'(Lopts (1 .. L - 1));
end if;
if B /= Bopts'First then
- Bargs_Options := new OS_Lib.Argument_List'(Bopts (1 .. B - 1));
+ Bargs_Options := new Argument_List'(Bopts (1 .. B - 1));
end if;
exception
when Invalid_Switch =>
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
Message => "Invalid Switch " & Full_Switch);
when Invalid_Parameter =>
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
Message => "No parameter for " & Full_Switch);
@@ -512,9 +514,9 @@ begin
end if;
if MDLL.Verbose or else Help then
- Text_IO.New_Line;
- Text_IO.Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder");
- Text_IO.New_Line;
+ New_Line;
+ Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder");
+ New_Line;
end if;
MDLL.Utl.Locate;
@@ -544,7 +546,8 @@ begin
To_String (Def_Filename),
To_String (DLL_Address),
Build_Import => True,
- Relocatable => Must_Build_Relocatable);
+ Relocatable => Must_Build_Relocatable,
+ Map_File => Gen_Map_File);
when Dynamic_Lib_Only =>
MDLL.Build_Dynamic_Library
@@ -557,31 +560,30 @@ begin
To_String (Def_Filename),
To_String (DLL_Address),
Build_Import => False,
- Relocatable => Must_Build_Relocatable);
+ Relocatable => Must_Build_Relocatable,
+ Map_File => Gen_Map_File);
when Nil =>
null;
-
end case;
-
end if;
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
+ Set_Exit_Status (Success);
exception
when SE : Syntax_Error =>
- Text_IO.Put_Line ("Syntax error : " & Exceptions.Exception_Message (SE));
- Text_IO.New_Line;
+ Put_Line ("Syntax error : " & Exception_Message (SE));
+ New_Line;
Syntax;
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ Set_Exit_Status (Failure);
- when E : Tools_Error | Context_Error =>
- Text_IO.Put_Line (Exceptions.Exception_Message (E));
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ when E : MDLL.Tools_Error | Context_Error =>
+ Put_Line (Exception_Message (E));
+ Set_Exit_Status (Failure);
when others =>
- Text_IO.Put_Line ("gnatdll: INTERNAL ERROR. Please report");
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ Put_Line ("gnatdll: INTERNAL ERROR. Please report");
+ Set_Exit_Status (Failure);
end Gnatdll;
Index: gnatls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatls.adb,v
retrieving revision 1.19
diff -u -p -r1.19 gnatls.adb
--- gnatls.adb 13 Aug 2004 10:24:45 -0000 1.19
+++ gnatls.adb 9 Sep 2004 09:24:26 -0000
@@ -98,6 +98,8 @@ procedure Gnatls is
Dependable : Boolean := False; -- flag -d
Also_Predef : Boolean := False;
+ Very_Verbose_Mode : Boolean := False; -- flag -V
+
Unit_Start : Integer;
Unit_End : Integer;
Source_Start : Integer;
@@ -162,6 +164,20 @@ procedure Gnatls is
function Image (Restriction : Restriction_Id) return String;
-- Returns the capitalized image of Restriction
+ ---------------------------------------
+ -- GLADE specific output subprograms --
+ ---------------------------------------
+
+ package GLADE is
+
+ -- Any modification to this subunit requires a synchronization
+ -- with the GLADE implementation.
+
+ procedure Output_ALI (A : ALI_Id);
+ procedure Output_No_ALI (Afile : File_Name_Type);
+
+ end GLADE;
+
-----------------
-- Add_Lib_Dir --
-----------------
@@ -355,6 +371,409 @@ procedure Gnatls is
end Find_Status;
-----------
+ -- GLADE --
+ -----------
+
+ package body GLADE is
+
+ N_Flags : Natural;
+ N_Indents : Natural := 0;
+
+ type Token_Type is
+ (T_No_ALI,
+ T_ALI,
+ T_Unit,
+ T_With,
+ T_Source,
+ T_Afile,
+ T_Ofile,
+ T_Sfile,
+ T_Name,
+ T_Main,
+ T_Kind,
+ T_Flags,
+ T_Preelaborated,
+ T_Pure,
+ T_Has_RACW,
+ T_Remote_Types,
+ T_Shared_Passive,
+ T_RCI,
+ T_Predefined,
+ T_Internal,
+ T_Is_Generic,
+ T_Procedure,
+ T_Function,
+ T_Package,
+ T_Subprogram,
+ T_Spec,
+ T_Body);
+
+ Image : constant array (Token_Type) of String_Access :=
+ (T_No_ALI => new String'("No_ALI"),
+ T_ALI => new String'("ALI"),
+ T_Unit => new String'("Unit"),
+ T_With => new String'("With"),
+ T_Source => new String'("Source"),
+ T_Afile => new String'("Afile"),
+ T_Ofile => new String'("Ofile"),
+ T_Sfile => new String'("Sfile"),
+ T_Name => new String'("Name"),
+ T_Main => new String'("Main"),
+ T_Kind => new String'("Kind"),
+ T_Flags => new String'("Flags"),
+ T_Preelaborated => new String'("Preelaborated"),
+ T_Pure => new String'("Pure"),
+ T_Has_RACW => new String'("Has_RACW"),
+ T_Remote_Types => new String'("Remote_Types"),
+ T_Shared_Passive => new String'("Shared_Passive"),
+ T_RCI => new String'("RCI"),
+ T_Predefined => new String'("Predefined"),
+ T_Internal => new String'("Internal"),
+ T_Is_Generic => new String'("Is_Generic"),
+ T_Procedure => new String'("procedure"),
+ T_Function => new String'("function"),
+ T_Package => new String'("package"),
+ T_Subprogram => new String'("subprogram"),
+ T_Spec => new String'("spec"),
+ T_Body => new String'("body"));
+
+ procedure Output_Name (N : Name_Id);
+ -- Remove any encoding info (%b and %s) and output N
+
+ procedure Output_Afile (A : File_Name_Type);
+ procedure Output_Ofile (O : File_Name_Type);
+ procedure Output_Sfile (S : File_Name_Type);
+ -- Output various names. Check that the name is different from
+ -- no name. Otherwise, skip the output.
+
+ procedure Output_Token (T : Token_Type);
+ -- Output token using a specific format. That is several
+ -- indentations and:
+ --
+ -- T_No_ALI .. T_With : <token> & " =>" & NL
+ -- T_Source .. T_Kind : <token> & " => "
+ -- T_Flags : <token> & " =>"
+ -- T_Preelab .. T_Body : " " & <token>
+
+ procedure Output_Sdep (S : Sdep_Id);
+ procedure Output_Unit (U : Unit_Id);
+ procedure Output_With (W : With_Id);
+ -- Output this entry as a global section (like ALIs)
+
+ ------------------
+ -- Output_Afile --
+ ------------------
+
+ procedure Output_Afile (A : File_Name_Type) is
+ begin
+ if A /= No_File then
+ Output_Token (T_Afile);
+ Write_Name (A);
+ Write_Eol;
+ end if;
+ end Output_Afile;
+
+ ----------------
+ -- Output_ALI --
+ ----------------
+
+ procedure Output_ALI (A : ALI_Id) is
+ begin
+ Output_Token (T_ALI);
+ N_Indents := N_Indents + 1;
+
+ Output_Afile (ALIs.Table (A).Afile);
+ Output_Ofile (ALIs.Table (A).Ofile_Full_Name);
+ Output_Sfile (ALIs.Table (A).Sfile);
+
+ -- Output Main
+
+ if ALIs.Table (A).Main_Program /= None then
+ Output_Token (T_Main);
+
+ if ALIs.Table (A).Main_Program = Proc then
+ Output_Token (T_Procedure);
+ else
+ Output_Token (T_Function);
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- Output Units
+
+ for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop
+ Output_Unit (U);
+ end loop;
+
+ -- Output Sdeps
+
+ for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
+ Output_Sdep (S);
+ end loop;
+
+ N_Indents := N_Indents - 1;
+ end Output_ALI;
+
+ -------------------
+ -- Output_No_ALI --
+ -------------------
+
+ procedure Output_No_ALI (Afile : File_Name_Type) is
+ begin
+ Output_Token (T_No_ALI);
+ N_Indents := N_Indents + 1;
+ Output_Afile (Afile);
+ N_Indents := N_Indents - 1;
+ end Output_No_ALI;
+
+ -----------------
+ -- Output_Name --
+ -----------------
+
+ procedure Output_Name (N : Name_Id) is
+ begin
+ -- Remove any encoding info (%s or %b)
+
+ Get_Name_String (N);
+ if Name_Len > 2
+ and then Name_Buffer (Name_Len - 1) = '%'
+ then
+ Name_Len := Name_Len - 2;
+ end if;
+
+ Output_Token (T_Name);
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Eol;
+ end Output_Name;
+
+ ------------------
+ -- Output_Ofile --
+ ------------------
+
+ procedure Output_Ofile (O : File_Name_Type) is
+ begin
+ if O /= No_File then
+ Output_Token (T_Ofile);
+ Write_Name (O);
+ Write_Eol;
+ end if;
+ end Output_Ofile;
+
+ -----------------
+ -- Output_Sdep --
+ -----------------
+
+ procedure Output_Sdep (S : Sdep_Id) is
+ begin
+ Output_Token (T_Source);
+ Write_Name (Sdep.Table (S).Sfile);
+ Write_Eol;
+ end Output_Sdep;
+
+ ------------------
+ -- Output_Sfile --
+ ------------------
+
+ procedure Output_Sfile (S : File_Name_Type) is
+ FS : File_Name_Type := S;
+
+ begin
+ if FS /= No_File then
+
+ -- We want to output the full source name
+
+ FS := Full_Source_Name (FS);
+
+ -- There is no full source name. This occurs for instance when a
+ -- withed unit has a spec file but no body file. This situation
+ -- is not a problem for GLADE since the unit may be located on
+ -- a partition we do not want to build. However, we need to
+ -- locate the spec file and to find its full source name.
+ -- Replace the body file name with the spec file name used to
+ -- compile the current unit when possible.
+
+ if FS = No_File then
+ Get_Name_String (S);
+
+ if Name_Len > 4
+ and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
+ then
+ Name_Buffer (Name_Len) := 's';
+ FS := Full_Source_Name (Name_Find);
+ end if;
+ end if;
+ end if;
+
+ if FS /= No_File then
+ Output_Token (T_Sfile);
+ Write_Name (FS);
+ Write_Eol;
+ end if;
+ end Output_Sfile;
+
+ ------------------
+ -- Output_Token --
+ ------------------
+
+ procedure Output_Token (T : Token_Type) is
+ begin
+ if T in T_No_ALI .. T_Flags then
+ for J in 1 .. N_Indents loop
+ Write_Str (" ");
+ end loop;
+
+ Write_Str (Image (T).all);
+
+ for J in Image (T)'Length .. 12 loop
+ Write_Char (' ');
+ end loop;
+
+ Write_Str ("=>");
+
+ if T in T_No_ALI .. T_With then
+ Write_Eol;
+ elsif T in T_Source .. T_Name then
+ Write_Char (' ');
+ end if;
+
+ elsif T in T_Preelaborated .. T_Body then
+ if T in T_Preelaborated .. T_Is_Generic then
+ if N_Flags = 0 then
+ Output_Token (T_Flags);
+ end if;
+
+ N_Flags := N_Flags + 1;
+ end if;
+
+ Write_Char (' ');
+ Write_Str (Image (T).all);
+
+ else
+ Write_Str (Image (T).all);
+ end if;
+ end Output_Token;
+
+ -----------------
+ -- Output_Unit --
+ -----------------
+
+ procedure Output_Unit (U : Unit_Id) is
+ begin
+ Output_Token (T_Unit);
+ N_Indents := N_Indents + 1;
+
+ -- Output Name
+
+ Output_Name (Units.Table (U).Uname);
+
+ -- Output Kind
+
+ Output_Token (T_Kind);
+
+ if Units.Table (U).Unit_Kind = 'p' then
+ Output_Token (T_Package);
+ else
+ Output_Token (T_Subprogram);
+ end if;
+
+ if Name_Buffer (Name_Len) = 's' then
+ Output_Token (T_Spec);
+ else
+ Output_Token (T_Body);
+ end if;
+
+ Write_Eol;
+
+ -- Output source file name
+
+ Output_Sfile (Units.Table (U).Sfile);
+
+ -- Output Flags
+
+ N_Flags := 0;
+
+ if Units.Table (U).Preelab then
+ Output_Token (T_Preelaborated);
+ end if;
+
+ if Units.Table (U).Pure then
+ Output_Token (T_Pure);
+ end if;
+
+ if Units.Table (U).Has_RACW then
+ Output_Token (T_Has_RACW);
+ end if;
+
+ if Units.Table (U).Remote_Types then
+ Output_Token (T_Remote_Types);
+ end if;
+
+ if Units.Table (U).Shared_Passive then
+ Output_Token (T_Shared_Passive);
+ end if;
+
+ if Units.Table (U).RCI then
+ Output_Token (T_RCI);
+ end if;
+
+ if Units.Table (U).Predefined then
+ Output_Token (T_Predefined);
+ end if;
+
+ if Units.Table (U).Internal then
+ Output_Token (T_Internal);
+ end if;
+
+ if Units.Table (U).Is_Generic then
+ Output_Token (T_Is_Generic);
+ end if;
+
+ if N_Flags > 0 then
+ Write_Eol;
+ end if;
+
+ -- Output Withs
+
+ for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
+ Output_With (W);
+ end loop;
+
+ N_Indents := N_Indents - 1;
+ end Output_Unit;
+
+ -----------------
+ -- Output_With --
+ -----------------
+
+ procedure Output_With (W : With_Id) is
+ begin
+ Output_Token (T_With);
+ N_Indents := N_Indents + 1;
+
+ Output_Name (Withs.Table (W).Uname);
+
+ -- Output Kind
+
+ Output_Token (T_Kind);
+
+ if Name_Buffer (Name_Len) = 's' then
+ Output_Token (T_Spec);
+ else
+ Output_Token (T_Body);
+ end if;
+
+ Write_Eol;
+
+ Output_Afile (Withs.Table (W).Afile);
+ Output_Sfile (Withs.Table (W).Sfile);
+
+ N_Indents := N_Indents - 1;
+ end Output_With;
+
+ end GLADE;
+
+ -----------
-- Image --
-----------
@@ -629,6 +1048,7 @@ procedure Gnatls is
declare
Restrictions : constant Restrictions_Info :=
ALIs.Table (ALI).Restrictions;
+
begin
-- If the source was compiled with pragmas Restrictions,
-- Display these restrictions.
@@ -721,6 +1141,7 @@ procedure Gnatls is
procedure Scan_Ls_Arg (Argv : String) is
FD : File_Descriptor;
Len : Integer;
+
begin
pragma Assert (Argv'First = 1);
@@ -729,7 +1150,6 @@ procedure Gnatls is
end if;
if Argv (1) = '-' then
-
if Argv'Length = 1 then
Fail ("switch character cannot be followed by a blank");
@@ -782,6 +1202,7 @@ procedure Gnatls is
when 'o' => Reset_Print; Print_Object := True;
when 'v' => Verbose_Mode := True;
when 'd' => Dependable := True;
+ when 'V' => Very_Verbose_Mode := True;
when others => null;
end case;
@@ -911,9 +1332,6 @@ procedure Gnatls is
-----------
procedure Usage is
-
- -- Start of processing for Usage
-
begin
-- Usage line
@@ -1020,7 +1438,7 @@ procedure Gnatls is
end Usage;
- -- Start of processing for Gnatls
+-- Start of processing for Gnatls
begin
-- Initialize standard packages
@@ -1063,11 +1481,6 @@ begin
if Verbose_Mode then
Targparm.Get_Target_Parameters;
- -- WARNING: the output of gnatls -v is used during the compilation
- -- and installation of GLADE to recreate sdefault.adb and locate
- -- the libgnat.a to use. Any change in the output of gnatls -v must
- -- be synchronized with the GLADE Dist/config.sdefault shell script.
-
Write_Eol;
Write_Str ("GNATLS ");
Write_Str (Gnat_Version_String);
@@ -1132,15 +1545,20 @@ begin
while More_Lib_Files loop
Main_File := Next_Main_Lib_File;
- Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File));
+ Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File));
if Ali_File = No_File then
- Write_Str ("Can't find library info for ");
- Get_Name_String (Main_File);
- Write_Char ('"');
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Char ('"');
- Write_Eol;
+ if Very_Verbose_Mode then
+ GLADE.Output_No_ALI (Lib_File_Name (Main_File));
+
+ else
+ Write_Str ("Can't find library info for ");
+ Get_Name_String (Main_File);
+ Write_Char ('"'); -- "
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Char ('"'); -- "
+ Write_Eol;
+ end if;
else
Ali_File := Strip_Directory (Ali_File);
@@ -1166,6 +1584,14 @@ begin
end if;
end loop;
+ if Very_Verbose_Mode then
+ for A in ALIs.First .. ALIs.Last loop
+ GLADE.Output_ALI (A);
+ end loop;
+
+ return;
+ end if;
+
Find_General_Layout;
for Id in ALIs.First .. ALIs.Last loop
Index: g-pehage.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-pehage.adb,v
retrieving revision 1.1
diff -u -p -r1.1 g-pehage.adb
--- g-pehage.adb 21 Oct 2003 13:42:04 -0000 1.1
+++ g-pehage.adb 9 Sep 2004 09:24:26 -0000
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S --
+-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
-- --
-- B o d y --
-- --
--- 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- --
@@ -38,7 +38,7 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sor
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Table;
-package body GNAT.Perfect_Hash.Generators is
+package body GNAT.Perfect_Hash_Generators is
-- We are using the algorithm of J. Czech as described in Zbigniew
-- J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
@@ -2397,4 +2397,4 @@ package body GNAT.Perfect_Hash.Generator
end case;
end Value;
-end GNAT.Perfect_Hash.Generators;
+end GNAT.Perfect_Hash_Generators;
Index: g-pehage.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-pehage.ads,v
retrieving revision 1.1
diff -u -p -r1.1 g-pehage.ads
--- g-pehage.ads 21 Oct 2003 13:42:04 -0000 1.1
+++ g-pehage.ads 9 Sep 2004 09:24:26 -0000
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S --
+-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
-- --
-- S p e c --
-- --
--- 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- --
@@ -31,16 +31,45 @@
-- --
------------------------------------------------------------------------------
--- This package provides a single generator of static minimal perfect
--- hash functions. No collisions occur and each item can be retrieved
--- from the table in one probe (perfect property). The hash table
--- size corresponds to the exact size of W and *no larger* (minimal
--- property). The key set has to be know in advance (static
--- property). The hash functions are also order preservering. If w2
--- is inserted after w1 in the generator, then f (w1) < f (w2). These
--- hashing functions are convenient for use with realtime applications.
+-- This package provides a generator of static minimal perfect hash
+-- functions. To understand what a perfect hash function is, we
+-- define several notions. These definitions are inspired from the
+-- following paper:
+
+-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An
+-- Optimal Algorithm for Generating Minimal Perfect Hash Functions'',
+-- Information Processing Letters, 43(1992) pp.257-264, Oct.1992
+
+-- Let W be a set of m words. A hash function h is a function that
+-- maps the set of words W into some given interval of integers
+-- [0, k-1], where k is an integer, usually k >= m. h (w) where w
+-- is a word computes an address or an integer from I for the
+-- storage or the retrieval of that item. The storage area used to
+-- store items is known as a hash table. Words for which the same
+-- address is computed are called synonyms. Due to the existence
+-- of synonyms a situation called collision may arise in which two
+-- items w1 and w2 have the same address. Several schemes for
+-- resolving known. A perfect hash function is an injection from
+-- the word set W to the integer interval I with k >= m. If k = m,
+-- then h is a minimal perfect hash function. A hash function is
+-- order preserving if it puts entries into the hash table in a
+-- prespecified order.
+
+-- A minimal perfect hash function is defined by two properties:
+
+-- Since no collisions occur each item can be retrieved from the
+-- table in *one* probe. This represents the "perfect" property.
+
+-- The hash table size corresponds to the exact size of W and
+-- *no larger*. This represents the "minimal" property.
+
+-- The functions generated by this package require the key set to
+-- be known in advance (they are "static" hash functions).
+-- The hash functions are also order preservering. If w2 is inserted
+-- after w1 in the generator, then f (w1) < f (w2). These hashing
+-- functions are convenient for use with realtime applications.
-package GNAT.Perfect_Hash.Generators is
+package GNAT.Perfect_Hash_Generators is
Default_K_To_V : constant Float := 2.05;
-- Default ratio for the algorithm. When K is the number of keys,
@@ -57,7 +86,8 @@ package GNAT.Perfect_Hash.Generators is
Default_Optimization : constant Optimization := CPU_Time;
-- Optimize either the memory space or the execution time.
- Verbose : Boolean := False;
+ Verbose : Boolean := False;
+ -- Comment required ???
procedure Initialize
(Seed : Natural;
@@ -183,4 +213,4 @@ package GNAT.Perfect_Hash.Generators is
-- Return the value of the component (I, J) of the table
-- Name. When the table has only one dimension, J is ignored.
-end GNAT.Perfect_Hash.Generators;
+end GNAT.Perfect_Hash_Generators;
Index: g-trasym.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-trasym.ads,v
retrieving revision 1.8
diff -u -p -r1.8 g-trasym.ads
--- g-trasym.ads 25 Jun 2004 16:39:27 -0000 1.8
+++ g-trasym.ads 9 Sep 2004 09:24:26 -0000
@@ -52,8 +52,8 @@
-- On all platforms except VMS, this package is not intended to be used
-- within a shared library, symbolic tracebacks are only supported for the
--- main executable and not for shared libraries.
--- You should consider using gdb to obtain symbolic traceback in such cases.
+-- main executable and not for shared libraries. You should consider using
+-- gdb to obtain symbolic traceback in such cases.
-- On VMS, there is no restriction on using this facility with shared
-- libraries. However, the OS should be at least v7.3-1 and OS patch
Index: impunit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/impunit.adb,v
retrieving revision 1.13
diff -u -p -r1.13 impunit.adb
--- impunit.adb 17 Apr 2004 12:13:53 -0000 1.13
+++ impunit.adb 9 Sep 2004 09:24:26 -0000
@@ -224,8 +224,7 @@ package body Impunit is
"g-memdum", -- GNAT.Memory_Dump
"g-moreex", -- GNAT.Most_Recent_Exception
"g-os_lib", -- GNAT.Os_Lib
- "g-pehage", -- GNAT.Perfect_Hash.Generators
- "g-perhas", -- GNAT.Perfect_Hash
+ "g-pehage", -- GNAT.Perfect_Hash_Generators
"g-regexp", -- GNAT.Regexp
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.36
diff -u -p -r1.36 init.c
--- init.c 25 Jun 2004 16:39:28 -0000 1.36
+++ init.c 9 Sep 2004 09:24:26 -0000
@@ -111,6 +111,7 @@ int __gl_num_interrupt_states = 0;
int __gl_unreserve_all_interrupts = 0;
int __gl_exception_tracebacks = 0;
int __gl_zero_cost_exceptions = 0;
+int __gl_detect_blocking = 0;
/* Indication of whether synchronous signal handler has already been
installed by a previous call to adainit */
@@ -173,7 +174,8 @@ __gnat_set_globals (int main_priority,
int num_interrupt_states,
int unreserve_all_interrupts,
int exception_tracebacks,
- int zero_cost_exceptions)
+ int zero_cost_exceptions,
+ int detect_blocking)
{
static int already_called = 0;
@@ -236,6 +238,7 @@ __gnat_set_globals (int main_priority,
__gl_task_dispatching_policy = task_dispatching_policy;
__gl_unreserve_all_interrupts = unreserve_all_interrupts;
__gl_exception_tracebacks = exception_tracebacks;
+ __gl_detect_blocking = detect_blocking;
/* ??? __gl_zero_cost_exceptions is new in 3.15 and is referenced from
a-except.adb, which is also part of the compiler sources. Since the
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.22
diff -u -p -r1.22 lib-writ.adb
--- lib-writ.adb 13 Aug 2004 10:24:45 -0000 1.22
+++ lib-writ.adb 9 Sep 2004 09:24:26 -0000
@@ -856,6 +856,10 @@ package body Lib.Writ is
Write_Info_Str (" CE");
end if;
+ if Opt.Detect_Blocking then
+ Write_Info_Str (" DB");
+ end if;
+
if Opt.Float_Format /= ' ' then
Write_Info_Str (" F");
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.13
diff -u -p -r1.13 lib-writ.ads
--- lib-writ.ads 12 Feb 2004 13:28:10 -0000 1.13
+++ lib-writ.ads 9 Sep 2004 09:24:26 -0000
@@ -181,6 +181,9 @@ package Lib.Writ is
-- format will be correct and complete. Note that NO is
-- always present if CE is present.
--
+ -- DB Detect_Blocking pragma is in effect for all units in
+ -- this file.
+ --
-- FD Configuration pragmas apply to all the units in this
-- file specifying a possibly non-standard floating point
-- format (VAX float with Long_Float using D_Float)
Index: link.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/link.c,v
retrieving revision 1.12
diff -u -p -r1.12 link.c
--- link.c 21 Apr 2004 10:10:31 -0000 1.12
+++ link.c 9 Sep 2004 09:24:26 -0000
@@ -157,9 +157,9 @@ const char *__gnat_object_library_extens
char *__gnat_object_file_option = "";
char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
-int __gnat_link_max = 2147483647;
-unsigned char __gnat_objlist_file_supported = 0;
-unsigned char __gnat_using_gnu_linker = 0;
+int __gnat_link_max = 8192;
+unsigned char __gnat_objlist_file_supported = 1;
+unsigned char __gnat_using_gnu_linker = 1;
char *__gnat_object_library_extension = ".a";
#elif defined (linux)
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.94
diff -u -p -r1.94 Makefile.in
--- Makefile.in 9 Aug 2004 12:24:15 -0000 1.94
+++ Makefile.in 9 Sep 2004 09:24:26 -0000
@@ -308,7 +308,7 @@ GNATMAKE_OBJS = a-except.o ctrl_c.o ali.
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \
make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o osint-m.o output.o \
- prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
+ prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \
rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.11
diff -u -p -r1.11 Makefile.rtl
--- Makefile.rtl 20 Jul 2004 10:26:51 -0000 1.11
+++ Makefile.rtl 9 Sep 2004 09:24:26 -0000
@@ -219,6 +219,7 @@ GNATRTL_NONTASKING_OBJS= \
g-diopit$(objext) \
g-dirope$(objext) \
g-dyntab$(objext) \
+ g-dynhta$(objext) \
g-except$(objext) \
g-excact$(objext) \
g-exctra$(objext) \
@@ -235,7 +236,6 @@ GNATRTL_NONTASKING_OBJS= \
g-memdum$(objext) \
g-moreex$(objext) \
g-os_lib$(objext) \
- g-perhas$(objext) \
g-pehage$(objext) \
g-regexp$(objext) \
g-regpat$(objext) \
Index: mdll.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mdll.adb,v
retrieving revision 1.8
diff -u -p -r1.8 mdll.adb
--- mdll.adb 5 Jan 2004 15:20:45 -0000 1.8
+++ mdll.adb 9 Sep 2004 09:24:26 -0000
@@ -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- --
@@ -52,7 +52,8 @@ package body MDLL is
Def_Filename : String;
Lib_Address : String := "";
Build_Import : Boolean := False;
- Relocatable : Boolean := False)
+ Relocatable : Boolean := False;
+ Map_File : Boolean := False)
is
use type OS_Lib.Argument_List;
@@ -70,6 +71,7 @@ package body MDLL is
Lib_Opt : aliased String := "-mdll";
Out_Opt : aliased String := "-o";
Adr_Opt : aliased String := "-Wl,--image-base=" & Lib_Address;
+ Map_Opt : aliased String := "-Wl,-Map," & Lib_Filename & ".map";
L_Afiles : Argument_List := Afiles;
-- Local afiles list. This list can be reordered to ensure that the
@@ -97,12 +99,10 @@ package body MDLL is
procedure Build_Reloc_DLL is
-- Objects plus the export table (.exp) file
-
Objects_Exp_File : constant OS_Lib.Argument_List
:= Exp_File'Unchecked_Access & Ofiles;
Success : Boolean;
-
begin
if not Quiet then
Text_IO.Put_Line ("building relocatable DLL...");
@@ -147,10 +147,20 @@ package body MDLL is
-- 5) Build the dynamic library
- Utl.Gcc (Output_File => Dll_File,
- Files => Objects_Exp_File,
- Options => Adr_Opt'Unchecked_Access & All_Options,
- Build_Lib => True);
+ declare
+ Params : OS_Lib.Argument_List :=
+ Adr_Opt'Unchecked_Access & All_Options;
+ begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
+ Utl.Gcc
+ (Output_File => Dll_File,
+ Files => Objects_Exp_File,
+ Options => Params,
+ Build_Lib => True);
+ end;
OS_Lib.Delete_File (Exp_File, Success);
OS_Lib.Delete_File (Bas_File, Success);
@@ -234,7 +244,7 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : constant OS_Lib.Argument_List :=
+ Params : OS_Lib.Argument_List :=
Out_Opt'Unchecked_Access &
Dll_File'Unchecked_Access &
Lib_Opt'Unchecked_Access &
@@ -243,6 +253,10 @@ package body MDLL is
Ofiles &
All_Options;
begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
@@ -285,10 +299,19 @@ package body MDLL is
-- Build the DLL
- Utl.Gcc (Output_File => Dll_File,
- Files => Exp_File'Unchecked_Access & Ofiles,
- Options => Adr_Opt'Unchecked_Access & All_Options,
- Build_Lib => True);
+ declare
+ Params : OS_Lib.Argument_List :=
+ Adr_Opt'Unchecked_Access & All_Options;
+ begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
+ Utl.Gcc (Output_File => Dll_File,
+ Files => Exp_File'Unchecked_Access & Ofiles,
+ Options => Params,
+ Build_Lib => True);
+ end;
OS_Lib.Delete_File (Exp_File, Success);
@@ -330,7 +353,7 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : constant OS_Lib.Argument_List :=
+ Params : OS_Lib.Argument_List :=
Out_Opt'Unchecked_Access &
Dll_File'Unchecked_Access &
Lib_Opt'Unchecked_Access &
@@ -339,6 +362,10 @@ package body MDLL is
Ofiles &
All_Options;
begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
@@ -370,7 +397,6 @@ package body MDLL is
end if;
case Relocatable is
-
when True =>
if L_Afiles'Length = 0 then
Build_Reloc_DLL;
@@ -384,7 +410,6 @@ package body MDLL is
else
Ada_Build_Non_Reloc_DLL;
end if;
-
end case;
end Build_Dynamic_Library;
@@ -408,13 +433,11 @@ package body MDLL is
--------------------------
procedure Build_Import_Library (Def_Base_Filename : String) is
-
Def_File : String renames Def_Filename;
Dll_File : constant String := Def_Base_Filename & ".dll";
Lib_File : constant String := "lib" & Base_Filename & ".a";
begin
-
if not Quiet then
Text_IO.Put_Line ("Building import library...");
Text_IO.Put_Line ("make " & Lib_File &
Index: mdll.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mdll.ads,v
retrieving revision 1.5
diff -u -p -r1.5 mdll.ads
--- mdll.ads 24 Apr 2003 17:54:06 -0000 1.5
+++ mdll.ads 9 Sep 2004 09:24:26 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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 @@
-- to build Windows DLL
with GNAT.OS_Lib;
+-- Should have USE here ???
package MDLL is
@@ -36,20 +37,21 @@ package MDLL is
Null_Argument_List : constant Argument_List := (1 .. 0 => new String'(""));
- Null_Argument_List_Access : Argument_List_Access
- := new Argument_List (1 .. 0);
+ Null_Argument_List_Access : Argument_List_Access :=
+ new Argument_List (1 .. 0);
- Tools_Error : exception;
+ Tools_Error : exception;
+ -- Commment required
- Verbose : Boolean := False;
- Quiet : Boolean := False;
+ Verbose : Boolean := False;
+ Quiet : Boolean := False;
+ -- Comment required ???
+ Kill_Suffix : Boolean := False;
-- Kill_Suffix is used by dlltool to know whether or not the @nn suffix
-- should be removed from the exported names. When Kill_Suffix is set to
-- True then dlltool -k option is used.
- Kill_Suffix : Boolean := False;
-
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Afiles : Argument_List;
@@ -60,14 +62,16 @@ package MDLL is
Def_Filename : String;
Lib_Address : String := "";
Build_Import : Boolean := False;
- Relocatable : Boolean := False);
+ Relocatable : Boolean := False;
+ Map_File : Boolean := False);
-- Build a DLL and the import library to link against the DLL.
-- this function handles relocatable and non relocatable DLL.
-- If the Afiles argument list contains some Ada units then it will
-- generate the right adainit and adafinal and integrate it in the DLL.
-- If the Afiles argument list is empty (there is only some object files
-- provided) then it will not try to build a binder file. This is ok to
- -- build DLL containing no Ada code.
+ -- build DLL containing no Ada code. If Map_File is set to True, a map
+ -- file named Lib_Filename & ".map" will be created.
procedure Build_Import_Library
(Lib_Filename : String;
Index: opt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.adb,v
retrieving revision 1.8
diff -u -p -r1.8 opt.adb
--- opt.adb 7 Jun 2004 14:16:22 -0000 1.8
+++ opt.adb 9 Sep 2004 09:24:26 -0000
@@ -98,7 +98,7 @@ package body Opt is
procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is
begin
if Internal_Unit then
- Ada_Version := Ada_Version_Default;
+ Ada_Version := Ada_Version_Runtime;
Dynamic_Elaboration_Checks := False;
Extensions_Allowed := True;
External_Name_Exp_Casing := As_Is;
Index: opt.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.ads,v
retrieving revision 1.21
diff -u -p -r1.21 opt.ads
--- opt.ads 26 Jul 2004 10:41:57 -0000 1.21
+++ opt.ads 9 Sep 2004 09:24:26 -0000
@@ -72,6 +72,10 @@ package Opt is
-- GNAT
-- Current Ada version for compiler
+ Ada_Version_Runtime : Ada_Version_Type := Ada_05;
+ -- GNAT
+ -- Ada version used to compile the runtime
+
Ada_Final_Suffix : constant String := "final";
Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix);
-- GNATBIND
Index: prj.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.ads,v
retrieving revision 1.24
diff -u -p -r1.24 prj.ads
--- prj.ads 9 Aug 2004 12:24:16 -0000 1.24
+++ prj.ads 9 Sep 2004 09:24:27 -0000
@@ -699,6 +699,9 @@ package Prj is
end record;
+ Project_Error : exception;
+ -- Raised by some subprograms in Prj.Attr.
+
function Empty_Project return Project_Data;
-- Return the representation of an empty project
Index: prj-attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-attr.adb,v
retrieving revision 1.15
diff -u -p -r1.15 prj-attr.adb
--- prj-attr.adb 15 Jul 2004 20:34:36 -0000 1.15
+++ prj-attr.adb 9 Sep 2004 09:24:27 -0000
@@ -24,8 +24,9 @@
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
-with Osint; use Osint;
+with Namet; use Namet;
+with Osint;
+with Prj.Com; use Prj.Com;
with Table;
with System.Case_Util; use System.Case_Util;
@@ -39,11 +40,13 @@ package body Prj.Attr is
-- Package names are preceded by 'P'
-- Attribute names are preceded by two letters:
+
-- The first letter is one of
-- 'S' for Single
-- 's' for Single with optional index
-- 'L' for List
-- 'l' for List of strings with optional indexes
+
-- The second letter is one of
-- 'V' for single variable
-- 'A' for associative array
@@ -186,90 +189,9 @@ package body Prj.Attr is
Initialized : Boolean := False;
-- A flag to avoid multiple initialization
- ----------------
- -- Attributes --
- ----------------
-
- type Attribute_Record is record
- Name : Name_Id;
- Var_Kind : Variable_Kind;
- Optional_Index : Boolean;
- Attr_Kind : Attribute_Kind;
- Next : Attr_Node_Id;
- end record;
- -- Data for an attribute
-
- package Attrs is
- new Table.Table (Table_Component_Type => Attribute_Record,
- Table_Index_Type => Attr_Node_Id,
- Table_Low_Bound => First_Attribute,
- Table_Initial => Attributes_Initial,
- Table_Increment => Attributes_Increment,
- Table_Name => "Prj.Attr.Attrs");
- -- The table of the attributes
-
- --------------
- -- Packages --
- --------------
-
- type Package_Record is record
- Name : Name_Id;
- Known : Boolean := True;
- First_Attribute : Attr_Node_Id;
- end record;
- -- Data for a package
-
- package Package_Attributes is
- new Table.Table (Table_Component_Type => Package_Record,
- Table_Index_Type => Pkg_Node_Id,
- Table_Low_Bound => First_Package,
- Table_Initial => Packages_Initial,
- Table_Increment => Packages_Increment,
- Table_Name => "Prj.Attr.Packages");
- -- The table of the packages
-
function Name_Id_Of (Name : String) return Name_Id;
-- Returns the Name_Id for Name in lower case
- -------------------
- -- Add_Attribute --
- -------------------
-
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id)
- is
- begin
- -- Only add the attribute if the package is already defined
-
- if To_Package /= Empty_Package then
- Attrs.Increment_Last;
- Attrs.Table (Attrs.Last) :=
- (Name => Attribute_Name,
- Var_Kind => Undefined,
- Optional_Index => False,
- Attr_Kind => Unknown,
- Next =>
- Package_Attributes.Table (To_Package.Value).First_Attribute);
- Package_Attributes.Table (To_Package.Value).First_Attribute :=
- Attrs.Last;
- Attribute_Node := (Value => Attrs.Last);
- end if;
- end Add_Attribute;
-
- -------------------------
- -- Add_Unknown_Package --
- -------------------------
-
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is
- begin
- Package_Attributes.Increment_Last;
- Id := (Value => Package_Attributes.Last);
- Package_Attributes.Table (Id.Value) :=
- (Name => Name, Known => False, First_Attribute => Empty_Attr);
- end Add_Unknown_Package;
-
-----------------------
-- Attribute_Kind_Of --
-----------------------
@@ -307,6 +229,7 @@ package body Prj.Attr is
Starting_At : Attribute_Node_Id) return Attribute_Node_Id
is
Id : Attr_Node_Id := Starting_At.Value;
+
begin
while Id /= Empty_Attr
and then Attrs.Table (Id).Name /= Name
@@ -386,7 +309,7 @@ package body Prj.Attr is
for Index in First_Package .. Package_Attributes.Last loop
if Package_Name = Package_Attributes.Table (Index).Name then
- Fail ("duplicate name """,
+ Osint.Fail ("duplicate name """,
Initialization_Data (Start .. Finish - 1),
""" in predefined packages.");
end if;
@@ -438,14 +361,14 @@ package body Prj.Attr is
Attr_Kind := Case_Insensitive_Associative_Array;
when 'b' =>
- if File_Names_Case_Sensitive then
+ if Osint.File_Names_Case_Sensitive then
Attr_Kind := Associative_Array;
else
Attr_Kind := Case_Insensitive_Associative_Array;
end if;
when 'c' =>
- if File_Names_Case_Sensitive then
+ if Osint.File_Names_Case_Sensitive then
Attr_Kind := Optional_Index_Associative_Array;
else
Attr_Kind :=
@@ -480,7 +403,7 @@ package body Prj.Attr is
for Index in First_Attribute .. Attrs.Last - 1 loop
if Attribute_Name = Attrs.Table (Index).Name then
- Fail ("duplicate attribute """,
+ Osint.Fail ("duplicate attribute """,
Initialization_Data (Start .. Finish - 1),
""" in " & Attribute_Location);
end if;
@@ -581,11 +504,13 @@ package body Prj.Attr is
begin
if Name'Length = 0 then
Fail ("cannot register an attribute with no name");
+ raise Project_Error;
end if;
if In_Package = Empty_Package then
Fail ("attempt to add attribute """, Name,
""" to an undefined package");
+ raise Project_Error;
end if;
Attr_Name := Name_Id_Of (Name);
@@ -603,7 +528,7 @@ package body Prj.Attr is
Get_Name_String
(Package_Attributes.Table (In_Package.Value).Name) &
"""");
- exit;
+ raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
@@ -613,7 +538,7 @@ package body Prj.Attr is
-- If Index_Is_File_Name, change the attribute kind if necessary
- if Index_Is_File_Name and then not File_Names_Case_Sensitive then
+ if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
case Attr_Kind is
when Associative_Array =>
Real_Attr_Kind := Case_Insensitive_Associative_Array;
@@ -645,14 +570,26 @@ package body Prj.Attr is
--------------------------
procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
- Pkg_Name : Name_Id;
+ Pkg_Name : Name_Id;
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
+ Id := Empty_Package;
+ return;
end if;
Pkg_Name := Name_Id_Of (Name);
+
+ for Index in Package_Attributes.First .. Package_Attributes.Last loop
+ if Package_Attributes.Table (Index).Name = Pkg_Name then
+ Fail ("cannot register a package with a non unique name""",
+ Name, """");
+ Id := Empty_Package;
+ return;
+ end if;
+ end loop;
+
Package_Attributes.Increment_Last;
Id := (Value => Package_Attributes.Last);
Package_Attributes.Table (Package_Attributes.Last) :=
@@ -672,6 +609,7 @@ package body Prj.Attr is
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
+ raise Project_Error;
end if;
Pkg_Name := Name_Id_Of (Name);
@@ -680,7 +618,7 @@ package body Prj.Attr is
if Package_Attributes.Table (Index).Name = Pkg_Name then
Fail ("cannot register a package with a non unique name""",
Name, """");
- exit;
+ raise Project_Error;
end if;
end loop;
@@ -692,7 +630,7 @@ package body Prj.Attr is
if Attrs.Table (Curr_Attr).Name = Attr_Name then
Fail ("duplicate attribute name """, Attributes (Index).Name,
""" in new package """ & Name & """");
- exit;
+ raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
@@ -701,7 +639,7 @@ package body Prj.Attr is
Attr_Kind := Attributes (Index).Attr_Kind;
if Attributes (Index).Index_Is_File_Name
- and then not File_Names_Case_Sensitive
+ and then not Osint.File_Names_Case_Sensitive
then
case Attr_Kind is
when Associative_Array =>
Index: prj-attr.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-attr.ads,v
retrieving revision 1.9
diff -u -p -r1.9 prj-attr.ads
--- prj-attr.ads 15 Jul 2004 20:34:36 -0000 1.9
+++ prj-attr.ads 9 Sep 2004 09:24:27 -0000
@@ -86,6 +86,12 @@ package Prj.Attr is
-- explicitly with Register_New_Package (see below).
type Attribute_Data_Array is array (Positive range <>) of Attribute_Data;
+ -- A list of attribute name/characteristics to be used as parameter of
+ -- procedure Register_New_Package below.
+
+ -- In the subprograms below, when it is specified that the subprogram
+ -- "fails", procedure Prj.Com.Fail is called. Unless it is specified
+ -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised.
procedure Register_New_Package
(Name : String;
@@ -93,11 +99,8 @@ package Prj.Attr is
-- Add a new package with its attributes.
-- This procedure can only be called after Initialize, but before any
-- other call to a service of the Project Managers.
- -- The name of the package must be unique. The names of the attributes
- -- must be different.
-
- -- The following declarations are only for the Project Manager, that is
- -- the packages of the Prj or MLib hierarchies.
+ -- Fail if the name of the package is empty or not unique, or if the names
+ -- of the attributes are not different.
----------------
-- Attributes --
@@ -168,9 +171,11 @@ package Prj.Attr is
-- Default value of Package_Node_Id objects
procedure Register_New_Package (Name : String; Id : out Package_Node_Id);
- -- Add a new package. Fails if the package has a duplicate name.
- -- Initially, the new package has no attributes. Id may be used to add
- -- attributes using procedure Register_New_Attribute below.
+ -- Add a new package. Fails if Name (the package name) is empty or is
+ -- already the name of a package, and set Id to Empty_Package,
+ -- if Prj.Com.Fail returns. Initially, the new package has no attributes.
+ -- Id may be used to add attributes using procedure Register_New_Attribute
+ -- below.
procedure Register_New_Attribute
(Name : String;
@@ -179,32 +184,21 @@ package Prj.Attr is
Var_Kind : Defined_Variable_Kind;
Index_Is_File_Name : Boolean := False;
Opt_Index : Boolean := False);
- -- Add a new attribute to registered package In_Package. Fails if the
- -- attribute has a duplicate name. See definition of type Attribute_Data
- -- above for the meaning of parameters Attr_Kind, Var_Kind,
+ -- Add a new attribute to registered package In_Package. Fails if Name
+ -- (the attribute name) is empty, if In_Package is Empty_Package or if
+ -- the attribute name has a duplicate name. See definition of type
+ -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
-- Index_Is_File_Name and Opt_Index.
function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id;
-- Returns the package node id of the package with name Name. Returns
-- Empty_Package if there is no package with this name.
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id);
- -- Add a new package. The Name cannot be the name of a predefined or
- -- already registered package.
-
function First_Attribute_Of
(Pkg : Package_Node_Id) return Attribute_Node_Id;
-- Returns the first attribute in the list of attributes of package Pkg.
-- Returns Empty_Attribute if Pkg is Empty_Package.
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id);
- -- Add an attribute to the list for package To_Package. Attribute_Name
- -- cannot be the name of an existing attribute of the package.
- -- Does nothing if To_Package is Empty_Package.
-
private
----------------
-- Attributes --
@@ -266,4 +260,46 @@ private
Package_First : constant Package_Node_Id := First_Package_Node_Id;
+ ----------------
+ -- Attributes --
+ ----------------
+
+ type Attribute_Record is record
+ Name : Name_Id;
+ Var_Kind : Variable_Kind;
+ Optional_Index : Boolean;
+ Attr_Kind : Attribute_Kind;
+ Next : Attr_Node_Id;
+ end record;
+ -- Data for an attribute
+
+ package Attrs is
+ new Table.Table (Table_Component_Type => Attribute_Record,
+ Table_Index_Type => Attr_Node_Id,
+ Table_Low_Bound => First_Attribute,
+ Table_Initial => Attributes_Initial,
+ Table_Increment => Attributes_Increment,
+ Table_Name => "Prj.Attr.Attrs");
+ -- The table of the attributes
+
+ --------------
+ -- Packages --
+ --------------
+
+ type Package_Record is record
+ Name : Name_Id;
+ Known : Boolean := True;
+ First_Attribute : Attr_Node_Id;
+ end record;
+ -- Data for a package
+
+ package Package_Attributes is
+ new Table.Table (Table_Component_Type => Package_Record,
+ Table_Index_Type => Pkg_Node_Id,
+ Table_Low_Bound => First_Package,
+ Table_Initial => Packages_Initial,
+ Table_Increment => Packages_Increment,
+ Table_Name => "Prj.Attr.Packages");
+ -- The table of the packages
+
end Prj.Attr;
Index: prj-dect.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-dect.adb,v
retrieving revision 1.14
diff -u -p -r1.14 prj-dect.adb
--- prj-dect.adb 15 Jul 2004 20:34:36 -0000 1.14
+++ prj-dect.adb 9 Sep 2004 09:24:27 -0000
@@ -24,17 +24,18 @@
-- --
------------------------------------------------------------------------------
-with Err_Vars; use Err_Vars;
-with Namet; use Namet;
-with Opt; use Opt;
-with Prj.Err; use Prj.Err;
-with Prj.Strt; use Prj.Strt;
-with Prj.Tree; use Prj.Tree;
-with Scans; use Scans;
+with Err_Vars; use Err_Vars;
+with Namet; use Namet;
+with Opt; use Opt;
+with Prj.Err; use Prj.Err;
+with Prj.Strt; use Prj.Strt;
+with Prj.Tree; use Prj.Tree;
+with Scans; use Scans;
with Snames;
-with Types; use Types;
-with Prj.Attr; use Prj.Attr;
-with Uintp; use Uintp;
+with Types; use Types;
+with Prj.Attr; use Prj.Attr;
+with Prj.Attr.PM; use Prj.Attr.PM;
+with Uintp; use Uintp;
package body Prj.Dect is
@@ -876,7 +877,6 @@ package body Prj.Dect is
-- Scan past "package"
Scan;
-
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Index: raise.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/raise.h,v
retrieving revision 1.8
diff -u -p -r1.8 raise.h
--- raise.h 15 Mar 2004 14:50:59 -0000 1.8
+++ raise.h 9 Sep 2004 09:24:27 -0000
@@ -65,7 +65,7 @@ extern void set_gnat_exit_status (int);
extern void __gnat_set_globals (int, int,
char, char, char, char,
char *, char *,
- int, int, int, int);
+ int, int, int, int, int);
extern void __gnat_initialize (void);
extern void __gnat_init_float (void);
extern void __gnat_install_handler (void);
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.50
diff -u -p -r1.50 sem_ch3.adb
--- sem_ch3.adb 13 Aug 2004 10:24:46 -0000 1.50
+++ sem_ch3.adb 9 Sep 2004 09:24:27 -0000
@@ -5594,12 +5594,13 @@ package body Sem_Ch3 is
elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
Record_Type_Definition (Empty, Derived_Type);
- -- STEP 5c: Process the record extension for non private tagged types.
+ -- STEP 5c: Process the record extension for non private tagged types
elsif not Private_Extension then
- -- Add the _parent field in the derived type.
- Expand_Derived_Record (Derived_Type, Type_Def);
+ -- Add the _parent field in the derived type
+
+ Expand_Record_Extension (Derived_Type, Type_Def);
-- Analyze the record extension
Index: sem_disp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_disp.adb,v
retrieving revision 1.8
diff -u -p -r1.8 sem_disp.adb
--- sem_disp.adb 6 Jul 2004 13:57:31 -0000 1.8
+++ sem_disp.adb 9 Sep 2004 09:24:27 -0000
@@ -150,7 +150,8 @@ package body Sem_Disp is
and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
then
Error_Msg_N
- ("Access parameter of a remote subprogram must be controlling",
+ ("access parameter of remote object primitive"
+ & " must be controlling",
Formal);
end if;
Index: sem_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_dist.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_dist.adb
--- sem_dist.adb 25 Jun 2004 16:39:31 -0000 1.13
+++ sem_dist.adb 9 Sep 2004 09:24:27 -0000
@@ -105,6 +105,55 @@ package body Sem_Dist is
end if;
end Add_Stub_Constructs;
+ ---------------------------------------
+ -- Build_RAS_Primitive_Specification --
+ ---------------------------------------
+
+ function Build_RAS_Primitive_Specification
+ (Subp_Spec : Node_Id;
+ Remote_Object_Type : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Subp_Spec);
+
+ Primitive_Spec : constant Node_Id :=
+ Copy_Specification (Loc,
+ Spec => Subp_Spec,
+ New_Name => Name_Call);
+
+ Subtype_Mark_For_Self : Node_Id;
+
+ begin
+ if No (Parameter_Specifications (Primitive_Spec)) then
+ Set_Parameter_Specifications (Primitive_Spec, New_List);
+ end if;
+
+ if Nkind (Remote_Object_Type) in N_Entity then
+ Subtype_Mark_For_Self :=
+ New_Occurrence_Of (Remote_Object_Type, Loc);
+ else
+ Subtype_Mark_For_Self := Remote_Object_Type;
+ end if;
+
+ Prepend_To (
+ Parameter_Specifications (Primitive_Spec),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ Subtype_Mark_For_Self)));
+
+ -- Trick later semantic analysis into considering this
+ -- operation as a primitive (dispatching) operation of
+ -- tagged type Obj_Type.
+
+ Set_Comes_From_Source (
+ Defining_Unit_Name (Primitive_Spec), True);
+
+ return Primitive_Spec;
+ end Build_RAS_Primitive_Specification;
+
-------------------------
-- Full_Qualified_Name --
-------------------------
@@ -295,7 +344,6 @@ package body Sem_Dist is
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
- Local_Addr : Node_Id;
begin
-- Check if we have to expand the access attribute
@@ -329,17 +377,11 @@ package body Sem_Dist is
All_Calls_Remote_E :=
Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
- Local_Addr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Remote_Subp, Loc),
- Attribute_Name => Name_Address);
-
Tick_Access_Conv_Call :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Attribute_Subp, Loc),
Parameter_Associations =>
New_List (
- Local_Addr,
Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc),
@@ -354,78 +396,165 @@ package body Sem_Dist is
------------------------------------
procedure Process_Remote_AST_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- User_Type : constant Node_Id := Defining_Identifier (N);
- Fat_Type : constant Entity_Id :=
+ Loc : constant Source_Ptr := Sloc (N);
+ User_Type : constant Node_Id := Defining_Identifier (N);
+ Scop : constant Entity_Id := Scope (User_Type);
+ Is_RCI : constant Boolean :=
+ Is_Remote_Call_Interface (Scop);
+ Is_RT : constant Boolean :=
+ Is_Remote_Types (Scop);
+ Type_Def : constant Node_Id := Type_Definition (N);
+
+ Parameter : Node_Id;
+ Is_Degenerate : Boolean;
+ -- True iff this RAS has an access formal parameter (see
+ -- Exp_Dist.Add_RAS_Dereference_TSS for details).
+
+ Subpkg : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Subpkg_Decl : Node_Id;
+ Vis_Decls : constant List_Id := New_List;
+ Priv_Decls : constant List_Id := New_List;
+
+ Obj_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (
+ Chars (User_Type), 'R'));
+
+
+ Full_Obj_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars (Obj_Type));
+
+ RACW_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (
+ Chars (User_Type), 'P'));
+
+ Fat_Type : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (User_Type));
- New_Type_Decl : Node_Id;
+ Fat_Type_Decl : Node_Id;
begin
- -- We add a record type declaration for the equivalent fat pointer type
- New_Type_Decl :=
+ -- The tagged private type, primitive operation and RACW
+ -- type associated with a RAS need to all be declared in
+ -- a subpackage of the one that contains the RAS declaration,
+ -- because the primitive of the object type, and the associated
+ -- primitive of the stub type, need to be dispatching operations
+ -- of these types, and the profile of the RAS might contain
+ -- tagged types declared in the same scope.
+
+ Append_To (Vis_Decls,
+ Make_Private_Type_Declaration (Loc,
+ Defining_Identifier => Obj_Type,
+ Abstract_Present => True,
+ Tagged_Present => True,
+ Limited_Present => True));
+
+ Append_To (Priv_Decls,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Fat_Type,
- Type_Definition =>
+ Defining_Identifier =>
+ Full_Obj_Type,
+ Type_Definition =>
Make_Record_Definition (Loc,
- Component_List =>
- Make_Component_List (Loc,
- Component_Items => New_List (
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Ras),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Origin),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Integer, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Receiver),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Subp_Id),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Natural, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Async),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Boolean, Loc)))))));
+ Abstract_Present => True,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Null_Present => True,
+ Component_List => Empty)));
+
+ Is_Degenerate := False;
+ Parameter := First (Parameter_Specifications (Type_Def));
+ Parameters : while Present (Parameter) loop
+ if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
+ Error_Msg_N ("formal parameter& has anonymous access type?",
+ Defining_Identifier (Parameter));
+ Is_Degenerate := True;
+ exit Parameters;
+ end if;
+ Next (Parameter);
+ end loop Parameters;
- Insert_After (N, New_Type_Decl);
+ if Is_Degenerate then
+ Error_Msg_NE (
+ "remote access-to-subprogram type& can only be null?",
+ Defining_Identifier (Parameter), User_Type);
+ -- The only legal value for a RAS with a formal parameter of an
+ -- anonymous access type is null, because it cannot be
+ -- subtype-Conformant with any legal remote subprogram declaration.
+ -- In this case, we cannot generate a corresponding primitive
+ -- operation.
+
+ else
+ Append_To (Vis_Decls,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification => Build_RAS_Primitive_Specification (
+ Subp_Spec => Type_Def,
+ Remote_Object_Type => Obj_Type)));
+ end if;
+
+ Append_To (Vis_Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => RACW_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Obj_Type, Loc),
+ Attribute_Name =>
+ Name_Class))));
+ Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
+ Set_Is_Remote_Types (RACW_Type, Is_RT);
+ -- ??? Object RPC receiver generation should be bypassed for this
+ -- RACW type, since actually calls will be received by the package
+ -- RPC receiver for the designated RCI subprogram.
+
+ Subpkg_Decl :=
+ Make_Package_Declaration (Loc,
+ Make_Package_Specification (Loc,
+ Defining_Unit_Name =>
+ Subpkg,
+ Visible_Declarations =>
+ Vis_Decls,
+ Private_Declarations =>
+ Priv_Decls,
+ End_Label =>
+ New_Occurrence_Of (Subpkg, Loc)));
+ Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
+ Set_Is_Remote_Types (Subpkg, Is_RT);
+ Insert_After_And_Analyze (N, Subpkg_Decl);
+
+ -- Many parts of the analyzer and expander expect
+ -- that the fat pointer type used to implement remote
+ -- access to subprogram types be a record.
+ -- Note: The structure of this type must be kept consistent
+ -- with the code generated by Remote_AST_Null_Value for the
+ -- corresponding 'null' expression.
+
+ Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Fat_Type,
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => New_List (
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Ras),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present =>
+ False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RACW_Type, Loc)))))));
Set_Equivalent_Type (User_Type, Fat_Type);
Set_Corresponding_Remote_Type (Fat_Type, User_Type);
+ Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl);
-- The reason we suppress the initialization procedure is that we know
-- that no initialization is required (even if Initialize_Scalars mode
@@ -506,8 +635,7 @@ package body Sem_Dist is
-- Remote_AST_E_Dereference --
------------------------------
- function Remote_AST_E_Dereference (P : Node_Id) return Boolean
- is
+ function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
begin
@@ -534,12 +662,11 @@ package body Sem_Dist is
-- Remote_AST_I_Dereference --
------------------------------
- function Remote_AST_I_Dereference (P : Node_Id) return Boolean
- is
+ function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
Deref : Node_Id;
- begin
+ begin
if Comes_From_Source (P)
and then (Is_Remote_Call_Interface (ET)
or else Is_Remote_Types (ET))
@@ -563,9 +690,8 @@ package body Sem_Dist is
---------------------------
function Remote_AST_Null_Value
- (N : Node_Id;
- Typ : Entity_Id)
- return Boolean
+ (N : Node_Id;
+ Typ : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Target_Type : Entity_Id;
@@ -603,12 +729,12 @@ package body Sem_Dist is
Rewrite (N,
Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Integer_Literal (Loc, 0), -- Ras
- Make_Integer_Literal (Loc, 0), -- Origin
- Make_Integer_Literal (Loc, 0), -- Receiver
- Make_Integer_Literal (Loc, 0), -- Subp_Id
- New_Occurrence_Of (Standard_False, Loc)))); -- Asyn
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Identifier (Loc, Name_Ras)),
+ Expression =>
+ Make_Null (Loc)))));
Analyze_And_Resolve (N, Target_Type);
return True;
end Remote_AST_Null_Value;
Index: sem_dist.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_dist.ads,v
retrieving revision 1.5
diff -u -p -r1.5 sem_dist.ads
--- sem_dist.ads 19 Apr 2004 15:20:06 -0000 1.5
+++ sem_dist.ads 9 Sep 2004 09:24:27 -0000
@@ -36,6 +36,13 @@ package Sem_Dist is
-- caller stubs, expansion takes place directly in the specification and
-- no additional compilation unit is created.
+ function Build_RAS_Primitive_Specification
+ (Subp_Spec : Node_Id;
+ Remote_Object_Type : Node_Id) return Node_Id;
+ -- Build a subprogram specification for the primitive operation of the
+ -- Remote_Object_Type used to implement a remote access-to-subprogram
+ -- type whose parameter profile is given by specification Subp_Spec.
+
function Is_All_Remote_Call (N : Node_Id) return Boolean;
-- Check whether a function or procedure call should be expanded into
-- a remote call, because the entity is declared in a package decl that
@@ -75,9 +82,8 @@ package Sem_Dist is
-- the previous function.
function Remote_AST_Null_Value
- (N : Node_Id;
- Typ : Entity_Id)
- return Boolean;
+ (N : Node_Id;
+ Typ : Entity_Id) return Boolean;
-- If N is a null value and Typ a remote access to subprogram type,
-- this function will check if null needs to be replaced with an
-- aggregate and will return True in this case. Otherwise, it will
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.41
diff -u -p -r1.41 sem_prag.adb
--- sem_prag.adb 1 Sep 2004 11:51:53 -0000 1.41
+++ sem_prag.adb 9 Sep 2004 09:24:28 -0000
@@ -2929,7 +2929,6 @@ package body Sem_Prag is
-- denoted entities in the same declarative part.
Hom_Id := Def_Id;
-
while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id);
@@ -4498,6 +4497,9 @@ package body Sem_Prag is
elsif Ekind (Nm) = E_Record_Type
and then Present (Corresponding_Remote_Type (Nm))
then
+ -- A record type that is the Equivalent_Type for
+ -- a remote access-to-subprogram type.
+
N := Declaration_Node (Corresponding_Remote_Type (Nm));
if Nkind (N) = N_Full_Type_Declaration
@@ -4507,6 +4509,13 @@ package body Sem_Prag is
L := Parameter_Specifications (Type_Definition (N));
Process_Async_Pragma;
+ if Is_Asynchronous (Nm)
+ and then Expander_Active
+ then
+ RACW_Type_Is_Asynchronous (
+ Underlying_RACW_Type (Nm));
+ end if;
+
else
Error_Pragma_Arg
("pragma% cannot reference access-to-function type",
Index: sem_type.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_type.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_type.adb
--- sem_type.adb 6 Jul 2004 13:57:31 -0000 1.14
+++ sem_type.adb 9 Sep 2004 09:24:28 -0000
@@ -141,7 +141,7 @@ package body Sem_Type is
-- visibility of these user-defined operations must be special-cased
-- to determine whether they hide or are hidden by predefined operators.
-- The form P."+" (x, y) requires additional handling.
- --
+
-- Concatenation is treated more conventionally: for every one-dimensional
-- array type we introduce a explicit concatenation operator. This is
-- necessary to handle the case of (element & element => array) which
@@ -154,7 +154,7 @@ package body Sem_Type is
procedure All_Overloads;
pragma Warnings (Off, All_Overloads);
- -- Debugging procedure: list full contents of Overloads table.
+ -- Debugging procedure: list full contents of Overloads table
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
@@ -197,7 +197,6 @@ package body Sem_Type is
begin
Get_First_Interp (N, Index, It);
-
while Present (It.Nam) loop
-- A user-defined subprogram hides another declared at an outer
@@ -234,8 +233,8 @@ package body Sem_Type is
exit;
elsif not In_Open_Scopes (Scope (Name))
- or else Scope_Depth (Scope (Name))
- <= Scope_Depth (Scope (It.Nam))
+ or else Scope_Depth (Scope (Name)) <=
+ Scope_Depth (Scope (It.Nam))
then
-- If ambiguity within instance, and entity is not an
-- implicit operation, save for later disambiguation.
@@ -297,9 +296,7 @@ package body Sem_Type is
elsif Nkind (N) = N_Function_Call then
Arg := First_Actual (N);
-
while Present (Arg) loop
-
if No (Universal_Interpretation (Arg)) then
return False;
end if;
@@ -338,7 +335,7 @@ package body Sem_Type is
or else Is_Potentially_Use_Visible (Vis_Type)
or else In_Use (Vis_Type)
or else (In_Use (Scope (Vis_Type))
- and then not Is_Hidden (Vis_Type))
+ and then not Is_Hidden (Vis_Type))
or else Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else In_Instance
@@ -354,8 +351,8 @@ package body Sem_Type is
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
- or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
- or else Scope (Vis_Type) = System_Aux_Id)
+ or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
+ or else Scope (Vis_Type) = System_Aux_Id)
then
null;
@@ -390,7 +387,7 @@ package body Sem_Type is
Set_Etype (N, T);
else
- -- Record both the operator or subprogram name, and its type.
+ -- Record both the operator or subprogram name, and its type
if Nkind (N) in N_Op or else Is_Entity_Name (N) then
Set_Entity (N, E);
@@ -504,12 +501,12 @@ package body Sem_Type is
for J in First_Interp .. All_Interp.Last - 1 loop
- -- Current homograph is not hidden. Add to overloads.
+ -- Current homograph is not hidden. Add to overloads
if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
exit;
- -- Homograph is hidden, unless it is a predefined operator.
+ -- Homograph is hidden, unless it is a predefined operator
elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
@@ -547,7 +544,7 @@ package body Sem_Type is
H := Homonym (H);
end loop;
- -- Scan list of homographs for use-visible entities only.
+ -- Scan list of homographs for use-visible entities only
H := Current_Entity (Ent);
@@ -576,7 +573,7 @@ package body Sem_Type is
if All_Interp.Last = First_Interp + 1 then
- -- The original interpretation is in fact not overloaded.
+ -- The original interpretation is in fact not overloaded
Set_Is_Overloaded (N, False);
end if;
@@ -666,7 +663,7 @@ package body Sem_Type is
then
return True;
- -- The context may be class wide.
+ -- The context may be class wide
elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2)
@@ -903,6 +900,10 @@ package body Sem_Type is
Predef_Subp : Entity_Id;
User_Subp : Entity_Id;
+ function Inherited_From_Actual (S : Entity_Id) return Boolean;
+ -- Determine whether one of the candidates is an operation inherited
+ -- by a type that is derived from an actual in an instantiation.
+
function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
-- Determine whether a subprogram is an actual in an enclosing
-- instance. An overloading between such a subprogram and one
@@ -914,6 +915,7 @@ package body Sem_Type is
-- ambiguities when two formal types have the same actual.
function Standard_Operator return Boolean;
+ -- Comment required ???
function Remove_Conversions return Interp;
-- Last chance for pathological cases involving comparisons on
@@ -932,6 +934,29 @@ package body Sem_Type is
-- pathology in the other direction with calls whose multiple overloaded
-- actuals make them truly unresolvable.
+ ---------------------------
+ -- Inherited_From_Actual --
+ ---------------------------
+
+ function Inherited_From_Actual (S : Entity_Id) return Boolean is
+ Par : constant Node_Id := Parent (S);
+ begin
+ if Nkind (Par) /= N_Full_Type_Declaration
+ or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
+ then
+ return False;
+ else
+ return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
+ and then
+ Is_Generic_Actual_Type (
+ Entity (Subtype_Indication (Type_Definition (Par))));
+ end if;
+ end Inherited_From_Actual;
+
+ --------------------------
+ -- Is_Actual_Subprogram --
+ --------------------------
+
function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
begin
return In_Open_Scopes (Scope (S))
@@ -947,7 +972,6 @@ package body Sem_Type is
function Matches (Actual, Formal : Node_Id) return Boolean is
T1 : constant Entity_Id := Etype (Actual);
T2 : constant Entity_Id := Etype (Formal);
-
begin
return T1 = T2
or else
@@ -969,9 +993,9 @@ package body Sem_Type is
Act2 : Node_Id;
begin
- It1 := No_Interp;
- Get_First_Interp (N, I, It);
+ It1 := No_Interp;
+ Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if not Is_Overloadable (It.Nam) then
@@ -1055,12 +1079,11 @@ package body Sem_Type is
Get_Next_Interp (I, It);
end loop;
- if Serious_Errors_Detected > 0 then
-
- -- After some error, a formal may have Any_Type and yield
- -- a spurious match. To avoid cascaded errors if possible,
- -- check for such a formal in either candidate.
+ -- After some error, a formal may have Any_Type and yield
+ -- a spurious match. To avoid cascaded errors if possible,
+ -- check for such a formal in either candidate.
+ if Serious_Errors_Detected > 0 then
declare
Formal : Entity_Id;
@@ -1115,17 +1138,15 @@ package body Sem_Type is
-- Start of processing for Disambiguate
begin
- -- Recover the two legal interpretations.
+ -- Recover the two legal interpretations
Get_First_Interp (N, I, It);
-
while I /= I1 loop
Get_Next_Interp (I, It);
end loop;
It1 := It;
Nam1 := It.Nam;
-
while I /= I2 loop
Get_Next_Interp (I, It);
end loop;
@@ -1154,12 +1175,12 @@ package body Sem_Type is
declare
Candidate : Interp := No_Interp;
+
begin
Get_First_Interp (N, I, It);
-
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
- or else Typ = Any_Type)
+ or else Typ = Any_Type)
and then
(It.Typ = Universal_Integer
or else It.Typ = Universal_Real)
@@ -1183,8 +1204,7 @@ package body Sem_Type is
end;
elsif Chars (Nam1) /= Name_Op_Not
- and then (Typ = Standard_Boolean
- or else Typ = Any_Boolean)
+ and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
then
-- Equality or comparison operation. Choose predefined operator
-- if arguments are universal. The node may be an operator, a
@@ -1215,7 +1235,6 @@ package body Sem_Type is
Universal_Interpretation (Arg1)
then
Get_First_Interp (N, I, It);
-
while Scope (It.Nam) /= Standard_Standard loop
Get_Next_Interp (I, It);
end loop;
@@ -1273,6 +1292,11 @@ package body Sem_Type is
-- node is overloaded, it did not resolve to the global entity in
-- the generic, and we choose the formal subprogram.
+ -- Finally, the ambiguity can be between an explicit subprogram and
+ -- one inherited (with different defaults) from an actual. In this
+ -- case the resolution was to the explicit declaration in the
+ -- generic, and remains so in the instance.
+
elsif In_Instance then
if Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement
@@ -1289,6 +1313,16 @@ package body Sem_Type is
elsif Is_Act2 and then not Is_Act1 then
return It2;
+
+ elsif Inherited_From_Actual (Nam1)
+ and then Comes_From_Source (Nam2)
+ then
+ return It2;
+
+ elsif Inherited_From_Actual (Nam2)
+ and then Comes_From_Source (Nam1)
+ then
+ return It1;
end if;
Actual := First_Actual (N);
@@ -1306,7 +1340,6 @@ package body Sem_Type is
end;
elsif Nkind (N) in N_Binary_Op then
-
if Matches (Left_Opnd (N), First_Formal (Nam1))
and then
Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
@@ -1317,7 +1350,6 @@ package body Sem_Type is
end if;
elsif Nkind (N) in N_Unary_Op then
-
if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
return It1;
else
@@ -1374,7 +1406,7 @@ package body Sem_Type is
then
if Is_Fixed_Point_Type (Typ)
and then (Chars (Nam1) = Name_Op_Multiply
- or else Chars (Nam1) = Name_Op_Divide)
+ or else Chars (Nam1) = Name_Op_Divide)
and then Ada_Version = Ada_83
then
if It2.Nam = Predef_Subp then
@@ -1393,7 +1425,6 @@ package body Sem_Type is
return It2;
end if;
end if;
-
end Disambiguate;
---------------------
@@ -1449,7 +1480,6 @@ package body Sem_Type is
begin
if Is_Overloaded (R) then
Get_First_Interp (R, I, It);
-
while Present (It.Typ) loop
if Covers (T, It.Typ) or else Covers (It.Typ, T) then
@@ -1474,8 +1504,7 @@ package body Sem_Type is
Set_Etype (R, TR);
- -- In the non-overloaded case, the Etype of R is already set
- -- correctly.
+ -- In the non-overloaded case, the Etype of R is already set correctly
else
null;
@@ -1542,7 +1571,6 @@ package body Sem_Type is
end if;
Map_Ptr := Headers (Hash (O_N));
-
while Present (Interp_Map.Table (Map_Ptr).Node) loop
if Interp_Map.Table (Map_Ptr).Node = O_N then
Int_Ind := Interp_Map.Table (Map_Ptr).Index;
@@ -1598,16 +1626,14 @@ package body Sem_Type is
else
Get_First_Interp (N, I, It);
-
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
- and then
- (Scope (It.Nam) /= Standard_Standard
- or else not Is_Invisible_Operator (N, Base_Type (Typ))))
-
+ and then
+ (Scope (It.Nam) /= Standard_Standard
+ or else not Is_Invisible_Operator (N, Base_Type (Typ))))
or else (not Is_Tagged_Type (Typ)
- and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (It.Typ, Typ))
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then Covers (It.Typ, Typ))
then
return True;
end if;
@@ -1685,7 +1711,6 @@ package body Sem_Type is
else
Get_First_Interp (R, Index, It);
-
loop
T2 := Specific_Type (T, It.Typ);
@@ -1714,7 +1739,6 @@ package body Sem_Type is
else
Typ := Any_Type;
Get_First_Interp (L, Index, It);
-
while Present (It.Typ) loop
Typ := Check_Right_Argument (It.Typ);
exit when Typ /= Any_Type;
@@ -1726,7 +1750,6 @@ package body Sem_Type is
-- If Typ is Any_Type, it means no compatible pair of types was found
if Typ = Any_Type then
-
if Nkind (Parent (L)) in N_Op then
Error_Msg_N ("incompatible types for operator", Parent (L));
@@ -1947,7 +1970,6 @@ package body Sem_Type is
New_F := First_Formal (New_S);
Old_F := First_Formal (Op);
Num := 0;
-
while Present (New_F) and then Present (Old_F) loop
Num := Num + 1;
Next_Formal (New_F);
@@ -2095,7 +2117,6 @@ package body Sem_Type is
-- Find end of Interp list and copy downward to erase the discarded one
II := I + 1;
-
while Present (All_Interp.Table (II).Typ) loop
II := II + 1;
end loop;
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.42
diff -u -p -r1.42 sem_util.adb
--- sem_util.adb 9 Aug 2004 12:24:21 -0000 1.42
+++ sem_util.adb 9 Sep 2004 09:24:28 -0000
@@ -41,7 +41,6 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Output; use Output;
with Opt; use Opt;
-with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
@@ -869,33 +868,23 @@ package body Sem_Util is
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
- Loc : constant Source_Ptr := Sloc (N);
begin
- -- N is one of the potentially blocking operations listed in
- -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
- -- before N if the context is a protected action. Otherwise, only issue
- -- a warning, since some users are relying on blocking operations
- -- inside protected objects.
- -- Indirect blocking through a subprogram call
- -- cannot be diagnosed statically without interprocedural analysis,
- -- so we do not attempt to do it here.
+ -- N is one of the potentially blocking operations listed in 9.5.1(8).
+ -- When pragma Detect_Blocking is active, the run time will raise
+ -- Program_Error. Here we only issue a warning, since we generally
+ -- support the use of potentially blocking operations in the absence
+ -- of the pragma.
+
+ -- Indirect blocking through a subprogram call cannot be diagnosed
+ -- statically without interprocedural analysis, so we do not attempt
+ -- to do it here.
S := Scope (Current_Scope);
-
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
- if Restricted_Profile then
- Insert_Before_And_Analyze (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Potentially_Blocking_Operation));
- Error_Msg_N ("potentially blocking operation, " &
- " Program Error will be raised at run time?", N);
-
- else
- Error_Msg_N
- ("potentially blocking operation in protected operation?", N);
- end if;
+ Error_Msg_N
+ ("potentially blocking operation in protected operation?", N);
return;
end if;
@@ -5781,10 +5770,9 @@ package body Sem_Util is
-- scope because the back end otherwise tries to allocate a
-- variable length temporary for the particular variant.
- -- ??? With tree-ssa, the back-end does not (yet) support these
- -- types either, so disable this optimization for now.
-
- if Has_Discriminants (Typ) then
+ if Opt.GCC_Version = 2
+ and then Has_Discriminants (Typ)
+ then
return True;
-- For GCC 3, or for a non-discriminated record in GCC 2, we are
Index: sem_util.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.ads,v
retrieving revision 1.15
diff -u -p -r1.15 sem_util.ads
--- sem_util.ads 9 Aug 2004 12:24:21 -0000 1.15
+++ sem_util.ads 9 Sep 2004 09:24:28 -0000
@@ -110,8 +110,7 @@ package Sem_Util is
procedure Check_Potentially_Blocking_Operation (N : Node_Id);
-- N is one of the statement forms that is a potentially blocking
- -- operation. If it appears within a protected action, emit warning
- -- and raise Program_Error.
+ -- operation. If it appears within a protected action, emit warning.
procedure Check_VMS (Construct : Node_Id);
-- Check that this the target is OpenVMS, and if so, return with
Index: s-parint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-parint.adb,v
retrieving revision 1.6
diff -u -p -r1.6 s-parint.adb
--- s-parint.adb 19 Apr 2004 15:20:13 -0000 1.6
+++ s-parint.adb 9 Sep 2004 09:24:28 -0000
@@ -45,8 +45,10 @@ package body System.Partition_Interface
type Pkg_Node;
type Pkg_List is access Pkg_Node;
type Pkg_Node is record
- Name : String_Access;
- Next : Pkg_List;
+ Name : String_Access;
+ Subp_Info : System.Address;
+ Subp_Info_Len : Integer;
+ Next : Pkg_List;
end record;
Pkg_Head : Pkg_List;
@@ -63,9 +65,9 @@ package body System.Partition_Interface
-- String prepended in top of shared passive packages
procedure Check
- (Name : in Unit_Name;
- Version : in String;
- RCI : in Boolean := True)
+ (Name : Unit_Name;
+ Version : String;
+ RCI : Boolean := True)
is
begin
null;
@@ -76,8 +78,7 @@ package body System.Partition_Interface
-----------------------------
function Get_Active_Partition_ID
- (Name : Unit_Name)
- return System.RPC.Partition_ID
+ (Name : Unit_Name) return System.RPC.Partition_ID
is
P : Pkg_List := Pkg_Head;
N : String := Lower (Name);
@@ -98,10 +99,7 @@ package body System.Partition_Interface
-- Get_Active_Version --
------------------------
- function Get_Active_Version
- (Name : Unit_Name)
- return String
- is
+ function Get_Active_Version (Name : Unit_Name) return String is
begin
return "";
end Get_Active_Version;
@@ -120,8 +118,7 @@ package body System.Partition_Interface
------------------------------
function Get_Passive_Partition_ID
- (Name : Unit_Name)
- return System.RPC.Partition_ID
+ (Name : Unit_Name) return System.RPC.Partition_ID
is
begin
return Get_Local_Partition_ID;
@@ -131,21 +128,50 @@ package body System.Partition_Interface
-- Get_Passive_Version --
-------------------------
- function Get_Passive_Version
- (Name : Unit_Name)
- return String
- is
+ function Get_Passive_Version (Name : Unit_Name) return String is
begin
return "";
end Get_Passive_Version;
+ ------------------
+ -- Get_RAS_Info --
+ ------------------
+
+ procedure Get_RAS_Info
+ (Name : Unit_Name;
+ Subp_Id : Subprogram_Id;
+ Proxy_Address : out Interfaces.Unsigned_64)
+ is
+ LName : constant String := Lower (Name);
+ N : Pkg_List;
+ begin
+ N := Pkg_Head;
+ while N /= null loop
+ if N.Name.all = LName then
+ declare
+ subtype Subprogram_Array is RCI_Subp_Info_Array
+ (First_RCI_Subprogram_Id ..
+ First_RCI_Subprogram_Id + N.Subp_Info_Len - 1);
+ Subprograms : Subprogram_Array;
+ for Subprograms'Address use N.Subp_Info;
+ pragma Import (Ada, Subprograms);
+ begin
+ Proxy_Address :=
+ Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr);
+ return;
+ end;
+ end if;
+ N := N.Next;
+ end loop;
+ Proxy_Address := 0;
+ end Get_RAS_Info;
+
------------------------------
-- Get_RCI_Package_Receiver --
------------------------------
function Get_RCI_Package_Receiver
- (Name : Unit_Name)
- return Interfaces.Unsigned_64
+ (Name : Unit_Name) return Interfaces.Unsigned_64
is
begin
return 0;
@@ -186,7 +212,7 @@ package body System.Partition_Interface
-------------------------------------
procedure Raise_Program_Error_Unknown_Tag
- (E : in Ada.Exceptions.Exception_Occurrence)
+ (E : Ada.Exceptions.Exception_Occurrence)
is
begin
Ada.Exceptions.Raise_Exception
@@ -235,11 +261,12 @@ package body System.Partition_Interface
------------------------------
procedure Register_Passive_Package
- (Name : in Unit_Name;
- Version : in String := "")
+ (Name : Unit_Name;
+ Version : String := "")
is
begin
- Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
+ Register_Receiving_Stub
+ (Passive_Prefix & Name, null, Version, System.Null_Address, 0);
end Register_Passive_Package;
-----------------------------
@@ -247,19 +274,23 @@ package body System.Partition_Interface
-----------------------------
procedure Register_Receiving_Stub
- (Name : in Unit_Name;
- Receiver : in RPC.RPC_Receiver;
- Version : in String := "")
- is
+ (Name : Unit_Name;
+ Receiver : RPC.RPC_Receiver;
+ Version : String := "";
+ Subp_Info : System.Address;
+ Subp_Info_Len : Integer)
+ is
+ N : constant Pkg_List :=
+ new Pkg_Node'(new String'(Lower (Name)),
+ Subp_Info, Subp_Info_Len,
+ Next => null);
begin
if Pkg_Tail = null then
- Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
- Pkg_Tail := Pkg_Head;
-
+ Pkg_Head := N;
else
- Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
- Pkg_Tail := Pkg_Tail.Next;
+ Pkg_Tail.Next := N;
end if;
+ Pkg_Tail := N;
end Register_Receiving_Stub;
---------
@@ -267,7 +298,7 @@ package body System.Partition_Interface
---------
procedure Run
- (Main : in Main_Subprogram_Type := null)
+ (Main : Main_Subprogram_Type := null)
is
begin
if Main /= null then
Index: s-parint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-parint.ads,v
retrieving revision 1.7
diff -u -p -r1.7 s-parint.ads
--- s-parint.ads 21 Apr 2004 10:10:32 -0000 1.7
+++ s-parint.ads 9 Sep 2004 09:24:28 -0000
@@ -45,8 +45,20 @@ package System.Partition_Interface is
type DSA_Implementation_Name is (No_DSA, GLADE_DSA, PolyORB_DSA);
DSA_Implementation : constant DSA_Implementation_Name := No_DSA;
+ -- RCI receiving stubs contain a table of descriptors for
+ -- all user subprograms exported by the unit.
+
type Subprogram_Id is new Natural;
- -- This type is used exclusively by stubs
+ First_RCI_Subprogram_Id : constant := 2;
+
+ type RCI_Subp_Info is record
+ Addr : System.Address;
+ -- Local address of the proxy object
+ end record;
+
+ type RCI_Subp_Info_Access is access all RCI_Subp_Info;
+ type RCI_Subp_Info_Array is array (Integer range <>) of
+ aliased RCI_Subp_Info;
subtype Unit_Name is String;
-- Name of Ada units
@@ -59,42 +71,49 @@ package System.Partition_Interface is
Addr : Interfaces.Unsigned_64;
Asynchronous : Boolean;
end record;
+
type RACW_Stub_Type_Access is access RACW_Stub_Type;
-- This type is used by the expansion to implement distributed objects.
-- Do not change its definition or its layout without updating
-- exp_dist.adb.
+ type RAS_Proxy_Type is tagged limited record
+ All_Calls_Remote : Boolean;
+ Receiver : System.Address;
+ Subp_Id : Subprogram_Id;
+ end record;
+
+ type RAS_Proxy_Type_Access is access RAS_Proxy_Type;
+ pragma No_Strict_Aliasing (RAS_Proxy_Type_Access);
+ -- This type is used by the expansion to implement distributed objects.
+ -- Do not change its definition or its layout without updating
+ -- Exp_Dist.Build_Remote_Supbrogram_Proxy_Type.
+
procedure Check
- (Name : in Unit_Name;
- Version : in String;
- RCI : in Boolean := True);
+ (Name : Unit_Name;
+ Version : String;
+ RCI : Boolean := True);
-- Use by the main subprogram to check that a remote receiver
-- unit has has the same version than the caller's one.
- function Get_Active_Partition_ID
- (Name : Unit_Name)
- return RPC.Partition_ID;
+ function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID;
-- Similar in some respects to RCI_Info.Get_Active_Partition_ID
- function Get_Active_Version
- (Name : Unit_Name)
- return String;
+ function Get_Active_Version (Name : Unit_Name) return String;
-- Similar in some respects to Get_Active_Partition_ID
function Get_Local_Partition_ID return RPC.Partition_ID;
-- Return the Partition_ID of the current partition
function Get_Passive_Partition_ID
- (Name : Unit_Name)
- return RPC.Partition_ID;
+ (Name : Unit_Name) return RPC.Partition_ID;
-- Return the Partition_ID of the given shared passive partition
function Get_Passive_Version (Name : Unit_Name) return String;
-- Return the version corresponding to a shared passive unit
function Get_RCI_Package_Receiver
- (Name : Unit_Name)
- return Interfaces.Unsigned_64;
+ (Name : Unit_Name) return Interfaces.Unsigned_64;
-- Similar in some respects to RCI_Info.Get_RCI_Package_Receiver
procedure Get_Unique_Remote_Pointer
@@ -102,20 +121,30 @@ package System.Partition_Interface is
-- Get a unique pointer on a remote object
procedure Raise_Program_Error_Unknown_Tag
- (E : in Ada.Exceptions.Exception_Occurrence);
+ (E : Ada.Exceptions.Exception_Occurrence);
pragma No_Return (Raise_Program_Error_Unknown_Tag);
-- Raise Program_Error with the same message as E one
procedure Register_Receiving_Stub
- (Name : in Unit_Name;
- Receiver : in RPC.RPC_Receiver;
- Version : in String := "");
+ (Name : Unit_Name;
+ Receiver : RPC.RPC_Receiver;
+ Version : String := "";
+ Subp_Info : System.Address;
+ Subp_Info_Len : Integer);
-- Register the fact that the Name receiving stub is now elaborated.
-- Register the access value to the package RPC_Receiver procedure.
+ procedure Get_RAS_Info
+ (Name : Unit_Name;
+ Subp_Id : Subprogram_Id;
+ Proxy_Address : out Interfaces.Unsigned_64);
+ -- Look up the address of the proxy object for the given subprogram
+ -- in the named unit, or Null_Address if not present on the local
+ -- partition.
+
procedure Register_Passive_Package
- (Name : in Unit_Name;
- Version : in String := "");
+ (Name : Unit_Name;
+ Version : String := "");
-- Register a passive package
generic
@@ -126,7 +155,7 @@ package System.Partition_Interface is
end RCI_Info;
-- RCI package information caching
- procedure Run (Main : in Main_Subprogram_Type := null);
+ procedure Run (Main : Main_Subprogram_Type := null);
-- Run the main subprogram
end System.Partition_Interface;
Index: s-taprob.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-taprob.adb,v
retrieving revision 1.7
diff -u -p -r1.7 s-taprob.adb
--- s-taprob.adb 20 Jul 2004 10:26:51 -0000 1.7
+++ s-taprob.adb 9 Sep 2004 09:24:28 -0000
@@ -39,6 +39,7 @@ pragma Polling (Off);
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Unlock
+-- Self
with System.Parameters;
-- used for Runtime_Traces
@@ -87,6 +88,7 @@ package body System.Tasking.Protected_Ob
procedure Lock (Object : Protection_Access) is
Ceiling_Violation : Boolean;
+
begin
-- The lock is made without defering abortion.
@@ -107,6 +109,19 @@ package body System.Tasking.Protected_Ob
if Ceiling_Violation then
raise Program_Error;
end if;
+
+ -- We are entering in a protected action, so that we increase the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+ begin
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end;
+ end if;
end Lock;
--------------------
@@ -115,6 +130,7 @@ package body System.Tasking.Protected_Ob
procedure Lock_Read_Only (Object : Protection_Access) is
Ceiling_Violation : Boolean;
+
begin
Read_Lock (Object.L'Access, Ceiling_Violation);
@@ -125,6 +141,19 @@ package body System.Tasking.Protected_Ob
if Ceiling_Violation then
raise Program_Error;
end if;
+
+ -- We are entering in a protected action, so that we increase the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+ begin
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end;
+ end if;
end Lock_Read_Only;
------------
@@ -133,6 +162,25 @@ package body System.Tasking.Protected_Ob
procedure Unlock (Object : Protection_Access) is
begin
+ -- We are exiting from a protected action, so that we decrease the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+
+ begin
+ -- Cannot call this procedure without being within a protected
+ -- action.
+
+ pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting - 1;
+ end;
+ end if;
+
Unlock (Object.L'Access);
if Parameters.Runtime_Traces then
Index: s-taskin.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-taskin.adb,v
retrieving revision 1.8
diff -u -p -r1.8 s-taskin.adb
--- s-taskin.adb 15 Jul 2004 20:34:41 -0000 1.8
+++ s-taskin.adb 9 Sep 2004 09:24:28 -0000
@@ -83,6 +83,7 @@ package body System.Tasking is
T.Common.Parent := Parent;
T.Common.Base_Priority := Base_Priority;
T.Common.Current_Priority := 0;
+ T.Common.Protected_Action_Nesting := 0;
T.Common.Call := null;
T.Common.Task_Arg := Task_Arg;
T.Common.Task_Entry_Point := Task_Entry_Point;
Index: s-taskin.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-taskin.ads,v
retrieving revision 1.10
diff -u -p -r1.10 s-taskin.ads
--- s-taskin.ads 15 Jul 2004 20:34:41 -0000 1.10
+++ s-taskin.ads 9 Sep 2004 09:24:28 -0000
@@ -335,13 +335,18 @@ package System.Tasking is
------------------------------------
type Activation_Chain is limited private;
+ -- Comment required ???
type Activation_Chain_Access is access all Activation_Chain;
+ -- Comment required ???
type Task_Procedure_Access is access procedure (Arg : System.Address);
type Access_Boolean is access all Boolean;
+ Detect_Blocking : constant Boolean;
+ -- Boolean constant set True iff Detect_Blocking is active
+
----------------------------------------------
-- Ada_Task_Control_Block (ATCB) definition --
----------------------------------------------
@@ -421,6 +426,14 @@ package System.Tasking is
-- accepts an entry or when Created activates, at which points Self is
-- suspended.
+ Protected_Action_Nesting : Natural;
+ pragma Atomic (Protected_Action_Nesting);
+ -- The dynamic level of protected action nesting for this task.
+ -- This field is needed for checking whether potentially
+ -- blocking operations are invoked from protected actions.
+ -- pragma Atomic is used because it can be read/written from
+ -- protected interrupt handlers.
+
Task_Image : String (1 .. 32);
-- Hold a string that provides a readable id for task,
-- built from the variable of which it is a value or component.
@@ -969,6 +982,14 @@ package System.Tasking is
private
Null_Task : constant Task_Id := null;
+ GL_Detect_Blocking : Integer;
+ pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking");
+ -- Global variable exported by the binder generated file. A value
+ -- equal to 1 indicates that pragma Detect_Blocking is active,
+ -- while 0 is used for the pragma not being present.
+
+ Detect_Blocking : constant Boolean := GL_Detect_Blocking = 1;
+
type Activation_Chain is record
T_ID : Task_Id;
end record;
Index: s-tasren.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tasren.adb,v
retrieving revision 1.8
diff -u -p -r1.8 s-tasren.adb
--- s-tasren.adb 17 May 2004 13:20:44 -0000 1.8
+++ s-tasren.adb 9 Sep 2004 09:24:28 -0000
@@ -102,6 +102,10 @@ package body System.Tasking.Rendezvous i
Accept_Alternative_Open,
No_Alternative_Open);
+ ----------------
+ -- Local Data --
+ ----------------
+
Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
(Simple_Mode => No_Alternative_Open,
Else_Mode => Else_Selected,
@@ -391,7 +395,19 @@ package body System.Tasking.Rendezvous i
Uninterpreted_Data : System.Address)
is
Rendezvous_Successful : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then STPO.Self.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
Call_Synchronous
(Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
end Call_Simple;
@@ -1309,6 +1325,17 @@ package body System.Tasking.Rendezvous i
Entry_Call : Entry_Call_Link;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
end if;
@@ -1668,6 +1695,17 @@ package body System.Tasking.Rendezvous i
Yielded : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
Initialization.Defer_Abort (Self_Id);
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
Index: s-tassta.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tassta.adb,v
retrieving revision 1.10
diff -u -p -r1.10 s-tassta.adb
--- s-tassta.adb 15 Jul 2004 20:34:41 -0000 1.10
+++ s-tassta.adb 9 Sep 2004 09:24:28 -0000
@@ -226,6 +226,17 @@ package body System.Tasking.Stages is
procedure Abort_Tasks (Tasks : Task_List) is
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then STPO.Self.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
Utilities.Abort_Tasks (Tasks);
end Abort_Tasks;
@@ -266,6 +277,17 @@ package body System.Tasking.Stages is
All_Elaborated : Boolean := True;
begin
+ -- If pragma Detect_Blocking is active must be checked whether
+ -- this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_ID.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
pragma Debug
(Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
@@ -513,6 +535,17 @@ package body System.Tasking.Stages is
Len : Natural;
begin
+ -- If pragma Detect_Blocking is active must be checked whether
+ -- this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_ID.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
pragma Debug
(Debug.Trace (Self_ID, "Create_Task", 'C'));
Index: s-tpoben.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tpoben.adb,v
retrieving revision 1.6
diff -u -p -r1.6 s-tpoben.adb
--- s-tpoben.adb 17 May 2004 13:20:48 -0000 1.6
+++ s-tpoben.adb 9 Sep 2004 09:24:28 -0000
@@ -44,6 +44,7 @@
with Ada.Exceptions;
-- used for Exception_Occurrence_Access
+-- Raise_Exception
with System.Task_Primitives.Operations;
-- used for Initialize_Lock
@@ -72,6 +73,10 @@ package body System.Tasking.Protected_Ob
use Task_Primitives.Operations;
use Ada.Exceptions;
+ ----------------
+ -- Local Data --
+ ----------------
+
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
@@ -216,13 +221,36 @@ package body System.Tasking.Protected_Ob
------------------
procedure Lock_Entries
- (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
+ (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean)
+ is
begin
if Object.Finalized then
Raise_Exception
(Program_Error'Identity, "Protected Object is finalized");
end if;
+ -- If pragma Detect_Blocking is active then Program_Error must
+ -- be raised if this potentially blocking operation is called from
+ -- a protected action, and the protected object nesting level
+ -- must be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
-- The lock is made without defering abortion.
-- Therefore the abortion has to be deferred before calling this
@@ -239,14 +267,9 @@ package body System.Tasking.Protected_Ob
procedure Lock_Entries (Object : Protection_Entries_Access) is
Ceiling_Violation : Boolean;
- begin
- if Object.Finalized then
- Raise_Exception
- (Program_Error'Identity, "Protected Object is finalized");
- end if;
- pragma Assert (STPO.Self.Deferral_Level > 0);
- Write_Lock (Object.L'Access, Ceiling_Violation);
+ begin
+ Lock_Entries (Object, Ceiling_Violation);
if Ceiling_Violation then
Raise_Exception (Program_Error'Identity, "Ceiling Violation");
@@ -259,12 +282,35 @@ package body System.Tasking.Protected_Ob
procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
Ceiling_Violation : Boolean;
+
begin
if Object.Finalized then
Raise_Exception
(Program_Error'Identity, "Protected Object is finalized");
end if;
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action, and the protected object nesting level must
+ -- be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
@@ -278,6 +324,24 @@ package body System.Tasking.Protected_Ob
procedure Unlock_Entries (Object : Protection_Entries_Access) is
begin
+ -- We are exiting from a protected action, so that we decrease the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+ begin
+ -- Cannot call this procedure without being within a protected
+ -- action.
+
+ pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting - 1;
+ end;
+ end if;
+
Unlock (Object.L'Access);
end Unlock_Entries;
Index: s-tposen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tposen.adb,v
retrieving revision 1.8
diff -u -p -r1.8 s-tposen.adb
--- s-tposen.adb 17 May 2004 13:20:48 -0000 1.8
+++ s-tposen.adb 9 Sep 2004 09:24:28 -0000
@@ -67,7 +67,8 @@ with System.Task_Primitives.Operations;
-- Unlock
with Ada.Exceptions;
--- used for Exception_Id;
+-- used for Exception_Id
+-- Raise_Exception
with System.Parameters;
-- used for Single_Lock
@@ -347,7 +348,30 @@ package body System.Tasking.Protected_Ob
procedure Lock_Entry (Object : Protection_Entry_Access) is
Ceiling_Violation : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must
+ -- be raised if this potentially blocking operation is called from
+ -- a protected action, and the protected object nesting level
+ -- must be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
@@ -364,7 +388,30 @@ package body System.Tasking.Protected_Ob
procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
Ceiling_Violation : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action, and the protected object nesting level must
+ -- be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
@@ -465,6 +512,17 @@ package body System.Tasking.Protected_Ob
Ceiling_Violation : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
@@ -579,6 +637,17 @@ package body System.Tasking.Protected_Ob
Ceiling_Violation : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
@@ -631,6 +700,23 @@ package body System.Tasking.Protected_Ob
procedure Unlock_Entry (Object : Protection_Entry_Access) is
begin
+ -- We are exiting from a protected action, so that we decrease the
+ -- protected object nesting level (if pragma Detect_Blocking is active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+
+ begin
+ -- Cannot call Unlock_Entry without being within protected action
+
+ pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting - 1;
+ end;
+ end if;
+
STPO.Unlock (Object.L'Access);
end Unlock_Entry;
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.77
diff -u -p -r1.77 trans.c
--- trans.c 1 Sep 2004 11:51:54 -0000 1.77
+++ trans.c 9 Sep 2004 09:24:29 -0000
@@ -779,8 +779,8 @@ Attribute_to_gnu (Node_Id gnat_node, tre
if (attribute == Attr_Max_Size_In_Storage_Elements)
gnu_result = convert (sizetype,
- fold (build (CEIL_DIV_EXPR, bitsizetype,
- gnu_result, bitsize_unit_node)));
+ fold (build2 (CEIL_DIV_EXPR, bitsizetype,
+ gnu_result, bitsize_unit_node)));
break;
case Attr_Alignment:
@@ -1101,8 +1101,8 @@ Attribute_to_gnu (Node_Id gnat_node, tre
example in AARM 11.6(5.e). */
if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
&& !Is_Entity_Name (Prefix (gnat_node)))
- gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
- gnu_prefix, gnu_result));
+ gnu_result = fold (build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
+ gnu_prefix, gnu_result));
*gnu_result_type_p = gnu_result_type;
return gnu_result;
@@ -1197,9 +1197,9 @@ Case_Statement_to_gnu (Node_Id gnat_node
abort ();
}
- add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node,
- gnu_low, gnu_high,
- create_artificial_label ()),
+ add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
+ gnu_low, gnu_high,
+ create_artificial_label ()),
gnat_choice);
}
@@ -1214,8 +1214,8 @@ Case_Statement_to_gnu (Node_Id gnat_node
/* Now emit a definition of the label all the cases branched to. */
add_stmt (build1 (LABEL_EXPR, void_type_node,
TREE_VALUE (gnu_switch_label_stack)));
- gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
- end_stmt_group (), NULL_TREE);
+ gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
+ end_stmt_group (), NULL_TREE);
pop_stack (&gnu_switch_label_stack);
return gnu_result;
@@ -1279,10 +1279,10 @@ Loop_Statement_to_gnu (Node_Id gnat_node
|| tree_int_cst_equal (gnu_last, gnu_limit))
{
gnu_cond_expr
- = build (COND_EXPR, void_type_node,
- build_binary_op (LE_EXPR, integer_type_node,
- gnu_low, gnu_high),
- NULL_TREE, alloc_stmt_list ());
+ = build3 (COND_EXPR, void_type_node,
+ build_binary_op (LE_EXPR, integer_type_node,
+ gnu_low, gnu_high),
+ NULL_TREE, alloc_stmt_list ());
annotate_with_node (gnu_cond_expr, gnat_loop_spec);
}
@@ -1485,8 +1485,8 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
add_stmt_with_node
(build1 (RETURN_EXPR, void_type_node,
- build (MODIFY_EXPR, TREE_TYPE (gnu_retval),
- DECL_RESULT (current_function_decl), gnu_retval)),
+ build2 (MODIFY_EXPR, TREE_TYPE (gnu_retval),
+ DECL_RESULT (current_function_decl), gnu_retval)),
gnat_node);
gnat_poplevel ();
gnu_result = end_stmt_group ();
@@ -1520,10 +1520,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
- GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */
+ GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
+ If GNU_TARGET is non-null, this must be a function call and the result
+ of the call is to be placed into that object. */
static tree
-call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
+call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
{
tree gnu_result;
/* The GCC node corresponding to the GNAT subprogram name. This can either
@@ -1566,7 +1568,7 @@ call_to_gnu (Node_Id gnat_node, tree *gn
gnat_actual = Next_Actual (gnat_actual))
add_stmt (gnat_to_gnu (gnat_actual));
- if (Nkind (gnat_node) == N_Function_Call)
+ if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
{
*gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
return build1 (NULL_EXPR, *gnu_result_type_p,
@@ -1576,6 +1578,37 @@ call_to_gnu (Node_Id gnat_node, tree *gn
return build_call_raise (PE_Stubbed_Subprogram_Called);
}
+ /* If we are calling by supplying a pointer to a target, set up that
+ pointer as the first argument. Use GNU_TARGET if one was passed;
+ otherwise, make a target by building a variable of the maximum size
+ of the type. */
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ {
+ tree gnu_real_ret_type
+ = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
+
+ if (!gnu_target)
+ {
+ tree gnu_obj_type
+ = maybe_pad_type (gnu_real_ret_type,
+ max_size (TYPE_SIZE (gnu_real_ret_type), true),
+ 0, Etype (Name (gnat_node)), "PAD", false,
+ false, false);
+
+ gnu_target = create_tmp_var_raw (gnu_obj_type, "LR");
+ gnat_pushdecl (gnu_target, gnat_node);
+ }
+
+ gnu_actual_list
+ = tree_cons (NULL_TREE,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ unchecked_convert (gnu_real_ret_type,
+ gnu_target,
+ false)),
+ NULL_TREE);
+
+ }
+
/* The only way we can be making a call via an access type is if Name is an
explicit dereference. In that case, get the list of formal args from the
type the access type is pointing to. Otherwise, get the formals from
@@ -1660,8 +1693,8 @@ call_to_gnu (Node_Id gnat_node, tree *gn
}
/* Set up to move the copy back to the original. */
- gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy),
- gnu_copy, gnu_actual);
+ gnu_temp = build2 (MODIFY_EXPR, TREE_TYPE (gnu_copy),
+ gnu_copy, gnu_actual);
annotate_with_node (gnu_temp, gnat_actual);
append_to_statement_list (gnu_temp, &gnu_after_list);
}
@@ -1826,12 +1859,24 @@ call_to_gnu (Node_Id gnat_node, tree *gn
gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
}
- gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
- gnu_subprog_addr, nreverse (gnu_actual_list),
- NULL_TREE);
-
- /* If it is a function call, the result is the call expression. */
- if (Nkind (gnat_node) == N_Function_Call)
+ gnu_subprog_call = build3 (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
+ gnu_subprog_addr, nreverse (gnu_actual_list),
+ NULL_TREE);
+
+ /* If we return by passing a target, we emit the call and return the target
+ as our result. */
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ {
+ add_stmt_with_node (gnu_subprog_call, gnat_node);
+ *gnu_result_type_p
+ = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
+ return unchecked_convert (*gnu_result_type_p, gnu_target, false);
+ }
+
+ /* If it is a function call, the result is the call expression unless
+ a target is specified, in which case we copy the result into the target
+ and return the assignment statement. */
+ else if (Nkind (gnat_node) == N_Function_Call)
{
gnu_result = gnu_subprog_call;
@@ -1841,7 +1886,12 @@ call_to_gnu (Node_Id gnat_node, tree *gn
|| TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+ if (gnu_target)
+ gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_target, gnu_result);
+ else
+ *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+
return gnu_result;
}
@@ -2111,12 +2161,12 @@ Handled_Sequence_Of_Statements_to_gnu (N
gnu_handler = end_stmt_group ();
/* This block is now "if (setjmp) ... <handlers> else <block>". */
- gnu_result = build (COND_EXPR, void_type_node,
- (build_call_1_expr
- (setjmp_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_jmpbuf_decl))),
- gnu_handler, gnu_inner_block);
+ gnu_result = build3 (COND_EXPR, void_type_node,
+ (build_call_1_expr
+ (setjmp_decl,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_jmpbuf_decl))),
+ gnu_handler, gnu_inner_block);
}
else if (gcc_zcx)
{
@@ -2131,8 +2181,8 @@ Handled_Sequence_Of_Statements_to_gnu (N
gnu_handlers = end_stmt_group ();
/* Now make the TRY_CATCH_EXPR for the block. */
- gnu_result = build (TRY_CATCH_EXPR, void_type_node,
- gnu_inner_block, gnu_handlers);
+ gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
+ gnu_inner_block, gnu_handlers);
}
else
gnu_result = gnu_inner_block;
@@ -2225,7 +2275,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id g
gnu_choice, this_choice);
}
- return build (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
+ return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
}
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
@@ -2312,7 +2362,7 @@ Exception_Handler_to_gnu_zcx (Node_Id gn
We use a local variable to retrieve the incoming value at handler entry
time, and reuse it to feed the end_handler hook's argument at exit. */
- gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node);
+ gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
ptr_type_node, gnu_current_exc_ptr,
false, false, false, false, NULL,
@@ -2325,8 +2375,8 @@ Exception_Handler_to_gnu_zcx (Node_Id gn
add_stmt_list (Statements (gnat_node));
gnat_poplevel ();
- return build (CATCH_EXPR, void_type_node, gnu_etypes_list,
- end_stmt_group ());
+ return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
+ end_stmt_group ());
}
\f
/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
@@ -2857,13 +2907,13 @@ gnat_to_gnu (Node_Id gnat_node)
expression if the slice range is not null (max >= min) or
returns the min if the slice range is null */
gnu_expr
- = fold (build (COND_EXPR, gnu_expr_type,
- build_binary_op (GE_EXPR, gnu_expr_type,
- convert (gnu_expr_type,
- gnu_max_expr),
- convert (gnu_expr_type,
- gnu_min_expr)),
- gnu_expr, gnu_min_expr));
+ = fold (build3 (COND_EXPR, gnu_expr_type,
+ build_binary_op (GE_EXPR, gnu_expr_type,
+ convert (gnu_expr_type,
+ gnu_max_expr),
+ convert (gnu_expr_type,
+ gnu_min_expr)),
+ gnu_expr, gnu_min_expr));
}
else
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
@@ -3354,26 +3404,32 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Assignment_Statement:
/* Get the LHS and RHS of the statement and convert any reference to an
- unconstrained array into a reference to the underlying array. */
+ unconstrained array into a reference to the underlying array.
+ If we are not to do range checking and the RHS is an N_Function_Call,
+ pass the LHS to the call function. */
gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
- gnu_rhs
- = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
- /* If range check is needed, emit code to generate it */
- if (Do_Range_Check (Expression (gnat_node)))
- gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
-
- /* If either side's type has a size that overflows, convert this
- into raise of Storage_Error: execution shouldn't have gotten
- here anyway. */
- if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
+ /* If the type has a size that overflows, convert this into raise of
+ Storage_Error: execution shouldn't have gotten here anyway. */
+ if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
- || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
gnu_result = build_call_raise (SE_Object_Too_Large);
+ else if (Nkind (Expression (gnat_node)) == N_Function_Call
+ && !Do_Range_Check (Expression (gnat_node)))
+ gnu_result = call_to_gnu (Expression (gnat_node),
+ &gnu_result_type, gnu_lhs);
else
- gnu_result
- = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+ {
+ gnu_rhs
+ = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
+
+ /* If range check is needed, emit code to generate it */
+ if (Do_Range_Check (Expression (gnat_node)))
+ gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
+
+ gnu_result
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+ }
break;
case N_If_Statement:
@@ -3381,9 +3437,9 @@ gnat_to_gnu (Node_Id gnat_node)
tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
/* Make the outer COND_EXPR. Avoid non-determinism. */
- gnu_result = build (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_node)),
- NULL_TREE, NULL_TREE);
+ gnu_result = build3 (COND_EXPR, void_type_node,
+ gnat_to_gnu (Condition (gnat_node)),
+ NULL_TREE, NULL_TREE);
COND_EXPR_THEN (gnu_result)
= build_stmt_group (Then_Statements (gnat_node), false);
TREE_SIDE_EFFECTS (gnu_result) = 1;
@@ -3396,9 +3452,9 @@ gnat_to_gnu (Node_Id gnat_node)
for (gnat_temp = First (Elsif_Parts (gnat_node));
Present (gnat_temp); gnat_temp = Next (gnat_temp))
{
- gnu_expr = build (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_temp)),
- NULL_TREE, NULL_TREE);
+ gnu_expr = build3 (COND_EXPR, void_type_node,
+ gnat_to_gnu (Condition (gnat_temp)),
+ NULL_TREE, NULL_TREE);
COND_EXPR_THEN (gnu_expr)
= build_stmt_group (Then_Statements (gnat_temp), false);
TREE_SIDE_EFFECTS (gnu_expr) = 1;
@@ -3433,12 +3489,12 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Exit_Statement:
gnu_result
- = build (EXIT_STMT, void_type_node,
- (Present (Condition (gnat_node))
- ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
- (Present (Name (gnat_node))
- ? get_gnu_tree (Entity (Name (gnat_node)))
- : TREE_VALUE (gnu_loop_label_stack)));
+ = build2 (EXIT_STMT, void_type_node,
+ (Present (Condition (gnat_node))
+ ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
+ (Present (Name (gnat_node))
+ ? get_gnu_tree (Entity (Name (gnat_node)))
+ : TREE_VALUE (gnu_loop_label_stack)));
break;
case N_Return_Statement:
@@ -3446,7 +3502,13 @@ gnat_to_gnu (Node_Id gnat_node)
/* The gnu function type of the subprogram currently processed. */
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
/* The return value from the subprogram. */
- tree gnu_ret_val = 0;
+ tree gnu_ret_val = NULL_TREE;
+ /* The place to put the return value. */
+ tree gnu_lhs
+ = (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
+ ? build_unary_op (INDIRECT_REF, NULL_TREE,
+ DECL_ARGUMENTS (current_function_decl))
+ : DECL_RESULT (current_function_decl));
/* If we are dealing with a "return;" from an Ada procedure with
parameters passed by copy in copy out, we need to return a record
@@ -3484,53 +3546,71 @@ gnat_to_gnu (Node_Id gnat_node)
else if (Present (Expression (gnat_node)))
{
- gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
+ /* If the current function returns by target pointer and we
+ are doing a call, pass that target to the call. */
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
+ && Nkind (Expression (gnat_node)) == N_Function_Call)
+ gnu_result = call_to_gnu (Expression (gnat_node),
+ &gnu_result_type, gnu_lhs);
- /* Do not remove the padding from GNU_RET_VAL if the inner
- type is self-referential since we want to allocate the fixed
- size in that case. */
- if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
- gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
-
- if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
- || By_Ref (gnat_node))
- gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
-
- else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
+ else
{
- gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+ gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
- /* We have two cases: either the function returns with
- depressed stack or not. If not, we allocate on the
- secondary stack. If so, we allocate in the stack frame.
- if no copy is needed, the front end will set By_Ref,
- which we handle in the case above. */
- if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
- gnu_ret_val
- = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
- TREE_TYPE (gnu_subprog_type), 0, -1,
- gnat_node);
- else
+ /* Do not remove the padding from GNU_RET_VAL if the inner
+ type is self-referential since we want to allocate the fixed
+ size in that case. */
+ if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
+ && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
+ && (CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
+ gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
+
+ if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
+ || By_Ref (gnat_node))
gnu_ret_val
- = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
- TREE_TYPE (gnu_subprog_type),
- Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node), gnat_node);
+ = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
+
+ else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
+ {
+ gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+
+ /* We have two cases: either the function returns with
+ depressed stack or not. If not, we allocate on the
+ secondary stack. If so, we allocate in the stack frame.
+ if no copy is needed, the front end will set By_Ref,
+ which we handle in the case above. */
+ if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
+ gnu_ret_val
+ = build_allocator (TREE_TYPE (gnu_ret_val),
+ gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type),
+ 0, -1, gnat_node);
+ else
+ gnu_ret_val
+ = build_allocator (TREE_TYPE (gnu_ret_val),
+ gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type),
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node),
+ gnat_node);
+ }
+ }
+
+ gnu_result = build2 (MODIFY_EXPR, TREE_TYPE (gnu_ret_val),
+ gnu_lhs, gnu_ret_val);
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ {
+ add_stmt_with_node (gnu_result, gnat_node);
+ gnu_ret_val = NULL_TREE;
}
}
gnu_result = build1 (RETURN_EXPR, void_type_node,
- (gnu_ret_val
- ? build (MODIFY_EXPR, TREE_TYPE (gnu_ret_val),
- DECL_RESULT (current_function_decl),
- gnu_ret_val)
- : NULL_TREE));
+ gnu_ret_val ? gnu_result : gnu_ret_val);
}
break;
@@ -3584,7 +3664,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Function_Call:
case N_Procedure_Call_Statement:
- gnu_result = call_to_gnu (gnat_node, &gnu_result_type);
+ gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
break;
/*************************/
@@ -3788,9 +3868,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_input_list = nreverse (gnu_input_list);
gnu_output_list = nreverse (gnu_output_list);
- gnu_result = build (ASM_EXPR, void_type_node,
- gnu_template, gnu_output_list,
- gnu_input_list, gnu_clobber_list);
+ gnu_result = build4 (ASM_EXPR, void_type_node,
+ gnu_template, gnu_output_list,
+ gnu_input_list, gnu_clobber_list);
ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
}
else
@@ -3889,9 +3969,9 @@ gnat_to_gnu (Node_Id gnat_node)
annotate_with_node (gnu_result, gnat_node);
if (Present (Condition (gnat_node)))
- gnu_result = build (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_node)),
- gnu_result, alloc_stmt_list ());
+ gnu_result = build3 (COND_EXPR, void_type_node,
+ gnat_to_gnu (Condition (gnat_node)),
+ gnu_result, alloc_stmt_list ());
}
else
gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
@@ -4079,7 +4159,7 @@ gnat_to_gnu (Node_Id gnat_node)
static void
record_code_position (Node_Id gnat_node)
{
- tree stmt_stmt = build (STMT_STMT, void_type_node, NULL_TREE);
+ tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
add_stmt_with_node (stmt_stmt, gnat_node);
save_gnu_tree (gnat_node, stmt_stmt, true);
@@ -4157,7 +4237,7 @@ add_decl_expr (tree gnu_decl, Entity_Id
this decl since we already have evaluated the expressions in the
sizes and positions as globals and doing it again would be wrong.
But we do have to mark everything as used. */
- gnu_stmt = build (DECL_EXPR, void_type_node, gnu_decl);
+ gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
if (!global_bindings_p ())
add_stmt_with_node (gnu_stmt, gnat_entity);
else
@@ -4276,12 +4356,12 @@ end_stmt_group ()
gnu_retval = alloc_stmt_list ();
if (group->cleanups)
- gnu_retval = build (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
- group->cleanups);
+ gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
+ group->cleanups);
if (current_stmt_group->block)
- gnu_retval = build (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
- gnu_retval, group->block);
+ gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
+ gnu_retval, group->block);
/* Remove this group from the stack and add it to the free list. */
current_stmt_group = group->previous;
@@ -4418,10 +4498,33 @@ gnat_gimplify_expr (tree *expr_p, tree *
*expr_p = TREE_OPERAND (*expr_p, 0);
return GS_OK;
+ case ADDR_EXPR:
+ /* If we're taking the address of a constant CONSTRUCTOR, force it to
+ be put into static memory. We know it's going to be readonly given
+ the semantics we have and it's required to be static memory in
+ the case when the reference is in an elaboration procedure. */
+ if (TREE_CODE (TREE_OPERAND (expr, 0)) == CONSTRUCTOR
+ && TREE_CONSTANT (TREE_OPERAND (expr, 0)))
+ {
+ tree new_var
+ = create_tmp_var (TREE_TYPE (TREE_OPERAND (expr, 0)), "C");
+
+ TREE_READONLY (new_var) = 1;
+ TREE_STATIC (new_var) = 1;
+ TREE_ADDRESSABLE (new_var) = 1;
+
+ gimplify_and_add (build2 (MODIFY_EXPR, TREE_TYPE (new_var),
+ new_var, TREE_OPERAND (expr, 0)),
+ pre_p);
+
+ TREE_OPERAND (expr, 0) = new_var;
+ return GS_ALL_DONE;
+ }
+ return GS_UNHANDLED;
+
case COMPONENT_REF:
- /* We have a kludge here. If the FIELD_DECL is from a fat pointer
- and is from an early dummy type, replace it with the proper
- FIELD_DECL. */
+ /* We have a kludge here. If the FIELD_DECL is from a fat pointer and is
+ from an early dummy type, replace it with the proper FIELD_DECL. */
if (TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0)))
&& DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1)))
{
@@ -4472,23 +4575,23 @@ gnat_gimplify_stmt (tree *stmt_p)
stmt_p);
if (LOOP_STMT_TOP_COND (stmt))
- append_to_statement_list (build (COND_EXPR, void_type_node,
- LOOP_STMT_TOP_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
+ append_to_statement_list (build3 (COND_EXPR, void_type_node,
+ LOOP_STMT_TOP_COND (stmt),
+ alloc_stmt_list (),
+ build1 (GOTO_EXPR,
+ void_type_node,
+ gnu_end_label)),
stmt_p);
append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
if (LOOP_STMT_BOT_COND (stmt))
- append_to_statement_list (build (COND_EXPR, void_type_node,
- LOOP_STMT_BOT_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
+ append_to_statement_list (build3 (COND_EXPR, void_type_node,
+ LOOP_STMT_BOT_COND (stmt),
+ alloc_stmt_list (),
+ build1 (GOTO_EXPR,
+ void_type_node,
+ gnu_end_label)),
stmt_p);
if (LOOP_STMT_UPDATE (stmt))
@@ -4508,8 +4611,8 @@ gnat_gimplify_stmt (tree *stmt_p)
see if it needs to be conditional. */
*stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
if (EXIT_STMT_COND (stmt))
- *stmt_p = build (COND_EXPR, void_type_node,
- EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
+ *stmt_p = build3 (COND_EXPR, void_type_node,
+ EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
return GS_OK;
default:
@@ -4974,17 +5077,17 @@ emit_check (tree gnu_cond, tree gnu_expr
in front of the comparison in case it ends up being a SAVE_EXPR. Put the
whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
out. */
- gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
- build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
- gnu_call, gnu_expr),
- gnu_expr));
+ gnu_result = fold (build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
+ build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
+ gnu_call, gnu_expr),
+ gnu_expr));
/* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
protect it. Otherwise, show GNU_RESULT has no side effects: we
don't need to evaluate it just for the check. */
if (TREE_SIDE_EFFECTS (gnu_expr))
gnu_result
- = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
+ = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
else
TREE_SIDE_EFFECTS (gnu_result) = 0;
@@ -5107,13 +5210,13 @@ convert_with_check (Entity_Id gnat_type,
tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
tree gnu_saved_result = save_expr (gnu_result);
- tree gnu_comp = build (GE_EXPR, integer_type_node,
- gnu_saved_result, gnu_zero);
- tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
- gnu_point_5, gnu_minus_point_5);
+ tree gnu_comp = build2 (GE_EXPR, integer_type_node,
+ gnu_saved_result, gnu_zero);
+ tree gnu_adjust = build3 (COND_EXPR, gnu_in_basetype, gnu_comp,
+ gnu_point_5, gnu_minus_point_5);
gnu_result
- = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
+ = build2 (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
}
if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
@@ -5531,36 +5634,36 @@ gnat_stabilize_reference (tree ref, bool
break;
case COMPONENT_REF:
- result = build (COMPONENT_REF, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0),
- force),
- TREE_OPERAND (ref, 1), NULL_TREE);
+ result = build3 (COMPONENT_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0),
+ force),
+ TREE_OPERAND (ref, 1), NULL_TREE);
break;
case BIT_FIELD_REF:
- result = build (BIT_FIELD_REF, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
- force));
+ result = build3 (BIT_FIELD_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
+ force));
break;
case ARRAY_REF:
case ARRAY_RANGE_REF:
- result = build (code, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- NULL_TREE, NULL_TREE);
+ result = build4 (code, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force),
+ NULL_TREE, NULL_TREE);
break;
case COMPOUND_EXPR:
- result = build (COMPOUND_EXPR, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
- force),
- gnat_stabilize_reference (TREE_OPERAND (ref, 1),
- force));
+ result = build2 (COMPOUND_EXPR, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
+ force),
+ gnat_stabilize_reference (TREE_OPERAND (ref, 1),
+ force));
break;
/* If arg isn't a kind of lvalue we recognize, make no change.
@@ -5621,10 +5724,10 @@ gnat_stabilize_reference_1 (tree e, bool
us to more easily find the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
&& TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
- result = build (COMPONENT_REF, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force),
- TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
+ result = build3 (COMPONENT_REF, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
+ force),
+ TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
else if (TREE_SIDE_EFFECTS (e) || force)
return save_expr (e);
else
@@ -5638,9 +5741,10 @@ gnat_stabilize_reference_1 (tree e, bool
case '2':
/* Recursively stabilize each operand. */
- result = build (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
+ result = build2 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
+ force));
break;
case '1':
Index: utils2.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils2.c,v
retrieving revision 1.38
diff -u -p -r1.38 utils2.c
--- utils2.c 1 Sep 2004 11:51:54 -0000 1.38
+++ utils2.c 9 Sep 2004 09:24:29 -0000
@@ -96,9 +96,9 @@ gnat_truthvalue_conversion (tree expr)
case COND_EXPR:
/* Distribute the conversion into the arms of a COND_EXPR. */
return fold
- (build (COND_EXPR, type, TREE_OPERAND (expr, 0),
- gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)),
- gnat_truthvalue_conversion (TREE_OPERAND (expr, 2))));
+ (build3 (COND_EXPR, type, TREE_OPERAND (expr, 0),
+ gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)),
+ gnat_truthvalue_conversion (TREE_OPERAND (expr, 2))));
default:
return build_binary_op (NE_EXPR, type, expr,
@@ -355,8 +355,8 @@ compare_arrays (tree result_type, tree a
tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
tree bt = get_base_type (TREE_TYPE (lb1));
- tree length1 = fold (build (MINUS_EXPR, bt, ub1, lb1));
- tree length2 = fold (build (MINUS_EXPR, bt, ub2, lb2));
+ tree length1 = fold (build2 (MINUS_EXPR, bt, ub1, lb1));
+ tree length2 = fold (build2 (MINUS_EXPR, bt, ub2, lb2));
tree nbt;
tree tem;
tree comparison, this_a1_is_null, this_a2_is_null;
@@ -365,8 +365,8 @@ compare_arrays (tree result_type, tree a
unless the length of the second array is the constant zero.
Note that we have set the `length' values to the length - 1. */
if (TREE_CODE (length1) == INTEGER_CST
- && !integer_zerop (fold (build (PLUS_EXPR, bt, length2,
- convert (bt, integer_one_node)))))
+ && !integer_zerop (fold (build2 (PLUS_EXPR, bt, length2,
+ convert (bt, integer_one_node)))))
{
tem = a1, a1 = a2, a2 = tem;
tem = t1, t1 = t2, t2 = tem;
@@ -379,8 +379,8 @@ compare_arrays (tree result_type, tree a
/* If the length of this dimension in the second array is the constant
zero, we can just go inside the original bounds for the first
array and see if last < first. */
- if (integer_zerop (fold (build (PLUS_EXPR, bt, length2,
- convert (bt, integer_one_node)))))
+ if (integer_zerop (fold (build2 (PLUS_EXPR, bt, length2,
+ convert (bt, integer_one_node)))))
{
tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
@@ -459,7 +459,7 @@ compare_arrays (tree result_type, tree a
a1 = convert (type, a1), a2 = convert (type, a2);
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
- fold (build (EQ_EXPR, result_type, a1, a2)));
+ fold (build2 (EQ_EXPR, result_type, a1, a2)));
}
@@ -474,10 +474,10 @@ compare_arrays (tree result_type, tree a
evaluated would be wrong. */
if (contains_save_expr_p (a1))
- result = build (COMPOUND_EXPR, result_type, a1, result);
+ result = build2 (COMPOUND_EXPR, result_type, a1, result);
if (contains_save_expr_p (a2))
- result = build (COMPOUND_EXPR, result_type, a2, result);
+ result = build2 (COMPOUND_EXPR, result_type, a2, result);
return result;
}
@@ -500,7 +500,7 @@ nonbinary_modular_operation (enum tree_c
/* If this is an addition of a constant, convert it to a subtraction
of a constant since we can do that faster. */
if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
- rhs = fold (build (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
+ rhs = fold (build2 (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
/* For the logical operations, we only need PRECISION bits. For
addition and subraction, we need one more and for multiplication we
@@ -532,7 +532,7 @@ nonbinary_modular_operation (enum tree_c
}
/* Do the operation, then we'll fix it up. */
- result = fold (build (op_code, op_type, lhs, rhs));
+ result = fold (build2 (op_code, op_type, lhs, rhs));
/* For multiplication, we have no choice but to do a full modulus
operation. However, we want to do this in the narrowest
@@ -544,32 +544,32 @@ nonbinary_modular_operation (enum tree_c
SET_TYPE_MODULUS (div_type, modulus);
TYPE_MODULAR_P (div_type) = 1;
result = convert (op_type,
- fold (build (TRUNC_MOD_EXPR, div_type,
- convert (div_type, result), modulus)));
+ fold (build2 (TRUNC_MOD_EXPR, div_type,
+ convert (div_type, result), modulus)));
}
/* For subtraction, add the modulus back if we are negative. */
else if (op_code == MINUS_EXPR)
{
result = save_expr (result);
- result = fold (build (COND_EXPR, op_type,
- build (LT_EXPR, integer_type_node, result,
- convert (op_type, integer_zero_node)),
- fold (build (PLUS_EXPR, op_type,
- result, modulus)),
- result));
+ result = fold (build3 (COND_EXPR, op_type,
+ build2 (LT_EXPR, integer_type_node, result,
+ convert (op_type, integer_zero_node)),
+ fold (build2 (PLUS_EXPR, op_type,
+ result, modulus)),
+ result));
}
/* For the other operations, subtract the modulus if we are >= it. */
else
{
result = save_expr (result);
- result = fold (build (COND_EXPR, op_type,
- build (GE_EXPR, integer_type_node,
- result, modulus),
- fold (build (MINUS_EXPR, op_type,
- result, modulus)),
- result));
+ result = fold (build3 (COND_EXPR, op_type,
+ build2 (GE_EXPR, integer_type_node,
+ result, modulus),
+ fold (build2 (MINUS_EXPR, op_type,
+ result, modulus)),
+ result));
}
return convert (type, result);
@@ -791,16 +791,16 @@ build_binary_op (enum tree_code op_code,
case NE_EXPR:
/* If either operand is a NULL_EXPR, just return a new one. */
if (TREE_CODE (left_operand) == NULL_EXPR)
- return build (op_code, result_type,
- build1 (NULL_EXPR, integer_type_node,
- TREE_OPERAND (left_operand, 0)),
- integer_zero_node);
+ return build2 (op_code, result_type,
+ build1 (NULL_EXPR, integer_type_node,
+ TREE_OPERAND (left_operand, 0)),
+ integer_zero_node);
else if (TREE_CODE (right_operand) == NULL_EXPR)
- return build (op_code, result_type,
- build1 (NULL_EXPR, integer_type_node,
- TREE_OPERAND (right_operand, 0)),
- integer_zero_node);
+ return build2 (op_code, result_type,
+ build1 (NULL_EXPR, integer_type_node,
+ TREE_OPERAND (right_operand, 0)),
+ integer_zero_node);
/* If either object is a left-justified modular types, get the
fields from within. */
@@ -998,11 +998,11 @@ build_binary_op (enum tree_code op_code,
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
- result = fold (build (op_code, operation_type, left_operand, right_operand,
- NULL_TREE, NULL_TREE));
+ result = fold (build4 (op_code, operation_type, left_operand,
+ right_operand, NULL_TREE, NULL_TREE));
else
result
- = fold (build (op_code, operation_type, left_operand, right_operand));
+ = fold (build2 (op_code, operation_type, left_operand, right_operand));
TREE_SIDE_EFFECTS (result) |= has_side_effects;
TREE_CONSTANT (result)
@@ -1016,8 +1016,8 @@ build_binary_op (enum tree_code op_code,
/* If we are working with modular types, perform the MOD operation
if something above hasn't eliminated the need for it. */
if (modulus)
- result = fold (build (FLOOR_MOD_EXPR, operation_type, result,
- convert (operation_type, modulus)));
+ result = fold (build2 (FLOOR_MOD_EXPR, operation_type, result,
+ convert (operation_type, modulus)));
if (result_type && result_type != operation_type)
result = convert (result_type, result);
@@ -1260,10 +1260,10 @@ build_unary_op (enum tree_code op_code,
the straightforward code; the TRUNC_MOD_EXPR below
is an AND operation. */
if (op_code == NEGATE_EXPR && mod_pow2)
- result = fold (build (TRUNC_MOD_EXPR, operation_type,
- fold (build1 (NEGATE_EXPR, operation_type,
- operand)),
- modulus));
+ result = fold (build2 (TRUNC_MOD_EXPR, operation_type,
+ fold (build1 (NEGATE_EXPR, operation_type,
+ operand)),
+ modulus));
/* For nonbinary negate case, return zero for zero operand,
else return the modulus minus the operand. If the modulus
@@ -1271,22 +1271,24 @@ build_unary_op (enum tree_code op_code,
as an XOR since it is equivalent and faster on most machines. */
else if (op_code == NEGATE_EXPR && !mod_pow2)
{
- if (integer_pow2p (fold (build (PLUS_EXPR, operation_type,
- modulus,
- convert (operation_type,
- integer_one_node)))))
- result = fold (build (BIT_XOR_EXPR, operation_type,
- operand, modulus));
+ if (integer_pow2p (fold (build2 (PLUS_EXPR, operation_type,
+ modulus,
+ convert (operation_type,
+ integer_one_node)))))
+ result = fold (build2 (BIT_XOR_EXPR, operation_type,
+ operand, modulus));
else
- result = fold (build (MINUS_EXPR, operation_type,
+ result = fold (build2 (MINUS_EXPR, operation_type,
modulus, operand));
- result = fold (build (COND_EXPR, operation_type,
- fold (build (NE_EXPR, integer_type_node,
- operand,
- convert (operation_type,
- integer_zero_node))),
- result, operand));
+ result = fold (build3 (COND_EXPR, operation_type,
+ fold (build2 (NE_EXPR,
+ integer_type_node,
+ operand,
+ convert
+ (operation_type,
+ integer_zero_node))),
+ result, operand));
}
else
{
@@ -1295,16 +1297,16 @@ build_unary_op (enum tree_code op_code,
XOR against the constant and subtract the operand from
that constant for nonbinary modulus. */
- tree cnst = fold (build (MINUS_EXPR, operation_type, modulus,
- convert (operation_type,
- integer_one_node)));
+ tree cnst = fold (build2 (MINUS_EXPR, operation_type, modulus,
+ convert (operation_type,
+ integer_one_node)));
if (mod_pow2)
- result = fold (build (BIT_XOR_EXPR, operation_type,
- operand, cnst));
+ result = fold (build2 (BIT_XOR_EXPR, operation_type,
+ operand, cnst));
else
- result = fold (build (MINUS_EXPR, operation_type,
- cnst, operand));
+ result = fold (build2 (MINUS_EXPR, operation_type,
+ cnst, operand));
}
break;
@@ -1360,8 +1362,8 @@ build_cond_expr (tree result_type, tree
false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
}
- result = fold (build (COND_EXPR, result_type, condition_operand,
- true_operand, false_operand));
+ result = fold (build3 (COND_EXPR, result_type, condition_operand,
+ true_operand, false_operand));
/* If either operand is a SAVE_EXPR (possibly surrounded by
arithmetic, make sure it gets done. */
@@ -1369,10 +1371,10 @@ build_cond_expr (tree result_type, tree
false_operand = skip_simple_arithmetic (false_operand);
if (TREE_CODE (true_operand) == SAVE_EXPR)
- result = build (COMPOUND_EXPR, result_type, true_operand, result);
+ result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
if (TREE_CODE (false_operand) == SAVE_EXPR)
- result = build (COMPOUND_EXPR, result_type, false_operand, result);
+ result = build2 (COMPOUND_EXPR, result_type, false_operand, result);
/* ??? Seems the code above is wrong, as it may move ahead of the COND
SAVE_EXPRs with side effects and not shared by both arms. */
@@ -1390,10 +1392,10 @@ build_cond_expr (tree result_type, tree
tree
build_call_1_expr (tree fundecl, tree arg)
{
- tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
- build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
- chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
- NULL_TREE);
+ tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
+ NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
@@ -1406,11 +1408,11 @@ build_call_1_expr (tree fundecl, tree ar
tree
build_call_2_expr (tree fundecl, tree arg1, tree arg2)
{
- tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
- build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
- chainon (chainon (NULL_TREE,
- build_tree_list (NULL_TREE, arg1)),
- build_tree_list (NULL_TREE, arg2)),
+ tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ chainon (chainon (NULL_TREE,
+ build_tree_list (NULL_TREE, arg1)),
+ build_tree_list (NULL_TREE, arg2)),
NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
@@ -1423,9 +1425,9 @@ build_call_2_expr (tree fundecl, tree ar
tree
build_call_0_expr (tree fundecl)
{
- tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
- build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
- NULL_TREE, NULL_TREE);
+ tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ NULL_TREE, NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
@@ -1510,11 +1512,10 @@ gnat_build_constructor (tree type, tree
}
result = build_constructor (type, list);
- TREE_CONSTANT (result) = allconstant;
- TREE_STATIC (result) = allconstant;
+ TREE_CONSTANT (result) = TREE_INVARIANT (result)
+ = TREE_STATIC (result) = allconstant;
TREE_SIDE_EFFECTS (result) = side_effects;
- TREE_READONLY (result) = TYPE_READONLY (type);
-
+ TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
return result;
}
\f
@@ -1596,8 +1597,8 @@ build_simple_component_ref (tree record_
/* It would be nice to call "fold" here, but that can lose a type
we need to tag a PLACEHOLDER_EXPR with, so we can't do it. */
- ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field,
- NULL_TREE);
+ ref = build3 (COMPONENT_REF, TREE_TYPE (field), record_variable, field,
+ NULL_TREE);
if (TREE_READONLY (record_variable) || TREE_READONLY (field))
TREE_READONLY (ref) = 1;
@@ -1688,8 +1689,8 @@ build_call_alloc_dealloc (tree gnu_obj,
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_align)));
- gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
- gnu_proc_addr, gnu_args, NULL_TREE);
+ gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
+ gnu_proc_addr, gnu_args, NULL_TREE);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
@@ -1717,8 +1718,8 @@ build_call_alloc_dealloc (tree gnu_obj,
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_size)));
- gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
- gnu_proc_addr, gnu_args, NULL_TREE);
+ gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
+ gnu_proc_addr, gnu_args, NULL_TREE);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
@@ -1750,7 +1751,7 @@ build_call_alloc_dealloc (tree gnu_obj,
else
abort ();
#if 0
- return build (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
+ return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
#endif
}
else
@@ -1830,16 +1831,16 @@ build_allocator (tree type, tree init, t
return convert
(result_type,
- build (COMPOUND_EXPR, storage_ptr_type,
- build_binary_op
- (MODIFY_EXPR, storage_type,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (storage_ptr_type, storage)),
- gnat_build_constructor (storage_type, template_cons)),
- convert (storage_ptr_type, storage)));
+ build2 (COMPOUND_EXPR, storage_ptr_type,
+ build_binary_op
+ (MODIFY_EXPR, storage_type,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (storage_ptr_type, storage)),
+ gnat_build_constructor (storage_type, template_cons)),
+ convert (storage_ptr_type, storage)));
}
else
- return build
+ return build2
(COMPOUND_EXPR, result_type,
build_binary_op
(MODIFY_EXPR, template_type,
@@ -1910,13 +1911,13 @@ build_allocator (tree type, tree init, t
{
result = save_expr (result);
result
- = build (COMPOUND_EXPR, TREE_TYPE (result),
- build_binary_op
- (MODIFY_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, TREE_TYPE (TREE_TYPE (result)),
- result),
- init),
- result);
+ = build2 (COMPOUND_EXPR, TREE_TYPE (result),
+ build_binary_op
+ (MODIFY_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF,
+ TREE_TYPE (TREE_TYPE (result)), result),
+ init),
+ result);
}
return convert (result_type, result);
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.80
diff -u -p -r1.80 utils.c
--- utils.c 1 Sep 2004 11:51:54 -0000 1.80
+++ utils.c 9 Sep 2004 09:24:29 -0000
@@ -832,12 +832,13 @@ finish_record_type (tree record_type, tr
case QUAL_UNION_TYPE:
ada_size
- = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
- this_ada_size, ada_size));
- size = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
- this_size, size));
- size_unit = fold (build (COND_EXPR, sizetype, DECL_QUALIFIER (field),
- this_size_unit, size_unit));
+ = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
+ this_ada_size, ada_size));
+ size = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
+ this_size, size));
+ size_unit = fold (build3 (COND_EXPR, sizetype,
+ DECL_QUALIFIER (field),
+ this_size_unit, size_unit));
break;
case RECORD_TYPE:
@@ -1073,15 +1074,15 @@ merge_sizes (tree last_size, tree first_
}
else
- new = fold (build (COND_EXPR, type, TREE_OPERAND (size, 0),
- integer_zerop (TREE_OPERAND (size, 1))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 1),
- 1, has_rep),
- integer_zerop (TREE_OPERAND (size, 2))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 2),
- 1, has_rep)));
+ new = fold (build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
+ integer_zerop (TREE_OPERAND (size, 1))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 1),
+ 1, has_rep),
+ integer_zerop (TREE_OPERAND (size, 2))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 2),
+ 1, has_rep)));
/* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
when fed through substitute_in_expr) into thinking that a constant
@@ -1157,12 +1158,14 @@ split_plus (tree in, tree *pvar)
RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
object. RETURNS_BY_REF is nonzero if the function returns by reference.
RETURNS_WITH_DSP is nonzero if the function is to return with a
- depressed stack pointer. */
+ depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function
+ is to be passed (as its first parameter) the address of the place to copy
+ its result. */
tree
create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
bool returns_unconstrained, bool returns_by_ref,
- bool returns_with_dsp)
+ bool returns_with_dsp, bool returns_by_target_ptr)
{
/* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
the subprogram formal parameters. This list is generated by traversing the
@@ -1193,13 +1196,15 @@ create_subprog_type (tree return_type, t
RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
if (TYPE_CI_CO_LIST (type) || cico_list
|| TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
- || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref)
+ || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref
+ || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr)
type = copy_type (type);
TYPE_CI_CO_LIST (type) = cico_list;
TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp;
TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
+ TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr;
return type;
}
\f
@@ -1342,10 +1347,12 @@ create_var_decl (tree var_name, tree asm
TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
= TYPE_VOLATILE (type);
- /* At the global binding level we need to allocate static storage for the
- variable if and only if its not external. If we are not at the top level
+ /* If it's public and not external, always allocate storage for it.
+ At the global binding level we need to allocate static storage for the
+ variable if and only if it's not external. If we are not at the top level
we allocate automatic storage unless requested not to. */
- TREE_STATIC (var_decl) = global_bindings_p () ? !extern_flag : static_flag;
+ TREE_STATIC (var_decl)
+ = public_flag || (global_bindings_p () ? !extern_flag : static_flag);
if (asm_name)
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
@@ -2066,19 +2073,19 @@ max_size (tree exp, bool max_p)
&& !TREE_CONSTANT (rhs))
return lhs;
else
- return fold (build (code, type, lhs, rhs));
+ return fold (build2 (code, type, lhs, rhs));
}
case 3:
if (code == SAVE_EXPR)
return exp;
else if (code == COND_EXPR)
- return fold (build (max_p ? MAX_EXPR : MIN_EXPR, type,
- max_size (TREE_OPERAND (exp, 1), max_p),
- max_size (TREE_OPERAND (exp, 2), max_p)));
+ return fold (build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
+ max_size (TREE_OPERAND (exp, 1), max_p),
+ max_size (TREE_OPERAND (exp, 2), max_p)));
else if (code == CALL_EXPR && TREE_OPERAND (exp, 1))
- return build (CALL_EXPR, type, TREE_OPERAND (exp, 0),
- max_size (TREE_OPERAND (exp, 1), max_p), NULL);
+ return build3 (CALL_EXPR, type, TREE_OPERAND (exp, 0),
+ max_size (TREE_OPERAND (exp, 1), max_p), NULL);
}
}
@@ -2307,7 +2314,7 @@ build_vms_descriptor (tree type, Mechani
build_pointer_type_for_mode (type, SImode, false), record_type,
build1 (ADDR_EXPR,
build_pointer_type_for_mode (type, SImode, false),
- build (PLACEHOLDER_EXPR, type))));
+ build0 (PLACEHOLDER_EXPR, type))));
switch (mech)
{
@@ -2368,12 +2375,12 @@ build_vms_descriptor (tree type, Mechani
size_in_bytes (type)));
/* Now build a pointer to the 0,0,0... element. */
- tem = build (PLACEHOLDER_EXPR, type);
+ tem = build0 (PLACEHOLDER_EXPR, type);
for (i = 0, inner_type = type; i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
- tem = build (ARRAY_REF, TREE_TYPE (inner_type), tem,
- convert (TYPE_DOMAIN (inner_type), size_zero_node),
- NULL_TREE, NULL_TREE);
+ tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
+ convert (TYPE_DOMAIN (inner_type), size_zero_node),
+ NULL_TREE, NULL_TREE);
field_list
= chainon (field_list,
@@ -2596,9 +2603,9 @@ update_pointer_to (tree old_type, tree n
is now a very "heavy" routine to do this, so it should be replaced
at some point. */
ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
- new_ref = build (COMPONENT_REF, ptr_temp_type,
- build (PLACEHOLDER_EXPR, ptr),
- TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
+ new_ref = build3 (COMPONENT_REF, ptr_temp_type,
+ build0 (PLACEHOLDER_EXPR, ptr),
+ TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
update_pointer_to
(TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
@@ -2801,10 +2808,11 @@ convert (tree type, tree expr)
/* If the input is a biased type, adjust first. */
if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
- return convert (type, fold (build (PLUS_EXPR, TREE_TYPE (etype),
- fold (build1 (NOP_EXPR,
- TREE_TYPE (etype), expr)),
- TYPE_MIN_VALUE (etype))));
+ return convert (type, fold (build2 (PLUS_EXPR, TREE_TYPE (etype),
+ fold (build1 (NOP_EXPR,
+ TREE_TYPE (etype),
+ expr)),
+ TYPE_MIN_VALUE (etype))));
/* If the input is a left-justified modular type, we need to extract
the actual object before converting it to any other type with the
@@ -2936,9 +2944,9 @@ convert (tree type, tree expr)
return unchecked_convert (type, expr, false);
else if (TYPE_BIASED_REPRESENTATION_P (type))
return fold (build1 (CONVERT_EXPR, type,
- fold (build (MINUS_EXPR, TREE_TYPE (type),
- convert (TREE_TYPE (type), expr),
- TYPE_MIN_VALUE (type)))));
+ fold (build2 (MINUS_EXPR, TREE_TYPE (type),
+ convert (TREE_TYPE (type), expr),
+ TYPE_MIN_VALUE (type)))));
/* ... fall through ... */
Index: a-direct.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-direct.ads,v
retrieving revision 1.2
diff -u -p -r1.2 a-direct.ads
--- a-direct.ads 7 Jun 2004 14:16:33 -0000 1.2
+++ a-direct.ads 9 Sep 2004 09:24:29 -0000
@@ -77,6 +77,9 @@ with Ada.Strings.Unbounded;
package Ada.Directories is
+ pragma Ada_05;
+ -- To be removed later ???
+
-----------------------------------
-- Directory and File Operations --
-----------------------------------
@@ -386,7 +389,7 @@ private
Is_Valid : Boolean := False;
Simple : Ada.Strings.Unbounded.Unbounded_String;
Full : Ada.Strings.Unbounded.Unbounded_String;
- Kind : File_Kind;
+ Kind : File_Kind := Ordinary_File;
end record;
-- The type Search_Data is defined in the body, so that the spec does not
Index: a-direct.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-direct.adb,v
retrieving revision 1.1
diff -u -p -r1.1 a-direct.adb
--- a-direct.adb 5 Apr 2004 14:57:42 -0000 1.1
+++ a-direct.adb 9 Sep 2004 09:24:29 -0000
@@ -38,22 +38,25 @@ with Ada.Unchecked_Deallocation;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regexp; use GNAT.Regexp;
+-- ??? Ada units cannot depend on GNAT units
with System;
package body Ada.Directories is
type Search_Data is record
- Is_Valid : Boolean := False;
- Name : Ada.Strings.Unbounded.Unbounded_String;
- Pattern : Regexp;
- Filter : Filter_Type;
- Dir : Dir_Type;
+ Is_Valid : Boolean := False;
+ Name : Ada.Strings.Unbounded.Unbounded_String;
+ Pattern : Regexp;
+ Filter : Filter_Type;
+ Dir : Dir_Type;
Entry_Fetched : Boolean := False;
Dir_Entry : Directory_Entry_Type;
end record;
+ -- Comment required ???
Empty_String : constant String := (1 .. 0 => ASCII.NUL);
+ -- Comment required ???
procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
@@ -97,9 +100,8 @@ package body Ada.Directories is
Name : String;
Extension : String := "") return String
is
- Result : String (1 ..
- Containing_Directory'Length +
- Name'Length + Extension'Length + 2);
+ Result : String (1 .. Containing_Directory'Length +
+ Name'Length + Extension'Length + 2);
Last : Natural;
begin
@@ -205,9 +207,9 @@ package body Ada.Directories is
begin
-- First, the invalid cases
- if (not Is_Valid_Path_Name (Source_Name)) or else
- (not Is_Valid_Path_Name (Target_Name)) or else
- (not Is_Regular_File (Source_Name))
+ if not Is_Valid_Path_Name (Source_Name)
+ or else not Is_Valid_Path_Name (Target_Name)
+ or else not Is_Regular_File (Source_Name)
then
raise Name_Error;
@@ -328,10 +330,17 @@ package body Ada.Directories is
-----------------------
function Current_Directory return String is
- begin
+
-- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
- return Get_Current_Dir;
+ Cur : constant String := Get_Current_Dir;
+
+ begin
+ if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
+ return Cur (1 .. Cur'Last - 1);
+ else
+ return Cur;
+ end if;
end Current_Directory;
----------------------
@@ -340,11 +349,14 @@ package body Ada.Directories is
procedure Delete_Directory (Directory : String) is
begin
- -- First, the invalid case
+ -- First, the invalid cases
if not Is_Valid_Path_Name (Directory) then
raise Name_Error;
+ elsif not Is_Directory (Directory) then
+ raise Name_Error;
+
else
-- The implementation uses GNAT.Directory_Operations.Remove_Dir
@@ -391,11 +403,14 @@ package body Ada.Directories is
procedure Delete_Tree (Directory : String) is
begin
- -- First, the invalid case
+ -- First, the invalid cases
if not Is_Valid_Path_Name (Directory) then
raise Name_Error;
+ elsif not Is_Directory (Directory) then
+ raise Name_Error;
+
else
-- The implementation uses GNAT.Directory_Operations.Remove_Dir
@@ -439,13 +454,12 @@ package body Ada.Directories is
raise Name_Error;
else
- -- Look fir the first dot that is not followed by a directory
- -- separator.
+ -- Look for first dot that is not followed by a directory separator
for Pos in reverse Name'Range loop
- -- If a directory separator is found before a dot, there is no
- -- extension.
+ -- If a directory separator is found before a dot, there
+ -- is no extension.
if Name (Pos) = Dir_Separator then
return Empty_String;
@@ -459,6 +473,8 @@ package body Ada.Directories is
begin
Result := Name (Pos + 1 .. Name'Last);
return Result;
+ -- This should be done with a subtype conversion, avoiding
+ -- the unnecessary junk copy ???
end;
end if;
end loop;
@@ -476,7 +492,9 @@ package body Ada.Directories is
procedure Fetch_Next_Entry (Search : Search_Type) is
Name : String (1 .. 255);
Last : Natural;
- Kind : File_Kind;
+
+ Kind : File_Kind := Ordinary_File;
+ -- Initialized to avoid a compilation warning
begin
-- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
@@ -499,7 +517,7 @@ package body Ada.Directories is
Compose
(To_String
(Search.Value.Name), Name (1 .. Last));
- Found : Boolean := False;
+ Found : Boolean := False;
begin
if File_Exists (Full_Name) then
@@ -553,7 +571,6 @@ package body Ada.Directories is
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
-
return C_File_Exists (C_Name (1)'Address) = 1;
end File_Exists;
@@ -587,8 +604,9 @@ package body Ada.Directories is
raise Name_Error;
else
- -- Build the return value with lower bound 1.
- -- Use GNAT.OS_Lib.Normalize_Pathname.
+ -- Build the return value with lower bound 1
+
+ -- Use GNAT.OS_Lib.Normalize_Pathname
declare
Value : constant String := Normalize_Pathname (Name);
@@ -596,6 +614,7 @@ package body Ada.Directories is
begin
Result := Value;
return Result;
+ -- Should use subtype conversion, not junk copy ???
end;
end if;
end Full_Name;
@@ -775,7 +794,7 @@ package body Ada.Directories is
raise Use_Error;
else
- -- The implemewntation uses GNAT.OS_Lib.Rename_File
+ -- The implementation uses GNAT.OS_Lib.Rename_File
Rename_File (Old_Name, New_Name, Success);
@@ -812,16 +831,18 @@ package body Ada.Directories is
raise Name_Error;
else
- -- Build the value to return with lower bound 1.
- -- The implementation uses GNAT.Directory_Operations.Base_Name.
+ -- Build the value to return with lower bound 1
+
+ -- The implementation uses GNAT.Directory_Operations.Base_Name
declare
- Value : constant String :=
+ Value : constant String :=
GNAT.Directory_Operations.Base_Name (Name);
Result : String (1 .. Value'Length);
begin
Result := Value;
return Result;
+ -- Should use subtype conversion instead of junk copy ???
end;
end if;
end Simple_Name;
@@ -849,7 +870,7 @@ package body Ada.Directories is
function Size (Name : String) return File_Size is
C_Name : String (1 .. Name'Length + 1);
- function C_Size (Name : System.Address) return File_Size;
+ function C_Size (Name : System.Address) return Long_Integer;
pragma Import (C, C_Size, "__gnat_named_file_length");
begin
@@ -861,7 +882,7 @@ package body Ada.Directories is
else
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
- return C_Size (C_Name'Address);
+ return File_Size (C_Size (C_Name'Address));
end if;
end Size;
Index: gnat_ugn.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat_ugn.texi,v
retrieving revision 1.19
diff -u -p -r1.19 gnat_ugn.texi
--- gnat_ugn.texi 1 Sep 2004 11:51:52 -0000 1.19
+++ gnat_ugn.texi 9 Sep 2004 09:24:30 -0000
@@ -98,8 +98,6 @@
@set FILE gnat_ugn_vms
@end ifset
-
-
@settitle @value{EDITION} User's Guide for Native Platforms / @value{PLATFORM}
@dircategory GNU Ada tools
@direntry
@@ -149,7 +147,6 @@ A copy of the license is included in the
@end titlepage
-
@ifnottex
@node Top, About This Guide, (dir), (dir)
@top @value{EDITION} User's Guide
@@ -321,7 +318,6 @@ The GNAT Make Program gnatmake
* How gnatmake Works::
* Examples of gnatmake Usage::
-
Improving Performance
* Performance Considerations::
* Reducing the Size of Ada Executables with gnatelim::
@@ -384,7 +380,6 @@ GNAT Project Manager
* An Extended Example::
* Project File Complete Syntax::
-
The Cross-Referencing Tools gnatxref and gnatfind
* gnatxref Switches::
@@ -394,13 +389,11 @@ The Cross-Referencing Tools gnatxref and
* Examples of gnatxref Usage::
* Examples of gnatfind Usage::
-
The GNAT Pretty-Printer gnatpp
* Switches for gnatpp::
* Formatting Rules::
-
File Name Krunching Using gnatkr
* About gnatkr::
@@ -622,7 +615,6 @@ Microsoft Windows Topics
* GNAT and COM/DCOM Objects::
@end ifset
-
* Index::
@end menu
@end ifnottex
@@ -649,8 +641,6 @@ For ease of exposition, ``GNAT Pro'' wil
``GNAT'' in the remainder of this document.
@end ifset
-
-
@menu
* What This Guide Contains::
* What You Should Know before Reading This Guide::
@@ -729,7 +719,6 @@ way to navigate through sources.
version of an Ada source file with control over casing, indentation,
comment placement, and other elements of program presentation style.
-
@item
@ref{File Name Krunching Using gnatkr}, describes the @code{gnatkr}
file name krunching utility, used to handle shortened
@@ -826,7 +815,6 @@ Microsoft Windows platform.
@end ifset
@end itemize
-
@c *************************************************
@node What You Should Know before Reading This Guide
@c *************************************************
@@ -933,8 +921,6 @@ If you are using GNAT on a Windows platf
the ``@code{\}'' character should be used instead.
@end ifset
-
-
@c ****************************
@node Getting Started with GNAT
@chapter Getting Started with GNAT
@@ -991,7 +977,6 @@ All three steps are most commonly handle
utility program that, given the name of the main program, automatically
performs the necessary compilation, binding and linking steps.
-
@node Running a Simple Ada Program
@section Running a Simple Ada Program
@@ -1114,7 +1099,6 @@ Hello WORLD!
@noindent
appear in response to this command.
-
@c ****************************************
@node Running a Program with Multiple Units
@section Running a Program with Multiple Units
@@ -1322,7 +1306,6 @@ startup menu).
* Simple Debugging with GPS::
@end menu
-
@node Building a New Program with GPS
@subsection Building a New Program with GPS
@noindent
@@ -1429,7 +1412,6 @@ Select @code{File}, then @code{Save As},
The file will be saved in the same directory you specified as the
location of the default project file.
-
@item @emph{Updating the project file}
You need to add the new source file to the project.
@@ -1463,8 +1445,6 @@ Close the GPS window (or select @code{Fi
terminate this GPS session.
@end enumerate
-
-
@node Simple Debugging with GPS
@subsection Simple Debugging with GPS
@noindent
@@ -1572,7 +1552,6 @@ Right click on @code{N}, select @code{De
You will see information about @code{N} appear in the @code{Debugger Data}
pane, showing the value as 5.
-
@item @emph{Assigning a new value to a variable}
Right click on the @code{N} in the @code{Debugger Data} pane, and
@@ -1608,7 +1587,6 @@ The console window will disappear.
@end enumerate
@end enumerate
-
@node Introduction to Glide and GVD
@section Introduction to Glide and GVD
@cindex Glide
@@ -3483,7 +3461,6 @@ directory designated by the logical name
GNAT uses the current directory for temporary files.
@end ifset
-
@c *************************
@node Compiling Using gcc
@chapter Compiling Using @code{gcc}
@@ -4122,7 +4099,6 @@ is equivalent to specifying the followin
@end smallexample
@end ifclear
-
@c NEED TO CHECK THIS FOR VMS
@noindent
@@ -4166,7 +4142,6 @@ as validity checking options (see descri
@end ifclear
@end itemize
-
@node Output and Error Message Control
@subsection Output and Error Message Control
@findex stderr
@@ -4330,7 +4305,6 @@ List possible interpretations for ambigu
Additional details on incorrect parameters
@end itemize
-
@item -gnatq
@cindex @option{-gnatq} (@code{gcc})
@ifclear vms
@@ -4374,7 +4348,6 @@ since ALI files are never generated if @
@end table
-
@node Warning Message Control
@subsection Warning Message Control
@cindex Warning messages
@@ -4467,7 +4440,6 @@ Mismatching bounds in an aggregate
@item
Attempt to return local value by reference
-
@item
Premature instantiation of a generic body
@@ -4528,7 +4500,6 @@ Useless exception handlers
@item
Accidental hiding of name by child unit
-
@item
Access before elaboration detected at compile time
@@ -4969,7 +4940,6 @@ When no switch @option{^-gnatw^/WARNINGS
@end table
-
@node Debugging and Assertion Control
@subsection Debugging and Assertion Control
@@ -5063,7 +5033,6 @@ indicate validity checks that are perfor
to the default checks described above.
@end ifset
-
@table @option
@c !sort!
@item -gnatVa
@@ -5227,7 +5196,6 @@ See also the pragma @code{Validity_Check
the validity checking mode at the program source level, and also allows for
temporary disabling of validity checks.
-
@node Style Checking
@subsection Style Checking
@findex Style checking
@@ -5781,7 +5749,6 @@ increase the amount of stack for the env
is an operating systems issue, and must be addressed with the
appropriate operating systems commands.
-
@node Using gcc for Syntax Checking
@subsection Using @code{gcc} for Syntax Checking
@table @option
@@ -5837,7 +5804,6 @@ together. This is primarily used by the
(@pxref{Renaming Files Using gnatchop}).
@end table
-
@node Using gcc for Semantic Checking
@subsection Using @code{gcc} for Semantic Checking
@table @option
@@ -6025,7 +5991,6 @@ to enable file name krunching.
For the source file naming rules, @xref{File Naming Rules}.
@end table
-
@node Subprogram Inlining Control
@subsection Subprogram Inlining Control
@@ -6415,7 +6380,6 @@ and communicates it to the compiler usin
@end table
-
@node Integrated Preprocessing
@subsection Integrated Preprocessing
@@ -6603,7 +6567,6 @@ are suitable for spawning with appropria
@end ifset
-
@node Search Paths and the Run-Time Library (RTL)
@section Search Paths and the Run-Time Library (RTL)
@@ -6717,7 +6680,6 @@ Besides simplifying access to the RTL, a
in compiling sources from multiple directories. This can make
development environments much more flexible.
-
@node Order of Compilation Issues
@section Order of Compilation Issues
@@ -6827,7 +6789,6 @@ This information is output in the forms
to be read by the @code{gnatlink} utility used to link the Ada application.
@end enumerate
-
@node Running gnatbind
@section Running @code{gnatbind}
@@ -6919,7 +6880,6 @@ The use of the @option{^-C^/BIND_FILE=C^
for both @code{gnatbind} and @code{gnatlink} will cause the program to
be generated in C (and compiled using the gnu C compiler).
-
@node Switches for gnatbind
@section Switches for @command{gnatbind}
@@ -7173,7 +7133,6 @@ You may obtain this listing of switches
no arguments.
@end ifclear
-
@node Consistency-Checking Modes
@subsection Consistency-Checking Modes
@@ -7496,7 +7455,6 @@ a list of ALI files can be given, and th
consists of elaboration of these units in an appropriate order.
@end table
-
@node Command-Line Access
@section Command-Line Access
@@ -7527,7 +7485,6 @@ required, your main program must set @co
@code{gnat_argv} from the @code{argc} and @code{argv} values passed to
it.
-
@node Search Paths for gnatbind
@section Search Paths for @code{gnatbind}
@@ -7696,7 +7653,6 @@ the @code{adainit} and @code{adafinal} r
after accessing the Ada units.
@end table
-
@c ------------------------------------
@node Linking Using gnatlink
@chapter Linking Using @code{gnatlink}
@@ -8583,13 +8539,6 @@ if you want to specify library paths
only.
@item
-@code{gnatmake} examines both an ALI file and its corresponding object file
-for consistency. If an ALI is more recent than its corresponding object,
-or if the object file is missing, the corresponding source will be recompiled.
-Note that @code{gnatmake} expects an ALI and the corresponding object file
-to be in the same directory.
-
-@item
@code{gnatmake} will ignore any files whose ALI file is write-protected.
This may conveniently be used to exclude standard libraries from
consideration and in particular it means that the use of the
@@ -8642,8 +8591,7 @@ approach and in particular to understand
previous compilations without incorrectly depending on them.
First a definition: an object file is considered @dfn{up to date} if the
-corresponding ALI file exists and its time stamp predates that of the
-object file and if all the source files listed in the
+corresponding ALI file exists and if all the source files listed in the
dependency section of this ALI file have time stamps matching those in
the ALI file. This means that neither the source file itself nor any
files that it depends on have been modified, and hence there is no need
@@ -8710,7 +8658,6 @@ listed by the binder. @code{gnatmake} wi
displaying commands it is executing.
@end table
-
@c *************************
@node Improving Performance
@chapter Improving Performance
@@ -8730,7 +8677,6 @@ the size of program executables.
@end menu
@end ifnottex
-
@c *****************************
@node Performance Considerations
@section Performance Considerations
@@ -8935,7 +8881,6 @@ is generally discouraged with GNAT, sinc
executables which run more slowly. See further discussion of this point
in @pxref{Inlining of Subprograms}.
-
@node Debugging Optimized Code
@subsection Debugging Optimized Code
@cindex Debugging optimized code
@@ -9064,7 +9009,6 @@ on the resulting executable,
which removes both debugging information and global symbols.
@end ifclear
-
@node Inlining of Subprograms
@subsection Inlining of Subprograms
@@ -9574,7 +9518,6 @@ the @file{gnat.adc} file. You should rec
from scratch after that, because you need a consistent @file{gnat.adc} file
during the entire compilation.
-
@node Making Your Executables Smaller
@subsection Making Your Executables Smaller
@@ -9635,9 +9578,6 @@ $ gnatmake ^-f main_prog^/FORCE_COMPILE
@end enumerate
-
-
-
@c ********************************
@node Renaming Files Using gnatchop
@chapter Renaming Files Using @code{gnatchop}
@@ -9682,7 +9622,6 @@ system, you can set up a procedure where
time you compile, regarding the source files that it writes as temporary
files that you throw away.
-
@node Operating gnatchop in Compilation Mode
@section Operating gnatchop in Compilation Mode
@@ -9997,6 +9936,7 @@ recognized by @code{GNAT}:
Ada_95
C_Pass_By_Copy
Component_Alignment
+ Detect_Blocking
Discard_Names
Elaboration_Checks
Eliminate
@@ -10333,7 +10273,6 @@ even in conjunction with one or several
@option{^-D^/DIRS_FILE^}. Several Naming Patterns and one excluded pattern
are used in this example.
-
@c *****************************************
@c * G N A T P r o j e c t M a n a g e r *
@c *****************************************
@@ -10744,7 +10683,7 @@ invoking @command{gnatmake} (see @ref{gn
@noindent
By default, the executable file name corresponding to a main source is
-deducted from the main source file name. Through the attributes
+deduced from the main source file name. Through the attributes
@code{Executable} and @code{Executable_Suffix} of package @code{Builder},
it is possible to change this default.
In project @code{Debug} above, the executable file name
@@ -12542,7 +12481,6 @@ All @file{ALI} files will also be copied
library directory. To build executables, @command{gnatmake} will use the
library rather than the individual object files.
-
@c **********************************************
@c * Using Third-Party Libraries through Projects
@c **********************************************
@@ -13730,7 +13668,6 @@ simple_name ::=
@end smallexample
-
@node The Cross-Referencing Tools gnatxref and gnatfind
@chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind}
@findex gnatxref
@@ -14426,7 +14363,6 @@ point to any character in the middle of
@end table
-
@c *********************************
@node The GNAT Pretty-Printer gnatpp
@chapter The GNAT Pretty-Printer @command{gnatpp}
@@ -14478,7 +14414,6 @@ allowed. The file name may contain path
follow the GNAT file naming rules
@end itemize
-
@menu
* Switches for gnatpp::
* Formatting Rules::
@@ -14540,7 +14475,6 @@ indicate the effect.
* Other gnatpp Switches::
@end menu
-
@node Alignment Control
@subsection Alignment Control
@cindex Alignment control in @command{gnatpp}
@@ -14581,7 +14515,6 @@ Align @code{=>} in associations
The @option{^-A^/ALIGN^} switches are mutually compatible; any combination
is allowed.
-
@node Casing Control
@subsection Casing Control
@cindex Casing control in @command{gnatpp}
@@ -14676,7 +14609,6 @@ The @option{^-D-^/SPECIFIC_CASING^} and
@option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually
compatible.
-
@node Construct Layout Control
@subsection Construct Layout Control
@cindex Layout control in @command{gnatpp}
@@ -14771,7 +14703,6 @@ indentation is set to 1 (in which case t
line indentation is also 1)
@end table
-
@node Other Formatting Options
@subsection Other Formatting Options
@@ -14831,7 +14762,6 @@ The same as the corresponding gcc switch
@end table
-
@node Output File Control
@subsection Output File Control
@@ -14913,7 +14843,6 @@ Warning mode;
a required layout in the result source.
@end table
-
@node Formatting Rules
@section Formatting Rules
@@ -14929,7 +14858,6 @@ They provide the detailed descriptions o
* Name Casing::
@end menu
-
@node White Space and Empty Lines
@subsection White Space and Empty Lines
@@ -14963,7 +14891,6 @@ In order to preserve a visual separation
Likewise, if for some reason you wish to have a sequence of empty lines,
use a sequence of empty comments instead.
-
@node Formatting Comments
@subsection Formatting Comments
@@ -15107,7 +15034,6 @@ comments may be reformatted in typical
word processor style (that is, moving words between lines and putting as
many words in a line as possible).
-
@node Construct Layout
@subsection Construct Layout
@@ -15185,7 +15111,6 @@ type q is record
end record; b : integer;
end record;
-
Block : declare Block :
A : Integer := 3; declare
begin A : Integer := 3;
@@ -15206,7 +15131,6 @@ A further difference between GNAT style
GNAT style layout inserts empty lines as separation for
compound statements, return statements and bodies.
-
@node Name Casing
@subsection Name Casing
@@ -15399,8 +15323,6 @@ end Test;
@end cartouche
@end smallexample
-
-
@c ***********************************
@node File Name Krunching Using gnatkr
@chapter File Name Krunching Using @code{gnatkr}
@@ -16578,7 +16500,6 @@ library, by reordering the lines in the
library must be installed before the GNAT library if it redefines
any part of it.
-
@node Using the library
@subsection Using the library
@@ -16646,7 +16567,6 @@ pragma Linker_Options ("-lmy_lib");
@end smallexample
@end itemize
-
@node Stand-alone Ada Libraries
@section Stand-alone Ada Libraries
@cindex Stand-alone library, building, using
@@ -16926,7 +16846,6 @@ gnat library. This Makefile contains its
particular the set of instructions needed to rebuild a new library and
to use it.
-
@node Using the GNU make Utility
@chapter Using the GNU @code{make} Utility
@findex make
@@ -17218,7 +17137,6 @@ all:
@end smallexample
@end ifclear
-
@node Finding Memory Problems
@chapter Finding Memory Problems
@@ -17238,7 +17156,6 @@ access values (including ``dangling refe
* The GNAT Debug Pool Facility::
@end menu
-
@ifclear vms
@node The gnatmem Tool
@section The @command{gnatmem} Tool
@@ -17581,7 +17498,6 @@ and #3 thanks to the more precise associ
@end ifclear
-
@node The GNAT Debug Pool Facility
@section The GNAT Debug Pool Facility
@findex Debug Pool
@@ -17726,7 +17642,6 @@ Debug Pool info:
High Water Mark: 8
@end smallexample
-
@node Creating Sample Bodies Using gnatstub
@chapter Creating Sample Bodies Using @command{gnatstub}
@findex gnatstub
@@ -17903,7 +17818,6 @@ Verbose mode: generate version informati
@end table
-
@node Other Utility Programs
@chapter Other Utility Programs
@@ -18098,7 +18012,6 @@ For more information, please refer to th
available in the @code{Glide} @result{} @code{Help} menu.
@end ifclear
-
@node Converting Ada Files to html with gnathtml
@section Converting Ada Files to HTML with @code{gnathtml}
@@ -18389,7 +18302,6 @@ The simplest command is simply @code{run
exactly as if the debugger were not present. The following section
describes some of the additional commands that can be given to @code{GDB}.
-
@c *******************************
@node Introduction to GDB Commands
@section Introduction to GDB Commands
@@ -19189,7 +19101,6 @@ You can then get further information by
tool as described earlier (note that the hexadecimal addresses
need to be specified in C format, with a leading ``0x'').
-
@node Symbolic Traceback
@subsection Symbolic Traceback
@cindex traceback, symbolic
@@ -20893,7 +20804,6 @@ and GNAT systems.
@end ifset
-
@c **************************************
@node Platform-Specific Information for the Run-Time Libraries
@appendix Platform-Specific Information for the Run-Time Libraries
@@ -20957,11 +20867,9 @@ information about several specific platf
* AIX-Specific Considerations::
@end menu
-
@node Summary of Run-Time Configurations
@section Summary of Run-Time Configurations
-
@multitable @columnfractions .30 .70
@item @b{alpha-openvms}
@item @code{@ @ }@i{rts-native (default)}
@@ -21021,8 +20929,6 @@ information about several specific platf
@*
@end multitable
-
-
@node Specifying a Run-Time Library
@section Specifying a Run-Time Library
@@ -21196,7 +21102,6 @@ you find that the improved efficiency of
Note also that to take full advantage of Florist and Glade, it is highly
recommended that you use native threads.
-
@node Choosing the Scheduling Policy
@section Choosing the Scheduling Policy
@@ -21235,8 +21140,6 @@ you should use @code{pragma Time_Slice}
value greater than @code{0.0}, or else use the corresponding @option{-T}
binder option.
-
-
@node Solaris-Specific Considerations
@section Solaris-Specific Considerations
@cindex Solaris Sparc threads libraries
@@ -21251,7 +21154,6 @@ debugging 64-bit applications.
* Building and Debugging 64-bit Applications::
@end menu
-
@node Solaris Threads Issues
@subsection Solaris Threads Issues
@@ -21305,7 +21207,6 @@ Run the program on the specified process
(where @code{_SC_NPROCESSORS_CONF} is a system variable).
@end table
-
@node Building and Debugging 64-bit Applications
@subsection Building and Debugging 64-bit Applications
@@ -21329,8 +21230,6 @@ amounts to:
$ gdb64 hello
@end smallexample
-
-
@node IRIX-Specific Considerations
@section IRIX-Specific Considerations
@cindex IRIX thread library
@@ -21351,7 +21250,6 @@ See the @cite{GNAT Reference Manual} for
The @emph{n32 ABI} compiler comes with a run-time library based on the
kernel POSIX threads and thus does not have the limitations mentioned above.
-
@node Linux-Specific Considerations
@section Linux-Specific Considerations
@cindex Linux threads libraries
@@ -21395,7 +21293,6 @@ This Appendix displays the source code f
file generated for a simple ``Hello World'' program.
Comments have been added for clarification purposes.
-
@smallexample @c adanocomment
@iftex
@leftskip=0cm
@@ -22111,7 +22008,6 @@ and trace the elaboration routine for th
the problem might be (more usually of course you would be debugging
elaboration code in your own application).
-
@node Elaboration Order Handling in GNAT
@appendix Elaboration Order Handling in GNAT
@cindex Order of elaboration
@@ -23967,7 +23863,6 @@ difference, by looking at the two elabor
and figuring out which is correct, and then adding the necessary
@code{Elaborate_All} pragmas to ensure the desired order.
-
@node Inline Assembler
@appendix Inline Assembler
@@ -25578,8 +25473,6 @@ end Intel_CPU;
@c END OF INLINE ASSEMBLER CHAPTER
@c ===============================
-
-
@c ***********************************
@c * Compatibility and Porting Guide *
@c ***********************************
@@ -25784,7 +25677,6 @@ include @code{pragma Interface} and the
(@code{Emax}, @code{Mantissa}, etc.), among other items.
@end table
-
@node Implementation-dependent characteristics
@section Implementation-dependent characteristics
@noindent
@@ -25805,7 +25697,6 @@ transition from certain Ada 83 compilers
* Target-specific aspects::
@end menu
-
@node Implementation-defined pragmas
@subsection Implementation-defined pragmas
@@ -25903,7 +25794,6 @@ incompatible with typical Ada 83 compile
packing, the meaning of the Size attribute, and the size of access values.
GNAT's approach to these issues is described in @ref{Representation Clauses}.
-
@node Compatibility with Other Ada 95 Systems
@section Compatibility with Other Ada 95 Systems
@@ -26104,8 +25994,6 @@ attributes are recognized, although only
be implemented. The description of pragmas in this reference manual
indicates whether or not they are applicable to non-VMS systems.
-
-
@ifset unw
@node Microsoft Windows Topics
@appendix Microsoft Windows Topics
@@ -27878,7 +27766,6 @@ This section is temporarily left blank.
@end ifset
-
@c **********************************
@c * GNU Free Documentation License *
@c **********************************
Index: gnat_rm.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat_rm.texi,v
retrieving revision 1.29
diff -u -p -r1.29 gnat_rm.texi
--- gnat_rm.texi 13 Aug 2004 10:24:46 -0000 1.29
+++ gnat_rm.texi 9 Sep 2004 09:24:31 -0000
@@ -117,6 +117,7 @@ Implementation Defined Pragmas
* Pragma CPP_Virtual::
* Pragma CPP_Vtable::
* Pragma Debug::
+* Pragma Detect_Blocking::
* Pragma Elaboration_Checks::
* Pragma Eliminate::
* Pragma Export_Exception::
@@ -308,7 +309,7 @@ The GNAT Library
* GNAT.Memory_Dump (g-memdum.ads)::
* GNAT.Most_Recent_Exception (g-moreex.ads)::
* GNAT.OS_Lib (g-os_lib.ads)::
-* GNAT.Perfect_Hash.Generators (g-pehage.ads)::
+* GNAT.Perfect_Hash_Generators (g-pehage.ads)::
* GNAT.Regexp (g-regexp.ads)::
* GNAT.Registry (g-regist.ads)::
* GNAT.Regpat (g-regpat.ads)::
@@ -632,6 +633,7 @@ consideration, the use of these pragmas
* Pragma CPP_Virtual::
* Pragma CPP_Vtable::
* Pragma Debug::
+* Pragma Detect_Blocking::
* Pragma Elaboration_Checks::
* Pragma Eliminate::
* Pragma Export_Exception::
@@ -1330,6 +1332,21 @@ with a terminating semicolon. Pragmas a
declarations, so you can use pragma @code{Debug} to intersperse calls to
debug procedures in the middle of declarations.
+@node Pragma Detect_Blocking
+@unnumberedsec Pragma Detect_Blocking
+@findex Detect_Blocking
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Detect_Blocking;
+@end smallexample
+
+@noindent
+This is a configuration pragma that forces the detection of potentially
+blocking operations within a protected operation, and to raise Program_Error
+if that happens.
+
@node Pragma Elaboration_Checks
@unnumberedsec Pragma Elaboration_Checks
@cindex Elaboration control
@@ -11495,7 +11512,7 @@ of GNAT, and will generate a warning mes
* GNAT.Memory_Dump (g-memdum.ads)::
* GNAT.Most_Recent_Exception (g-moreex.ads)::
* GNAT.OS_Lib (g-os_lib.ads)::
-* GNAT.Perfect_Hash.Generators (g-pehage.ads)::
+* GNAT.Perfect_Hash_Generators (g-pehage.ads)::
* GNAT.Regexp (g-regexp.ads)::
* GNAT.Registry (g-regist.ads)::
* GNAT.Regpat (g-regpat.ads)::
@@ -12137,9 +12154,9 @@ including time/date management, file ope
including a portable spawn procedure, and access to environment variables
and error return codes.
-@node GNAT.Perfect_Hash.Generators (g-pehage.ads)
-@section @code{GNAT.Perfect_Hash.Generators} (@file{g-pehage.ads})
-@cindex @code{GNAT.Perfect_Hash.Generators} (@file{g-pehage.ads})
+@node GNAT.Perfect_Hash_Generators (g-pehage.ads)
+@section @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads})
+@cindex @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads})
@cindex Hash functions
@noindent
Index: s-solita.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-solita.adb,v
retrieving revision 1.2
diff -u -p -r1.2 s-solita.adb
--- s-solita.adb 9 Aug 2004 12:24:25 -0000 1.2
+++ s-solita.adb 9 Sep 2004 09:24:31 -0000
@@ -44,6 +44,12 @@ with System.Task_Primitives.Operations;
-- Used for Self
-- Timed_Delay
+with System.Tasking;
+-- Used for Task_Id
+
+with Ada.Exceptions;
+-- Used for Raise_Exception
+
package body System.Soft_Links.Tasking is
package STPO renames System.Task_Primitives.Operations;
@@ -79,9 +85,9 @@ package body System.Soft_Links.Tasking i
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-- Task-safe version of SSL.Timed_Delay
- ----------------------
- -- Soft-Link Bodies --
- ----------------------
+ --------------------------
+ -- Soft-Link Get Bodies --
+ --------------------------
function Get_Current_Excep return SSL.EOA is
begin
@@ -103,6 +109,10 @@ package body System.Soft_Links.Tasking i
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
+ --------------------------
+ -- Soft-Link Set Bodies --
+ --------------------------
+
procedure Set_Jmpbuf_Address (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
@@ -118,9 +128,27 @@ package body System.Soft_Links.Tasking i
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
+ -------------------
+ -- Timed_Delay_T --
+ -------------------
+
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
+ Self_Id : constant System.Tasking.Task_Id := STPO.Self;
+
begin
- STPO.Timed_Delay (STPO.Self, Time, Mode);
+ -- In case pragma Detect_Blocking is active then Program_Error
+ -- must be raised if this potentially blocking operation
+ -- is called from a protected operation.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ STPO.Timed_Delay (Self_Id, Time, Mode);
+ end if;
+
end Timed_Delay_T;
-----------------------------
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 14:49 ` Florian Weimer
@ 2004-09-01 20:48 ` Florian Weimer
0 siblings, 0 replies; 178+ messages in thread
From: Florian Weimer @ 2004-09-01 20:48 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: Richard Kenner, gcc-patches
* Florian Weimer:
> * Arnaud Charlet:
>
>>> I'm not aware of anything "in the pipe" that affects bootstrapping, actually,
>>> though I last tried it yesterday, so I don't understand this. We bootstrapped
>>> with -O2 on x86-64 yesterday evening.
>>
>> I just tried a bootstrap from scratch on i686-linux with default options,
>> and indeed, got no trouble.
>
> Hmm, my troubles might be a result of a broken GCC 3.4 package
> supplied by Debian. I'm going to try GNAT 3.15p next.
It turned out that I was building from a CVS checkout that wasn't as
up-to-date as I expected. D'oh!
stage1 compilation was successful, finally. I'm sorry for the noise.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 13:32 Richard Kenner
2004-09-01 14:15 ` Andreas Schwab
2004-09-01 14:38 ` Arnaud Charlet
@ 2004-09-01 16:08 ` Andreas Schwab
2 siblings, 0 replies; 178+ messages in thread
From: Andreas Schwab @ 2004-09-01 16:08 UTC (permalink / raw)
To: Richard Kenner; +Cc: charlet, gcc-patches
kenner@vlsi1.ultra.nyu.edu (Richard Kenner) writes:
> I use -O0 to bootstrap, pending middle/back-end fixes.
>
> I'm not aware of anything "in the pipe" that affects bootstrapping, actually,
> though I last tried it yesterday, so I don't understand this. We bootstrapped
> with -O2 on x86-64 yesterday evening.
Here is what I get when bootstrapping the current sources on ia64-linux:
../../xgcc -B../../ -c -g -O2 -fPIC -W -Wall -gnatpg a-teioed.adb -o a-teioed.o
a-teioed.adb: In function `Ada.Text_Io.Editing.Format_Number':
a-teioed.adb:843: error: Call edges for non-call insn in bb 537
a-teioed.adb:843: error: Call edges for non-call insn in bb 536
a-teioed.adb:843: error: Call edges for non-call insn in bb 535
a-teioed.adb:843: error: Call edges for non-call insn in bb 534
a-teioed.adb:843: error: Call edges for non-call insn in bb 533
a-teioed.adb:843: error: Call edges for non-call insn in bb 532
a-teioed.adb:843: error: Call edges for non-call insn in bb 531
a-teioed.adb:843: error: Call edges for non-call insn in bb 530
a-teioed.adb:843: error: Call edges for non-call insn in bb 529
a-teioed.adb:843: error: Call edges for non-call insn in bb 528
a-teioed.adb:843: error: Call edges for non-call insn in bb 527
a-teioed.adb:843: error: Call edges for non-call insn in bb 526
a-teioed.adb:843: error: Call edges for non-call insn in bb 525
a-teioed.adb:843: error: Call edges for non-call insn in bb 524
a-teioed.adb:843: error: Call edges for non-call insn in bb 523
+===========================GNAT BUG DETECTED==============================+
| 3.5.0 20040901 (experimental) (ia64-suse-linux-gnu) GCC error: |
| verify_flow_info failed |
| Error detected at a-teioed.adb:2909:1 |
Andreas.
--
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux AG, Maxfeldstraße 5, 90409 Nürnberg, Germany
Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 15:38 ` Arnaud Charlet
@ 2004-09-01 15:45 ` Andreas Schwab
0 siblings, 0 replies; 178+ messages in thread
From: Andreas Schwab @ 2004-09-01 15:45 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: Richard Kenner, gcc-patches
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
>> Well, for example, I made the utils.c change that was mentioned. And
>> I also remember running into the atree.adb blowup. It was due to the
>> TYPE_VALUE_CACHE stuff and was fixed by no longer changing TYPE_UNSIGNED
>> of a type. So it looks like at least those changes I did got lost.
>
> None of your changes got lost. Do not hesitate to have a look if you
> have some doubts, although it seems clear from follow up messages that
> older sources were used for the reported failure.
Yes, nothing seems to be lost. I apologize for the confusion.
Andreas.
--
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux AG, Maxfeldstraße 5, 90409 Nürnberg, Germany
Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 15:28 Richard Kenner
@ 2004-09-01 15:38 ` Arnaud Charlet
2004-09-01 15:45 ` Andreas Schwab
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-09-01 15:38 UTC (permalink / raw)
To: Richard Kenner; +Cc: charlet, gcc-patches
> Well, for example, I made the utils.c change that was mentioned. And
> I also remember running into the atree.adb blowup. It was due to the
> TYPE_VALUE_CACHE stuff and was fixed by no longer changing TYPE_UNSIGNED
> of a type. So it looks like at least those changes I did got lost.
None of your changes got lost. Do not hesitate to have a look if you
have some doubts, although it seems clear from follow up messages that
older sources were used for the reported failure.
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-09-01 15:28 Richard Kenner
2004-09-01 15:38 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Richard Kenner @ 2004-09-01 15:28 UTC (permalink / raw)
To: charlet; +Cc: gcc-patches
Not sure what I should be looking for, could be be more explicit ?
Well, for example, I made the utils.c change that was mentioned. And
I also remember running into the atree.adb blowup. It was due to the
TYPE_VALUE_CACHE stuff and was fixed by no longer changing TYPE_UNSIGNED
of a type. So it looks like at least those changes I did got lost.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 14:22 Richard Kenner
@ 2004-09-01 14:57 ` Andreas Schwab
0 siblings, 0 replies; 178+ messages in thread
From: Andreas Schwab @ 2004-09-01 14:57 UTC (permalink / raw)
To: Richard Kenner; +Cc: charlet, gcc-patches
kenner@vlsi1.ultra.nyu.edu (Richard Kenner) writes:
> Something funny is going on here because both of those are bugs I've already
> fixed.
The tree I tested was checked out today at 08:00 UTC, so it missed the
changes that Arno checked in today. I'll recheck later with the latest
sources.
Andreas.
--
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux AG, Maxfeldstraße 5, 90409 Nürnberg, Germany
Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 14:38 ` Arnaud Charlet
@ 2004-09-01 14:49 ` Florian Weimer
2004-09-01 20:48 ` Florian Weimer
0 siblings, 1 reply; 178+ messages in thread
From: Florian Weimer @ 2004-09-01 14:49 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: Richard Kenner, gcc-patches
* Arnaud Charlet:
>> I'm not aware of anything "in the pipe" that affects bootstrapping, actually,
>> though I last tried it yesterday, so I don't understand this. We bootstrapped
>> with -O2 on x86-64 yesterday evening.
>
> I just tried a bootstrap from scratch on i686-linux with default options,
> and indeed, got no trouble.
Hmm, my troubles might be a result of a broken GCC 3.4 package
supplied by Debian. I'm going to try GNAT 3.15p next.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 13:32 Richard Kenner
2004-09-01 14:15 ` Andreas Schwab
@ 2004-09-01 14:38 ` Arnaud Charlet
2004-09-01 14:49 ` Florian Weimer
2004-09-01 16:08 ` Andreas Schwab
2 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-09-01 14:38 UTC (permalink / raw)
To: Richard Kenner; +Cc: charlet, gcc-patches
> I'm not aware of anything "in the pipe" that affects bootstrapping, actually,
> though I last tried it yesterday, so I don't understand this. We bootstrapped
> with -O2 on x86-64 yesterday evening.
I just tried a bootstrap from scratch on i686-linux with default options,
and indeed, got no trouble.
In another message you said:
<<
Arno, can you doublecheck the merge you did?
>>
Not sure what I should be looking for, could be be more explicit ?
The merge should be pretty safe, since I ended up taking your changes almost
unchanged and reviewed carefully the remaining differences.
I also checked that I had no local changes in my tree.
Did other people do a bootstrap from a clean build tree ?
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-09-01 14:22 Richard Kenner
2004-09-01 14:57 ` Andreas Schwab
0 siblings, 1 reply; 178+ messages in thread
From: Richard Kenner @ 2004-09-01 14:22 UTC (permalink / raw)
To: schwab; +Cc: charlet, gcc-patches
Something funny is going on here because both of those are bugs I've already
fixed.
Arno, can you doublecheck the merge you did?
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 13:32 Richard Kenner
@ 2004-09-01 14:15 ` Andreas Schwab
2004-09-01 14:38 ` Arnaud Charlet
2004-09-01 16:08 ` Andreas Schwab
2 siblings, 0 replies; 178+ messages in thread
From: Andreas Schwab @ 2004-09-01 14:15 UTC (permalink / raw)
To: Richard Kenner; +Cc: charlet, gcc-patches
kenner@vlsi1.ultra.nyu.edu (Richard Kenner) writes:
> I use -O0 to bootstrap, pending middle/back-end fixes.
>
> I'm not aware of anything "in the pipe" that affects bootstrapping, actually,
> though I last tried it yesterday, so I don't understand this. We bootstrapped
> with -O2 on x86-64 yesterday evening.
When I try on ia64 I get this crash:
stage1/xgcc -Bstage1/ -B/usr/local/ia64-suse-linux/bin/ -c -g -O2 -gnatpg -gnata -g -O0 \
-I- -I. -Iada -I../../gcc/ada ../../gcc/ada/memtrack.adb -o ada/memtrack.o
+===========================GNAT BUG DETECTED==============================+
| 3.5.0 20040901 (experimental) (ia64-suse-linux-gnu) Segmentation fault |
| Error detected at a-exexda.adb:361:8 |
This can be fixed with this patch:
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.79
diff -u -p -a -u -p -a -r1.79 utils.c
--- utils.c 27 Aug 2004 10:02:30 -0000 1.79
+++ utils.c 1 Sep 2004 14:05:15 -0000
@@ -431,6 +431,7 @@ gnat_define_builtin (const char *name, t
TREE_READONLY (decl) = const_p;
implicit_built_in_decls[function_code] = decl;
+ built_in_decls[function_code] = decl;
}
/* Install the builtin functions the middle-end needs. */
But even then I only get little further:
stage1/xgcc -Bstage1/ -B/usr/local/ia64-suse-linux/bin/ -c -g -O2 -gnatpg -gnata -I- -I. -Iada -I../../gcc/ada ../../gcc/ada/atree.adb -o ada/atree.o
+===========================GNAT BUG DETECTED==============================+
| 3.5.0 20040831 (experimental) (ia64-suse-linux-gnu) GCC error: |
| in build_int_cst_wide, at tree.c:517 |
| Error detected at atree.adb:248:28 |
Should I put that in bugzilla?
Andreas.
--
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux AG, Maxfeldstraße 5, 90409 Nürnberg, Germany
Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-09-01 13:32 Richard Kenner
2004-09-01 14:15 ` Andreas Schwab
` (2 more replies)
0 siblings, 3 replies; 178+ messages in thread
From: Richard Kenner @ 2004-09-01 13:32 UTC (permalink / raw)
To: charlet; +Cc: gcc-patches
I use -O0 to bootstrap, pending middle/back-end fixes.
I'm not aware of anything "in the pipe" that affects bootstrapping, actually,
though I last tried it yesterday, so I don't understand this. We bootstrapped
with -O2 on x86-64 yesterday evening.
There are pending changes to fix ACATS failures.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 12:55 ` Florian Weimer
@ 2004-09-01 12:59 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-09-01 12:59 UTC (permalink / raw)
To: Florian Weimer; +Cc: Arnaud Charlet, gcc-patches
> How have you tested this? I still can't bootstrap on x86, GNU/Linux:
I use -O0 to bootstrap, pending middle/back-end fixes.
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-09-01 12:05 Arnaud Charlet
@ 2004-09-01 12:55 ` Florian Weimer
2004-09-01 12:59 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Florian Weimer @ 2004-09-01 12:55 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
* Arnaud Charlet:
> Tested on i686-linux
How have you tested this? I still can't bootstrap on x86, GNU/Linux:
stage1/xgcc -Bstage1/ -B/home/fw/src/install/gcc.ada-2004-09-01/i686-pc-linux-gnu/bin/ -c -O2 -g -march=athlon-xp -gnatpg -gnata -g -O1 -fno-inline \
-I- -I. -Iada -I/home/fw/src/gnu/gcc.ada/gcc/ada /home/fw/src/gnu/gcc.ada/gcc/ada/a-except.adb -o ada/a-except.o
+===========================GNAT BUG DETECTED==============================+
| 3.5.0 20040817 (experimental) (i686-pc-linux-gnu) Storage_Error stack overflow (or erroneous memory access)|
| Error detected at a-except.adb:47:17 |
Shall I open a PR? Or is it still the case that Ada doesn't bootstrap
on mainline?
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-09-01 12:05 Arnaud Charlet
2004-09-01 12:55 ` Florian Weimer
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-09-01 12:05 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4736 bytes --]
Tested on i686-linux
--
2004-08-31 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* misc.c (gnat_print_type): Use TYPE_RM_SIZE_NUM.
* trans.c (struct stmt_group): Delete field GLOBAL.
(gnat_init_stmt_group): Do not initialize it.
(call_to_gnu): Use save_expr, not protect_multiple_eval.
(Exception_Handler_to_gnu_sjlj): Call build_int_cst, not build_int_2
(gnat_to_gnu, case N_Character_Literal, N_String_Literal): Likewise.
(gnat_to_gnu, case N_Compilation_Unit): Do not set GLOBAL in stmt group.
(start_stmt_group): Likewise.
(add_stmt, add_decl_expr): Rework handling of global DECL_EXPRs.
* utils2.c (ggc.h): Include.
(build_call_raise): Call build_int_cst, not build_int_2.
* utils.c (gnat_init_decl_processing): Fix arg to
build_common_tree_nodes.
(create_subprog_type): Do not use SET_TYPE_CI_CO_LIST.
(gnat_define_builtin): Set built_in_decls.
(init_gigi_decls): Call build_int_cst, not build_int_2.
* ada-tree.h (struct lang_decl, struct lang_type): Field is type tree.
(GET_TYPE_LANG_SPECIFIC, SET_TYPE_LANG_SPECIFIC): New macros.
(GET_DECL_LANG_SPECIFIC, SET_DECL_LANG_SPECIFIC): Likewise.
(TYPE_CI_CO_LIST, SET_TYPE_CI_CO_LIST, TYPE_MODULE,
SET_TYPE_MODULE): Use them.
(TYPE_INDEX_TYPE, SET_TYPE_INDEX_TYPE, TYPE_DIGITS_VALUE): Likewise.
(SET_TYPE_DIGITS_VALUE, TYPE_UNCONSTRAINED_ARRAY): Likewise.
(SET_TYPE_UNCONSTRAINED_ARRAY, TYPE_ADA_SIZE,
SET_TYPE_ADA_SIZE): Likewise.
(TYPE_ACTUAL_BOUNDS, SET_TYPE_ACTUAL_BOUNDS): Likewise.
(DECL_CONST_CORRESPONDING_VAR,
SET_DECL_CONST_CORRESPONDING_VAR): Likewise.
(DECL_ORIGINAL_FIELD, SET_DECL_ORIGINAL_FIELD): Likewise.
(TYPE_RM_SIZE_INT, TYPE_RM_SIZE_ENUM, SET_TYPE_RM_SIZE_ENUM): Deleted.
(TYPE_RM_SIZE_NUM): New macro.
(TYPE_RM_SIZE): Modified to use above.
* cuintp.c: (build_cst_from_int): New function.
(UI_To_gnu): Use it.
* decl.c (gnat_to_gnu_entity): Use TYPE_RM_SIZE_NUM.
(make_type_from_size): Avoid changing TYPE_UNSIGNED of a type.
(gnat_substitute_in_type, case ARRAY_TYPE): If old had a
MIN_EXPR for the size, copy it into new.
2004-08-31 Robert Dewar <dewar@gnat.com>
* exp_ch6.adb (Expand_Call): Properly handle validity checks for
packed indexed component where array is an IN OUT formal. This
generated garbage code previously.
* gnat_ugn.texi: Document -fverbose-asm
* gnat-style.texi: Minor updates (note that boolean constants and
variables are joined with AND/OR rather than short circuit forms).
2004-08-31 Ed Schonberg <schonberg@gnat.com>
* exp_util.adb (Safe_Unchecked_Type_Conversion): Conversion is safe if
it is an upward conversion of an untagged type with no representation
change.
2004-08-31 Thomas Quinot <quinot@act-europe.fr>
* rtsfind.ads: Move RCI_Subp_Info and RCI_Subp_Info_Array to
System.Partition_Interface.
* checks.adb (Apply_Access_Checks): Do not generate checks when
expander is not active (but check for unset reference to prefix of
dereference).
* sem_prag.adb (Analyze_Pragma, case Pragma_Debug): Uniformly rewrite
pragma Debug as an if statement with a constant condition, for
consistent treatment of entity references contained within the
enclosed procedure call.
2004-08-31 Vincent Celier <celier@gnat.com>
* bindgen.adb: (Set_EA_Last): New procedure
(Gen_Exception_Table_Ada, Gen_Exception_Table_C): Use new procedure
Set_EA_Last.
(Gen_Adafinal_Ada): If no finalization, adafinal does nothing
(Gen_Output_File_Ada): Always call Gen_Adafinal_Ada, so that SAL can be
linked without errors.
(Gen_Exception_Table_Ada): Correct bugs when generating code for arrays
ST and EA.
(Gen_Exception_Table_C): Correct same bugs
* vms_data.ads: Add new qualifier /VERBOSE_ASM to GCC_Switches
* g-os_lib.adb (Normalize_Pathname.Get_Directory): When Dir is empty,
on Windows, make sure that the drive letter is in upper case.
* g-os_lib.ads (Normalize_Pathname): Add a comment to indicate that on
Windows, when the drive letter is added and Case_Sensitive is True, the
drive letter is forced to upper case.
* mlib-tgt-irix.adb (Build_Dynamic_Library): Transfer all -lxxx options
to Options_2 for the call to MLib.Utl.Gcc.
* bld.adb (Put_Include_Project): Use '/', not '\' on Windows as
directory separator when defining BASE_DIR.
2004-08-19 Pascal Obry <obry@gnat.com>
* gprcmd.adb (Extend): Do not output trailing directory separator. This
is not needed and it confuses Windows GNU/make which does not report
directory terminated by a slash as a directory.
(gprcmd): Idem for "pwd" internal command.
* Makefile.generic: Use __GPRCOLON__ instead of pipe character in
target names rewrite to fix regressions with recent version of
GNU/make. Starting with GNU/make 3.80 the pipe character was not
handled properly anymore.
[-- Attachment #2: difs.gnat.gz --]
[-- Type: application/x-gunzip, Size: 13924 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-08-16 9:20 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-08-16 9:20 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 594 bytes --]
Tested on i686-linux
--
2004-08-16 Pascal Obry <obry@gnat.com>
* adaint.c (__gnat_prj_add_obj_files): Set to 0 only on Win32 for GCC
backend prior to GCC 3.4. With GCC 3.4 we are using the GCC's shared
option and not mdll anymore. Update comment.
2004-08-16 Pascal Obry <obry@gnat.com>
* bld.adb (Put_Include_Project): Properly handle directory separators
on Windows.
2004-08-16 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Try_Object_Operation): Restructure code. Optimize by
decreasing the number of allocated junk nodes while searching for the
appropriate subprogram.
[-- Attachment #2: difs.gnat.gz --]
[-- Type: application/x-gunzip, Size: 10504 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-08-13 10:44 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-08-13 10:44 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1939 bytes --]
Tested on i686-linux
--
2004-08-13 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_entity) <E_Variable>: When building an allocator
for a global aliased object with a variable size and an unconstrained
nominal subtype, pretend there is no initializer if the one we have is
incomplete, and avoid referencing an inexistant component in there. The
part we have will be rebuilt anyway and the reference may confuse
further operations.
2004-08-13 Thomas Quinot <quinot@act-europe.fr>
* einfo.ads: Minor reformatting
* lib-writ.adb (Output_Main_Program_Line): Do not set parameter
restrictions in the ALI if we only want to warn about violations.
2004-08-13 Vincent Celier <celier@gnat.com>
* ali.adb (Scan_ALI): Initialize component Body_Needed_For_SAL to False
when creating a new Unit_Record in table Units.
* gnatls.adb (Output_Unit): In verbose mode, output the restrictions
that are violated, if any.
* prj-nmsc.adb (Ada_Check.Get_Path_Names_And_Record_Sources): Do not
add directory separator if path already ends with a directory separator.
2004-08-13 Ed Schonberg <schonberg@gnat.com>
* rtsfind.adb (Entity_Not_Defined): If the error ocurrs in a predefined
unit, this is an attempt to inline a construct that is not available in
the current restricted mode, so abort rather than trying to continue.
* sem_ch3.adb (Build_Underlying_Full_View): If the new type has
discriminants that rename those of the parent, recover names of
original discriminants for the constraint on the full view of the
parent.
(Complete_Private_Subtype): Do not create a subtype declaration if the
subtype is an itype.
* gnat_rm.texi: Added section on implementation of discriminated
records with default values for discriminants.
2004-08-13 Ed Schonberg <schonberg@gnat.com>
PR ada/15601
* sem_res.adb (Make_Call_Into_Operator): Handle properly the case where
the second operand is overloaded.
[-- Attachment #2: difs.gnat.gz --]
[-- Type: application/x-gunzip, Size: 9355 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-08-09 13:10 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-08-09 13:10 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 12439 bytes --]
Tested and committed on HEAD on i686-linux
Bootstrap done with CFLAGS="-g -O0" BOOT_CFLAGS="-g -O0" until ssa-related
issues are solved.
I got 85 ACATS failures due to the tree-ssa move, not due to these
changes.
Arno
--
2004-08-09 Thomas Quinot <quinot@act-europe.fr>
* g-socket.adb (Abort_Selector): Initialize Buf to prevent valgrind
from complaining on potential uninitialized reference.
Change calls to GNAT.Sockets.Thin.Is_Socket_In_Set to account for
new specification and test explicitly for non-zero return value.
* g-socthi.ads (Is_Socket_In_Set): Declare imported function as
returning C.int, to avoid using a derived boolean type.
* exp_ch5.adb (Make_Tag_Ctrl_Assignments): Use
Duplicate_Subexpr_No_Checks in preference to direct use of
Remove_Side_Effects and New_Copy_Tree.
Clear Comes_From_Source on prefix of 'Size attribute reference.
* g-socthi.adb, g-socthi-vms.adb, g-socthi-mingw.adb,
g-socthi-vxworks.adb: Change calls to
GNAT.Sockets.Thin.Is_Socket_In_Set to account for new specification
and test explicitly for non-zero return value.
* g-socthi-vms.ads, g-socthi-mingw.ads, g-socthi-vxworks.ads:
(Is_Socket_In_Set): Declare imported function as returning C.int, to
avoid using a derived boolean type.
2004-08-09 Albert Lee <lee@gnat.com>
* system-irix-n32.ads: Refine tasking priority constants for IRIX.
2004-08-09 Pascal Obry <obry@gnat.com>
* gnat_ugn.texi: Document new way to build DLLs on Windows using
GCC's -shared option.
* mlib-tgt-mingw.adb (Build_Dynamic_Library): Pass GCC's options into
Options_2 parameter (options put after object files).
2004-08-09 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Adjust condition to
ignore overflows on low and high bounds of an index to also account for
differences in signedness between sizetype and gnu_index_subtype.
These are as legitimate as the ones caused by a lower TYPE_PRECISION
on sizetype.
2004-08-09 Robert Dewar <dewar@gnat.com>
* s-solita.ads, s-solita.adb: Minor reformatting
* gnat_rm.texi: Add documentation for pragma Profile (Restricted)
Move pragma Restricted_Run_Time, No_Run_Time, Ravenscar to new
obsolescent section
Add note that No_Implicit_Conditionals does not suppress
run time constraint checks.
* vms_conv.ads: Minor reformatting
* s-secsta.adb: Use SS_Ptr instead of Mark_Id as stack pointer (cleanup
and necessary for following change).
(Mark): Return new format Mark_Id containing sec stack address
(Release): Use sec stack address from Mark_Id avoiding Self call
* s-secsta.ads: Define SS_Ptr to be used instead of Mark_Id as stack
pointer (cleanup and necessary for following change).
Define Mark_Id as record containing address of secondary stack, that way
Release does not need to find the stack again, decreasing the number of
calls to Self and improving efficiency.
* sem_util.ads: Add a ??? comment for Is_Local_Variable_Reference
* sem_ch5.adb (Analyze_Case_Statement): Add circuitry to track value of
case variable into the individual case branches when possible.
* sem_ch11.adb: Minor reformatting
* prj.ads: Correct spelling of suffixs
* prj-nmsc.adb: Minor reformatting
Correct spelling suffixs throughout (also in identifiers)
* freeze.adb: Minor spelling correction
* exp_ch2.adb: Cleanups to handling of Current_Value
(no functional effect).
* bld.adb: Correct spelling of suffixs
* einfo.adb (Enclosing_Dynamic_Scope): Defend against junk argument
2004-08-09 Ed Schonberg <schonberg@gnat.com>
PR ada/15408
* sem_ch7.adb (Install_Private_Declarations): In the body of the
package or of a child, private entities are both immediately_visible
and not hidden.
2004-08-09 Ed Schonberg <schonberg@gnat.com>
* sem_eval.adb (Eval_Integer_Literal): If the context is Any_Integer,
there are no range checks on the value of the literal.
* exp_ch7.adb (Insert_Actions_In_Scope_Around): If the node being
wrapped is the triggering alternative of an asynchronous select, action
statements mustbe inserted before the select itself.
* sem_attr.adb (Analyze_Attribute, case 'Size): Handle properly the
case where the prefix is a protected function call.
(Resolve_Attribute, case 'Access): The attribute reference on a
subprogram is legal in a generic body if the subprogram is declared
elsewhere.
2004-08-09 Vincent Celier <celier@gnat.com>
* makegpr.adb (Build_Library): Link with g++ if C++ is one of the
languages, otherwise building the library may fail with unresolved
symbols.
(Compile_Sources): Do not build libraries if -c switch is used
* gnatlink.adb (Process_Args): New switches -M and -Mmap
(Write_Usage): If map file creation is supported, output new switches
-M and -Mmap.
(Gnatlink): When -M is specified, add the necessary switch(es) to the
gcc call, when supported.
* Makefile.in: Added indepsw.o to the object list for gnatlink
Specified the AIX, GNU/Linux and Windows versions of indepsw.adb
* indepsw-aix.adb, indepsw-linux.adb, indepsw-mingw.adb,
indepsw.adb, indepsw.ads: New files.
2004-08-09 Bernard Banner <banner@gnat.com>
* system-vxworks-x86.ads, s-vxwork-x86.ads: New files.
* Makefile.in: add section for vxworks x86
2004-08-09 Hristian Kirtchev <kirtchev@gnat.com>
* exp_ch3.adb (Build_Init_Statements): Add extra condition to deal with
per-object constrained components where the discriminant is of an
Access type.
(Build_Record_Init_Proc): Add condition to prevent the inheritance of
the parent initialization procedure for derived Unchecked_Unions.
Instead, derived Unchecked_Unions build their own initialization
procedure.
(Build_Variant_Record_Equality): Implement Unchecked_Union equality.
Check the body of the subprogram for details.
(Freeze_Record_Type): Prevent the inheritance of discriminant checking
functions for derived Unchecked_Union types by introducing a condition.
Allow the creation of TSS equality functions for Unchecked_Unions.
(Make_Eq_Case): Rename formal parameter Node to E in function signature.
Add formal parameter Discr to function signature. Discr is used to
control the generated case statement for Unchecked_Union types.
(Make_Eq_If): Rename formal parameter Node to E in function signature.
* exp_ch4.adb (Build_Equality_Call): Implement equality calls for
Unchecked_Unions.
Check the body of the subprogram for details.
(Expand_Composite_Equality): Augment composite type equality to include
correct handling of Unchecked_Union components.
(Expand_N_In): Add condition to detect illegal membership tests when the
subtype mark is a constrained Unchecked_Union and the expression lacks
inferable discriminants, and build a Raise_Program_Error node.
(Expand_N_Op_Eq): Add function Has_Unconstrained_UU_Component. Used
to detect types that contain components of unconstrained Unchecked_Union
subtype. Add condition to detect equality between types that have an
unconstrained Unchecked_Union component, and build a Raise_Program_Error
node. Add condition to detect equality between Unchecked_Union types
that lack inferable discriminants, and build a Raise_Program_Error node.
Otherwise build a TSS equality function call.
(Expand_N_Type_Conversion): Add condition to detect illegal conversions
from a derived Unchecked_Union to an unconstrained non-Unchecked_Union
with the operand lacking inferable discriminants, and build a Raise_
Program_Error node.
(Expand_Record_Equality): Remove guard that prevents Unchecked_Union
composite equality.
(Has_Inferable_Discriminants): Implement new predicate for objects and
expressions of Unchecked_Union type. Check the body of subprogram for
details.
(Has_Unconstrained_UU_Components): Add function
Component_Is_Unconstrained_UU. It is used to detect whether a single
component is of an unconstrained Unchecked_Union subtype. Add function
Variant_Is_Unconstrained_UU. It is used to detect whether a single
component inside a variant is of an unconstrained Unchecked_Union type.
* exp_ch5.adb (Expand_Assign_Record): Add condition to copy the
inferred discriminant values. Add condition to generate a case
statement with an inferred discriminant as the switch.
(Make_Component_List_Assign): Introduce a Boolean flag that determines
the behaviour of the subprogram in the presence of an Unchecked_Union.
Add condition to trigger the usage of the inferred discriminant value
as the generated case statement switch.
(Make_Field_Assign): Introduce a Boolean flag that determines the
behaviour of the subprogram in the presence of an Unchecked_Union. Add
condition to trigger the usage of the inferred discriminant value as
the right-hand side of the generated assignment.
* exp_ch6.adb (Expand_Call): Add condition to skip extra actual
parameter generation when dealing with Unchecked_Unions.
* checks.adb (Apply_Discriminant_Check): Do not apply discriminant
checks for Unchecked_Unions.
* einfo.ads: Update comment on usage of flag Has_Per_Object_Constraint
* exp_attr.adb (Expand_N_Attribute_Reference): Produce
Raise_Program_Error nodes for the execution of Read and Write
attributes of Unchecked_Union types and the execution of Input and
Output attributes of Unchecked_Union types that lack default
discriminant values.
* sem_prag.adb (Analyze_Pragma): Remodel the analysis of pragma
Unchecked_Union. Add procedure Check_Component. It is used to inspect
per-object constrained components of Unchecked_Unions for being
Unchecked_Unions themselves. Add procedure Check_Variant. It is used to
check individual components withing a variant.
* sem_res.adb (Resolve_Comparison_Op): Remove guard that prevents
comparison of Unchecked_Unions.
(Resolve_Equality_OP): Remove guard that prevents equality between
Unchecked_Unions.
* sem_util.adb (Build_Component_Subtype): Add guard to prevent creation
of component subtypes for Unchecked_Union components.
(Get_Actual_Subtype): Add condition that returs the Unchecked_Union type
since it is the actual subtype.
* sem_ch12.adb (Instantiate_Type): Add condition to detect the correct
pass of Unchecked_Union subtypes as generic actuals to formal types
that lack known_discriminant_parts or that are derived Unchecked_Union
types, and do nothing. In any other case, produce an error message.
* sem_ch3.adb (Analyze_Component_Declaration): Add function
Contains_POC. It determines whether a constraint uses the discriminant
of an enclosing record type.
Add condition to detect per-object constrained component and set the
appropriate flag.
(Derived_Type_Declaration): Remove guard that prevents derivation from
Unchecked_Union types.
(Process_Subtype): Remove quard that prevents the creation of Unchecked_
Union subtypes.
* sem_ch4.adb (Analyze_Selected_Component): Correct the detection of
references to Unchecked_Union discriminants.
* sem_ch6.adb (Create_Extra_Formals): Add condition to skip extra
formal generation when dealing with Unchecked_Unions.
(Set_Actual_Subtypes): Add condition to prevent generation of actual
subtypes for Unchecked_Unions.
* sem_ch7.adb (Analyze_Package_Specification): Add procedure
Inspect_Unchecked_Union_Completion. It is used to detect incorrect
completions of discriminated partial views by Unchecked_Unions and
produce an error message.
2004-08-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (struct stmt_group): New field, GLOBAL.
(global_stmt_group, gnu_elab_proc_decl, build_unit_elab): Deleted.
(struct elab_info): New struct.
(elab_info_list, gnu_elab_proc_stack): New variables.
(Compilation_Unit_to_gnu): New procedure.
(gigi): Call it and also handle elaboration procs we've saved.
(gnat_init_stmt_group): Don't set global_stmt_group; instead initialize
global field from parent.
(gnat_to_gnu): Get decl from gnu_elab_proc_stack.
(gnat_to_gnu, case N_Compilation_Unit): Call Compilation_Unit_to_gnu.
(start_stmt_group): Initialize global field from parent.
(add_decl_expr): Set to global for current statement group.
(gnat_gimplify_expr, case NULL_EXPR): Add operand 0 to pre list, not
post.
* utils.c (global_bindings_p): True when no current_function_decl; no
longer check current_binding_level.
2004-08-09 Ben Brosgol <brosgol@gnat.com>
* xgnatugn.adb: Added logic to deal with @ifset/@ifclear for edition
choice.
* gnat_rm.texi, gnat_ugn.texi: Added edition conditionalization logic.
[-- Attachment #2: difs.gnat.gz --]
[-- Type: application/x-gunzip, Size: 46555 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-07-20 20:21 ` Arnaud Charlet
@ 2004-07-20 20:24 ` Duncan Sands
0 siblings, 0 replies; 178+ messages in thread
From: Duncan Sands @ 2004-07-20 20:24 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
Hi Arnaud, thanks for replying.
> As pointed out, the tag (not branch) used is tree-ssa-pre-merge, although
> getting things to work together is tricky, since the gigi (gnat to gnu)
> head sources correespond to tree-ssa, not to pre-ssa, so a mix a old gigi files
> and new front-end/run time files is needed,plus a few tweaks.
>
> Definitely not something I would recommend (even for me, it is getting trickier
> and trickier to test those changes), and I'd rather see Ada at least bootstrap
> on a few platforms (such as x86-linux) instead. AFAIk, we're not that far,
> but there are still middle-end issues blocking this.
It sounds painful. I think I will instead just backport the fixes that I need.
All the best,
Duncan.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-07-20 20:11 ` Duncan Sands
2004-07-20 20:12 ` Andrew Pinski
@ 2004-07-20 20:21 ` Arnaud Charlet
2004-07-20 20:24 ` Duncan Sands
1 sibling, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-07-20 20:21 UTC (permalink / raw)
To: Duncan Sands; +Cc: gcc-patches, Arnaud Charlet
> Hi Arnaud, where can I find the pre-ssa branch? (I rummaged around
> but couldn't work out how to check it out). And when I have it, should I
> replace the gcc/ada directory with that from the ssa-branch if I want to
> try these updates?
As pointed out, the tag (not branch) used is tree-ssa-pre-merge, although
getting things to work together is tricky, since the gigi (gnat to gnu)
head sources correespond to tree-ssa, not to pre-ssa, so a mix a old gigi files
and new front-end/run time files is needed,plus a few tweaks.
Definitely not something I would recommend (even for me, it is getting trickier
and trickier to test those changes), and I'd rather see Ada at least bootstrap
on a few platforms (such as x86-linux) instead. AFAIk, we're not that far,
but there are still middle-end issues blocking this.
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-07-20 20:11 ` Duncan Sands
@ 2004-07-20 20:12 ` Andrew Pinski
2004-07-20 20:21 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Andrew Pinski @ 2004-07-20 20:12 UTC (permalink / raw)
To: Duncan Sands; +Cc: gcc-patches, Arnaud Charlet
On Jul 20, 2004, at 7:18 AM, Duncan Sands wrote:
> On Tuesday 20 July 2004 12:27, Arnaud Charlet wrote:
>> Tested on i686-linux with a pre ssa compiler
>
> Hi Arnaud, where can I find the pre-ssa branch? (I rummaged around
> but couldn't work out how to check it out). And when I have it,
> should I
> replace the gcc/ada directory with that from the ssa-branch if I want
> to
> try these updates?
The tag you want to check out is: tree-ssa-pre-merge.
Other than that and how to compile the Ada compiler with the more recent
Ada sources I do not know.
Thanks,
Andrew Pinski
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-07-20 18:29 Arnaud Charlet
@ 2004-07-20 20:11 ` Duncan Sands
2004-07-20 20:12 ` Andrew Pinski
2004-07-20 20:21 ` Arnaud Charlet
0 siblings, 2 replies; 178+ messages in thread
From: Duncan Sands @ 2004-07-20 20:11 UTC (permalink / raw)
To: gcc-patches; +Cc: Arnaud Charlet
On Tuesday 20 July 2004 12:27, Arnaud Charlet wrote:
> Tested on i686-linux with a pre ssa compiler
Hi Arnaud, where can I find the pre-ssa branch? (I rummaged around
but couldn't work out how to check it out). And when I have it, should I
replace the gcc/ada directory with that from the ssa-branch if I want to
try these updates?
Thanks a lot,
Duncan.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-07-20 18:29 Arnaud Charlet
2004-07-20 20:11 ` Duncan Sands
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-07-20 18:29 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4030 bytes --]
Tested on i686-linux with a pre ssa compiler
--
2004-07-20 Olivier Hainque <hainque@act-europe.fr>
* a-elchha.adb (Last_Chance_Handler): Remove the bogus buffer dynamic
allocation and potentially overflowing update with
Tailored_Exception_Information. Use the sec-stack free procedural
interface to output Exception_Information instead.
* a-except.adb (To_Stderr): New subprogram for character, and string
version moved from a-exextr to be visible from other separate units.
(Tailored_Exception_Information): Remove the procedural version,
previously used by the default Last_Chance_Handler and not any more.
Adjust various comments.
* a-exexda.adb: Generalize the exception information procedural
interface, to minimize the use of secondary stack and the need for
local buffers when the info is to be output to stderr:
(Address_Image): Removed.
(Append_Info_Character): New subprogram, checking for overflows and
outputing to stderr if buffer to fill is of length 0.
(Append_Info_String): Output to stderr if buffer to fill is of length 0.
(Append_Info_Address, Append_Info_Exception_Name,
Append_Info_Exception_Message, Append_Info_Basic_Exception_Information,
Append_Info_Basic_Exception_Traceback,
Append_Info_Exception_Information): New subprograms.
(Append_Info_Nat, Append_Info_NL): Use Append_Info_Character.
(Basic_Exception_Info_Maxlength, Basic_Exception_Tback_Maxlength,
Exception_Info_Maxlength, Exception_Name_Length,
Exception_Message_Length): New subprograms.
(Exception_Information): Use Append_Info_Exception_Information.
(Tailored_Exception_Information): Use
Append_Info_Basic_Exception_Information.
Export services for the default Last_Chance_Handler.
* a-exextr.adb (To_Stderr): Remove. Now in a-except to be usable by
other separate units.
2004-07-20 Vincent Celier <celier@gnat.com>
* clean.adb, mlib-utl.adb, osint.adb, makegpr.adb: Minor reformatting.
2004-07-20 Ed Schonberg <schonberg@gnat.com>
* freeze.adb (Freeze_Entity): If entity is a discriminated record type,
emit itype references for the designated types of component types that
are declared outside of the full record declaration, and that may
denote a partial view of that record type.
2004-07-20 Ed Schonberg <schonberg@gnat.com>
PR ada/15607
* sem_ch3.adb (Build_Discriminated_Subtype): Do not attach a subtype
which is the designated type in an access component declaration, to the
list of incomplete dependents of the parent type, to avoid elaboration
issues with out-of-scope subtypes.
(Complete_Private_Subtype): Recompute Has_Unknown_Discriminants from the
full view of the parent.
2004-07-20 Ed Schonberg <schonberg@gnat.com>
PR ada/15610
* sem_ch8.adb (Find_Expanded_Name): If name is overloaded, reject
entities that are hidden, such as references to generic actuals
outside an instance.
2004-07-20 Javier Miranda <miranda@gnat.com>
* sem_ch4.adb (Try_Object_Operation): New subprogram that gives
support to the new notation.
(Analyze_Selected_Component): Add call to Try_Object_Operation.
2004-07-20 Jose Ruiz <ruiz@act-europe.fr>
* s-taprob.adb: Adding the elaboration code required for initializing
the tasking soft links that are common to the full and the restricted
run times.
* s-tarest.adb (Init_RTS): Tasking soft links that are shared with the
restricted run time has been moved to the package
System.Soft_Links.Tasking.
* s-tasini.adb (Init_RTS): Tasking soft links that are shared with the
restricted run time has been moved to the package
System.Soft_Links.Tasking.
* Makefile.rtl: Add entry for s-solita.o in run-time library list.
* s-solita.ads, s-solita.adb: New files.
2004-07-20 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (Identifier_to_gnu, Pragma_to_gnu, Attribute_to_gnu,
Case_Statement_to_gnu): Split off from gnat_to_gnu.
(Loop_Statement_to_gnu, Subprogram_Body_to_gnu, call_to_gnu,
Handled_Sequence_Of_Statements_to_gnu, Exception_Handler_to_gnu_sjlj,
Exception_Handler_to_gnu_zcx): Likewise.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 55380 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-07-16 2:57 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-07-16 2:57 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 6239 bytes --]
Tested on i686-linux with a pre-ssa compiler
--
2004-07-15 Robert Dewar <dewar@gnat.com>
* makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor
reformatting
* gnat_ugn.texi: Add instantiation of direct_io or sequential_io with
access values as an example of a warning.
* gnat_rm.texi: Document new attribute Has_Access_Values
* gnat-style.texi: Document that box comments belong on nested
subprograms
* sem_util.ads (Has_Access_Values): Improved documentation
* s-finimp.ads, s-finimp.adb: Fix spelling error in comment
* sem_prag.adb (Check_Duplicated_Export_Name): New procedure
(Process_Interface_Name): Call to this new procedure
(Set_Extended_Import_Export_External_Name): Call to this new procedure
* s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment
* a-direio.ads, a-sequio.ads: Warn if Element_Type has access values
* einfo.ads: Minor comment typo fixed
2004-07-15 Jose Ruiz <ruiz@act-europe.fr>
* snames.adb: Add _atcb.
* snames.ads: Add Name_uATCB.
* s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated
(in the expanded code) when using the restricted run time.
* s-tarest.ads (Create_Restricted_Task): Created_Task transformed into
a in parameter in order to allow ATCBs to be preallocated (in the
expanded code).
* s-taskin.adb (Initialize_ATCB): T converted into a in parameter in
order to allow ATCBs to be preallocated. In case of error, the ATCB is
deallocated in System.Tasking.Stages.
* s-taskin.ads (Initialize_ATCB): T converted into a in parameter in
order to allow ATCBs to be preallocated.
* s-tassta.adb (Create_Task): In case of error the ATCB is deallocated
here. It was previously done in Initialize_ATCB.
* rtsfind.ads: Make the Ada_Task_Control_Block visible.
* exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the
Restricted run time.
* exp_ch3.adb: When using the Restricted run time, pass the
preallocated Ada_Task_Control_Block when creating a task.
2004-07-15 Ed Schonberg <schonberg@gnat.com>
* sem_util.adb (Normalize_Actuals): If there are no actuals on a
function call that is itself an actual in an enclosing call, diagnose
problem here rather than assuming that resolution will catch it.
* sem_ch7.adb (Analyze_Package_Specification): If the specification is
the local copy of a generic unit for a formal package, and the generic
is a child unit, install private part of ancestors before compiling
private part of spec.
* sem_cat.adb (Validate_Categorization_Dependency): Simplify code to
use scope entities rather than tree structures, to handle properly
parent units that are instances rewritten as bodies for inlining
purposes.
* sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent,
Remove_Parents): Handle properly a parent unit that is an
instantiation, when the unit has been rewritten as a body for inlining
purposes.
* par.adb (Goto_List): Global variable to collect goto statements in a
given unit, for use in detecting natural loops.
* par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for
use in detecting natural loops.
* par-labl.adb (Find_Natural_Loops): Recognize loops create by
backwards goto's, and rewrite as a infinite loop, to improve locality
of temporaries.
* exp_util.adb (Force_Evaluation): Recognize a left-hand side
subcomponent that includes an indexed reference, to prevent the
generation of copies that would miscompile the desired assignment
statement.
(Build_Task_Image_Decls): Add a numeric suffix to
generated name for string variable, to avoid spurious conflicts with
the name of the type of a single protected object.
* exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a
loop with an explicit exit statement, to avoid generating an
out-of-range value with 'Succ leading to spurious constraint_errors
when compiling with -gnatVo.
2004-07-15 Thomas Quinot <quinot@act-europe.fr>
* sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it
might not be analyzed yet, even if its Etype is already set (case of an
unchecked conversion built using Unchecked_Convert_To, for example).
If the prefix has already been analyzed, this will be a nop anyway.
* exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a
controller type, or an assignment of a record type with controlled
components, copy only user data, and leave the finalization chain
pointers untouched.
2004-07-15 Vincent Celier <celier@gnat.com>
* make.adb (Collect_Arguments): Improve error message when attempting
to compile a source not part of any project, when -x is not used.
* prj.ads: (Defined_Variable_Kind): New subtype
* prj-attr.adb (Register_New_Package): Two new procedures to register
a package with or without its attributes.
(Register_New_Attribute): Mew procedure to register a new attribute in a
package.
New attribute oriented subprograms: Attribute_Node_Id_Of,
Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
Next_Attribute.
New package oriented subprograms: Package_Node_Id_Of,
Add_Unknown_Package, First_Attribute_Of, Add_Attribute.
* prj-attr.ads (Attribute_Node_Id): Now a private, self initialized
type.
(Package_Node_Id): Now a private, self initialized type
(Register_New_Package): New procedure to register a package with its
attributes.
New attribute oriented subprograms: Attribute_Node_Id_Of,
Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
Next_Attribute.
New package oriented subprograms: Package_Node_Id_Of,
Add_Unknown_Package, First_Attribute_Of, Add_Attribute.
* prj-dect.adb (Parse_Attribute_Declaration,
Parse_Package_Declaration): Adapt to new spec of Prj.Attr.
* prj-makr.adb (Make): Parse existing project file before creating
other files. Fail if there was an error during parsing.
* prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to
new spec of Prj.Attr.
* prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt
to new spec of Prj.Attr.
2004-07-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils2.c: Fix typo in comment.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 41262 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-07-14 3:46 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-07-14 3:46 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2399 bytes --]
Not fully tested, since this is the part of GNAT that depends now on
tree-ssa.
Part of these changes have been tested independently on other GCC back-ends.
This should get the FSF tree in sync with all changes made by Richard in
the Ada sources.
(Richard, please let me know if there are other missing patches)
Note: I got several merge conflicts doing this merge, so there is a small
chance that some changes made at the FSF on these files recently have
got lost, although I tried my best to avoid it, so as far as I know this
shouldn't be the case. If you find a missing change, do not hesitate
to coordinate with me to put this change back.
--
2004-07-13 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c: (gnat_to_gnu_entity, object case): Convert initializer to
object type.
(gnat_to_gnu_entity, case E_Record_Subtype): Properly set
TYPE_STUB_DECL.
* misc.c (gnat_types_compatible_p): New function.
(LANG_HOOKS_TYPES_COMPATIBLE_P): New hook, to use it.
(LANG_HOOKS_TYPE_MAX_SIZE, gnat_type_max_size): New.
* trans.c (gigi): Move processing of main N_Compilation_Unit here.
(gnat_to_gnu, case N_Compilation_Unit): Just handle nested case here.
(add_stmt): Force walking of sizes and DECL_INITIAL for DECL_EXPR.
(mark_visited): Don't mark dummy type.
(tree_transform <N_Procedure_Call_Statement>): Unless this is an In
parameter, we must remove any LJM building from GNU_NAME.
(gnat_to_gnu, case N_String_Literal): Fill in indices in CONSTRUCTOR.
(pos_to_constructor): Use int_const_binop.
(gnat_to_gnu, case N_Identifier): Don't reference DECL_INITIAL of
PARM_DECL.
* utils.c (gnat_init_decl_processing): Don't make two "void" decls.
(gnat_pushlevel): Set TREE_USE on BLOCK node.
(gnat_install_builtins): Add __builtin_memset.
2004-07-13 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_entity <E_Variable>): If we are making a pointer
for a renaming, stabilize the initialization expression if we are at a
local level. At the local level, uses of the renaming may be performed
by a direct dereference of the initializing expression, and we don't
want possible variables there to be evaluated for every use.
* trans.c (gnat_stabilize_reference, gnat_stabilize_reference_1):
Propagate TREE_SIDE_EFFECTS and TREE_THIS_VOLATILE to avoid loosing
them on the way. Account for the fact that we may introduce side
effects in the process.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 8007 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-07-06 14:10 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-07-06 14:10 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5151 bytes --]
Tested on i686-linux using the pre ssa merge tag.
--
2004-07-06 Vincent Celier <celier@gnat.com>
* vms_conv.ads: Minor reformatting.
Alphabetical order for enumerated values of type Command_Type, to have
the command in alphabetical order for the usage.
* vms_conv.adb (Process_Argument): Set Keep_Temporary_Files to True for
the special qualifier /KEEP_TEMPORARY_FILES (minimum 6 characters).
* gnat_ugn.texi: Document new switch -dn for the GNAT driver.
* makegpr.adb (Global_Archive_Exists): New global Boolean variable
(Add_Archive_Path): Only add the global archive if there is one.
(Build_Global_Archive): Set Global_Archive_Exists depending if there is
or not any object file to put in the global archive, and don't build
a global archive if there is none.
(X_Switches): New table
(Compile_Link_With_Gnatmake): Pass to gnatmake the -X switches stored
in the X_Switches table, if any.
(Initialize): Make sure the X_Switches table is empty
(Scan_Arg): Record -X switches in table X_Switches
* opt.ads (Keep_Temporary_Files): New Boolean flag, defaulted to False.
* make.adb: Minor comment fix
* gnatname.adb (Gnatname): When not on VMS, and gnatname has been
invoked with directory information, add the directory in front of the
path.
* gnatchop.adb (Gnatchop): When not on VMS, and gnatchop has been
invoked with directory information, add the directory in front of the
path.
* gnatcmd.adb (Delete_Temp_Config_Files): Only delete temporary files
when Keep_Temporary_Files is False.
(GNATCmd): When not on VMS, and the GNAT driver has been invoked with
directory information, add the directory in front of the path.
When not on VMS, handle new switch -dn before the command to set
Keep_Temporary_Files to True.
(Non_VMS_Usage): Use lower case for the non VMS usage: this is valid
everywhere.
* gnatlink.adb (Gnatlink): When not on VMS, and gnatlink has been
invoked with directory information, add the directory in front of the
path.
2004-07-06 Thomas Quinot <quinot@act-europe.fr>
* snames.ads, snames.adb (Name_Stub): New name for the distributed
systems annex.
* rtsfind.ads: New RTE TC_Object, for DSA/PolyORB.
New RTEs RAS_Proxy_Type and RAS_Proxy_Type_Access, for DSA.
* g-socket.adb (To_Timeval): Fix incorrect conversion of
Selector_Duration to Timeval for the case of 0.0.
* exp_util.ads (Evolve_Or_Else): Fix overenthusiastic copy/paste of
documentation from Evolve_And_Then.
2004-07-06 Jose Ruiz <ruiz@act-europe.fr>
* s-taprop-tru64.adb, s-taprop-os2.adb,
s-taprop-mingw.adb, s-taprop-posix.adb: Update comment.
2004-07-06 Robert Dewar <dewar@gnat.com>
* s-osinte-hpux.ads, s-osinte-freebsd.ads,
s-osinte-lynxos.ads, s-taprop-lynxos.adb, s-osinte-tru64.ads,
s-osinte-aix.ads, s-osinte-irix.ads, s-taprop-irix.adb,
s-interr-sigaction.adb, s-taprop-irix-athread.adb,
s-osinte-hpux-dce.adb, s-taprop-hpux-dce.adb,
s-taprop-linux.adb, s-taprop-dummy.adb, s-taprop-solaris.adb,
s-interr-vms.adb, s-osinte-vms.ads, s-taprop-vms.adb,
s-osinte-vxworks.ads, s-osprim-vxworks.adb, a-numaux-x86.adb,
a-except.adb, a-exexpr.adb, a-intsig.adb, a-tags.adb,
a-tags.ads, bindgen.ads, checks.adb, checks.adb,
csets.ads, einfo.ads, einfo.ads, elists.adb, exp_ch4.adb,
exp_ch7.adb, exp_dist.adb, exp_util.adb, freeze.adb,
g-dynhta.adb, gnatmem.adb, g-regexp.adb, inline.adb,
i-os2thr.ads, osint.adb, prj.adb, scng.adb, sem_cat.adb,
sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, sem_ch7.adb,
sem_ch8.adb, sem_disp.adb, sem_prag.adb, sem_res.adb,
sem_type.adb, sem_type.ads, sem_warn.adb, s-ficobl.ads,
s-finimp.adb, s-htable.adb, sinfo.ads, sinput-l.ads,
s-interr.adb, s-interr.ads, sprint.adb, s-tarest.adb,
s-tasini.ads, s-taskin.ads, s-taskin.ads, uname.adb,
vms_data.ads: Minor reformatting,
Fix bad box comment format.
* gnat_rm.texi: Fix minor grammatical error
* sem_attr.adb, exp_attr.adb: New attribute Has_Access_Values
* sem_util.ads, sem_util.adb (Requires_Transient_Scope): Allow many
more cases of discriminated records to be recognized as not needing a
secondary stack.
(Has_Access_Values): New function.
* snames.h, snames.adb, snames.ads: New attribute Has_Access_Values
* cstand.adb, layout.ads, layout.adb, sem_ch13.ads: Change name
Set_Prim_Alignment to Set_Elem_Alignment (more accurate correspondence
with LRM terminology).
Change terminology in comments primitive type => elementary type.
2004-07-06 Ed Schonberg <schonberg@gnat.com>
PR ada/15602
* sem_ch7.adb (Unit_Requires_Body): For a generic package, the formal
parameters do not impose any requirements on the presence of a body.
2004-07-06 Ed Schonberg <schonberg@gnat.com>
PR ada/15593
* sem_ch12.adb (Analyze_Package_Instantiation): If the generic is not a
compilation unit and is in an open scope at the point of instantiation,
assume that a body may be present later.
2004-07-06 Ed Schonberg <schonberg@gnat.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case 'Size):
Improve error message when specified size is not supported.
* sem_ch6.adb (Maybe_Primitive_Operation): A library-level subprogram
is never a primitive operation.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 47670 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-06-28 15:50 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-06-28 15:50 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3216 bytes --]
Tested on i686-linux using the pre ssa merge tag
--
2004-06-28 Robert Dewar <dewar@gnat.com>
* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb,
mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-solaris.adb,
mlib-tgt-vms-alpha.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb,
a-strmap.adb, a-strmap.ads, clean.adb: Minor reformatting
* exp_util.adb (Is_Possibly_Unaligned_Slice): Completely rewritten, to
deal with problem of inefficient slices on machines with strict
alignment, when the slice is a component of a composite.
* checks.adb (Apply_Array_Size_Check): Do not special case 64-bit
machines, we need the check there as well.
2004-06-28 Ed Schonberg <schonberg@gnat.com>
* exp_ch5.adb (Expand_Assign_Array): Use correct condition to
determine safe copying direction for overlapping slice assignments
when component is controlled.
* sem_ch12.adb (Instantiate_Formal_Package): Implicit operations of a
formal derived type in the actual for a formal package are visible in
the enclosing instance.
2004-06-28 Ed Schonberg <schonberg@gnat.com>
PR ada/15600
* sem_util.adb (Trace_Components): Diagnose properly an illegal
circularity involving a private type whose completion includes a
self-referential component.
(Enter_Name): Use Is_Inherited_Operation to distinguish a source
renaming or an instantiation from an implicit derived operation.
2004-06-28 Pascal Obry <obry@gnat.com>
* mlib-tgt-mingw.adb: (Library_Exists_For): Remove "lib" prefix from
DLL.
(Library_File_Name_For): Idem.
2004-06-28 Matthew Gingell <gingell@gnat.com>
* g-traceb.ads: Add explanatory note on the format of addresses
expected by addr2line.
2004-06-28 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: Force debugging information on s-tasdeb.adb,
a-except.adb and s-assert.adb needed by the debugger.
2004-06-28 Vincent Celier <celier@gnat.com>
* make.adb (Collect_Arguments_And_Compile): Change Flag1 to
Need_To_Build_Lib.
(Gnatmake): Ditto.
* mlib-prj.adb (Check_Library): Replace Flag1 with Need_To_Build_Lib
* prj.adb: Minor reformatting
(Project_Empty): Change Flag1 to Need_To_Build_Lib. Remove Flag2.
* prj.ads: Comment updates
Minor reformatting
(Project_Data): Change Flag1 to Need_To_Build_Lib.
Remove Flag2: not used.
* prj-dect.adb (Parse_Declarative_Items): Accept "null" as a
declaration.
* gnat_ugn.texi: Put a "null;" declaration in one project file example
* gnat_rm.texi: Document Empty declarations "null;".
* makegpr.adb (Compile_Link_With_Gnatmake): Put the global archives in
front of the linker options.
(Link_Foreign): Put the global archives and the libraries in front of
the linker options.
2004-06-28 Javier Miranda <miranda@gnat.com>
* rtsfind.adb: (Get_Unit_Name): Fix typo in comment
(RTU_Loaded): Code cleanup
(Set_RTU_Loaded): New procedure to register as *loaded* explicitly
withed predefined units.
* rtsfind.ads (Set_RTU_Loaded): New procedure to register as *loaded*
explicitly withed predefined units.
Fix typo in comment
* sem_ch10.adb (Analyze_Compilation_Unit): Register as *loaded*
explicitly withed predefined units.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 16655 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-06-25 18:29 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-06-25 18:29 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 14273 bytes --]
Tested on i686-linux using the pre ssa merge tag.
There were some ACATS failures in some of these changes, which explains
the unusual delay since last merge, to take the time to fix those regressions.
--
2004-06-25 Pascal Obry <obry@gnat.com>
* makegpr.adb (Build_Library): Remove parameter Lib_Address and
Relocatable from Build_Dynamic_Library call.
* gnat_ugn.texi: Change documentation about Library_Kind. Dynamic and
Relocatable are now synonym.
* Makefile.in: Use s-parame-mingw.adb on MingW platform.
* mlib-prj.adb (Build_Library): Remove DLL_Address constant definition.
Remove parameter Lib_Address and Relocatable from Build_Dynamic_Library
call.
* mlib-tgt.ads, mlib-tgt.adb (Build_Dynamic_Library): Remove parameter
Lib_Address and Relocatable.
(Default_DLL_Address): Removed.
* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb,
mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-vxworks.adb:
(Build_Dynamic_Library): Remove parameter Lib_Address and Relocatable.
(Default_DLL_Address): Removed.
* mlib-tgt-mingw.adb: Ditto.
(Build_Dynamic_Library): Do not add "lib" prefix to the DLL name.
* s-taprop-mingw.adb (Create_Task): Use Adjust_Storage_Size to compute
the initial thread stack size.
* a-strmap.ads: Move package L to private part as it is not used in
the spec. Found while reading code.
2004-06-25 Olivier Hainque <hainque@act-europe.fr>
* tracebak.c: Introduce support for a GCC infrastructure based
implementation of __gnat_backtrace.
* raise.c: Don't rely on a C mapping of the GNAT_GCC_Exception record
any more. Use accessors instead. This eases maintenance and relaxes
some alignment constraints.
(_GNAT_Exception structure): Remove the Ada specific fields
(EID_For, Adjust_N_Cleanups_For): New accessors, exported by
a-exexpr.adb.
(is_handled_by, __gnat_eh_personality): Replace component references to
exception structure by use of the new accessors.
* init.c (__gnat_initialize): Adjust comments to match the just
reverted meaning of the -static link-time option.
* adaint.c (convert_addresses): Arrange not to define a stub for
mips-irix any more, as we now want to rely on a real version from a
recent libaddr2line.
* a-exexpr.adb: Provide new accessors to a GNAT_GCC occurrence, so that
the personality routine can use them and not have to rely on a C
counterpart of the record anymore. This simplifies maintenance and
relaxes the constraint of having Standard'Maximum_Alignment match
BIGGEST_ALIGNMENT.
Update comments, and add a section on the common header alignment issue.
2004-06-25 Geert Bosch <bosch@gnat.com>
* a-ngelfu.adb (Tanh): Use full 20 digit precision for constants in
polynomial approximation. Fixes inconsistency with Cody/Waite algorithm.
2004-06-25 Robert Dewar <dewar@gnat.com>
* gnat_rm.texi: Fix section on component clauses to indicate that the
restriction on byte boundary placement still applies for bit packed
arrays.
Add comment on stack usage from Initialize_Scalars
* gnat_ugn.texi: Add documentation for -gnatyLnnn
* stylesw.ads, stylesw.adb: Implement new -gnatyLnnn option for
limiting nesting level.
* usage.adb: Add line for -gnatyLnnn switch
* g-debpoo.ads, xtreeprs.adb, sinput.ads, sem_ch13.ads,
sem_ch13.adb, exp_aggr.adb: Minor reformatting
* sem_prag.adb (Process_Atomic_Shared_Volatile): Set Is_Atomic on base
type as well as on the subtype. This corrects a problem in freeze in
setting alignments of atomic types.
* sem_eval.ads: Minor comment typo fixed
* par-util.adb (Push_Scope_Stack): Check for violation of max nesting
level. Minor reformatting.
* fname.adb (Is_Predefined_File_Name): Require a letter after the
minus sign. This means that file names like a--b.adb will not be
considered predefined.
* freeze.adb: Propagate new flag Must_Be_On_Byte_Boundary to containing
record Test new flag and give diagnostic for bad component clause.
(Freeze_Entity): Set alignment of array from component alignment in
cases where this is safe to do.
* exp_pakd.adb: Set new flag Must_Be_On_Byte_Boundary for large packed
arrays.
* cstand.adb: (Create_Standard): Set alignment of String to 1
* einfo.ads, einfo.adb: Introduce new flag Must_Be_On_Byte_Boundary
* exp_ch4.adb (Expand_Array_Equality): Improve efficiency of generated
code in the common constrained array cases.
* a-storio.adb: Change implementation to avoid possible alignment
problems on machines requiring strict alignment (data should be moved
as type Buffer, not type Elmt).
* checks.adb (Apply_Array_Size_Check): Improve these checks by
killing the overflow checks which we really do not need (64-bits is
enough).
2004-06-25 Vincent Celier <celier@gnat.com>
* makegpr.adb (Is_Included_In_Global_Archive): New Boolean function
(Add_Archives.Recursive_Add_Archives): Call Add_Archive_Path
inconditionally for the main project.
(Recursive_Add_Archives.Add_Archive_Path): New procedure
(Link_Executables.Check_Time_Stamps): New procedure
(Link_Executables.Link_Foreign): New procedure
Changes made to reduce nesting level of this package
(Check): New procedure
(Add_Switches): When not in quiet output, check that a switch is not
the concatenation of several valid switches. If it is, issue a warning.
(Build_Global_Archive): If the global archive is rebuilt, linking need
to be done.
(Compile_Sources): Rebuilding a library archive does not imply
rebuilding the global archive.
(Build_Global_Archive): New procedure
(Build_Library): New name for Build_Archive, now only for library
project
(Check_Archive_Builder): New procedure
(Create_Global_Archive_Dependency_File): New procedure
(Gprmake): Call Build_Global_Archive before linking
* makegpr.adb: Use Other_Sources_Present instead of Sources_Present
throughout.
(Scan_Arg): Display the Copyright notice when -v is used
* gnat_ugn.texi: Document new switch -files= (VMS qualifier /FILES=)
for gnatls.
* vms_data.ads: Add qualifier /MAX_NESTING=nnn (-gnatyLnnn) for GNAT
COMPILE.
Add new GNAT LIST qualifier /FILES=
Added qualifier /DIRECTORY= to GNAT METRIC
Added qualifier /FILES= to GNAT METRIC
Added qualifier /FILES to GNAT PRETTY
* switch.adb (Is_Front_End_Switch): Refine the test for --RTS or -fRTS,
to take into account both versions of the switch.
* switch-c.adb (Scan_Front_End_Switches): New switch -gnatez. Should
always be the last switch to the gcc driver. Disable switch storing so
that switches automatically added by the gcc driver are not put in the
ALI file.
* prj.adb (Project_Empty): Take into account changes in components of
Project_Data.
* prj.ads (Languages_Processed): New enumaration value All_Languages.
* prj.ads (Project_Data): Remove component Lib_Elaboration: never
used. Split Boolean component Ada_Sources_Present in two Boolean
components Ada_Sources_Present and Other_Sources_Present.
Minor reformatting
* prj-env.adb (For_All_Source_Dirs.Add): Use Ada_Sources_Present
instead of Sources_Present.
(Set_Ada_Paths.Add.Recursive_Add): Ditto
* prj-nmsc.adb: Minor reformatting
(Check_Ada_Naming_Scheme): New name of procedure Check_Naming_Scheme
(Check_Ada_Naming_Scheme_Validity): New name of previous procedure
Check_Ada_Naming_Scheme.
Change Sources_Present to Ada_Sources_Present or Other_Sources_Present
throughout.
* prj-part.adb (Post_Parse_Context_Clause): New Boolean parameter
In_Limited.
Make sure that all cycles where there is at least one "limited with"
are detected.
(Parse_Single_Project): New Boolean parameter In_Limited
* prj-proc.adb (Recursive_Check): When Process_Languages is
All_Languages, call first Prj.Nmsc.Ada_Check, then
Prj.Nmsc.Other_Languages_Check.
* prj-proc.adb (Process): Use Ada_Sources_Present or
Other_Sources_Present (instead of Sources_Present) depending on
Process_Languages.
* lang-specs.h: Keep -g and -m switches in the same order, and as the
last switches.
* lib.adb (Switch_Storing_Enabled): New global Boolean flag
(Disable_Switch_Storing): New procedure. Set Switch_Storing_Enabled to
False.
(Store_Compilation_Switch): Do nothing if Switch_Storing_Enabled is
False.
* lib.ads (Disable_Switch_Storing): New procedure.
* make.adb: Modifications to reduce nesting level of this package.
(Check_Standard_Library): New procedure
(Gnatmake.Check_Mains): New procedure
(Gnatmake.Create_Binder_Mapping_File): New procedure
(Compile_Sources.Compile): Add switch -gnatez as the last option
(Display): Never display -gnatez
* Makefile.generic:
When using $(MAIN_OBJECT), always use $(OBJ_DIR)/$(MAIN_OBJECT)
* gnatcmd.adb (Check_Project): New function
(Process_Link): New procedure to reduce nesting depth
(Check_Files): New procedure to reduce the nesting depth.
For GNAT METRIC, include the inherited sources in extending projects.
(GNATCmd): When GNAT LS is invoked with a project file and no files,
add the list of files from the sources of the project file. If this list
is too long, put it in a temp text files and use switch -files=
(Delete_Temp_Config_Files): Delete the temp text file that contains
a list of source for gnatpp or gnatmetric, if one has been created.
(GNATCmd): For GNAT METRIC and GNAT PRETTY, if the number of sources
in the project file is too large, create a temporary text file that
list them and pass it to the tool with "-files=<temp text file>".
(GNATCmd): For GNAT METRIC add "-d=<abject dir>" as the first switch
* gnatlink.adb (Gnatlink): Do not compile with --RTS= when the
generated file is in not in Ada.
* gnatls.adb: Remove all parameters And_Save that are no longer used.
(Scan_Ls_Arg): Add processing for -files=
(Usage): Add line for -files=
* g-os_lib.adb (On_Windows): New global constant Boolean flag
(Normalize_Pathname): When on Windows and the path starts with a
directory separator, make sure that the resulting path will start with
a drive letter.
* clean.adb (Clean_Archive): New procedure
(Clean_Project): When there is non-Ada code, delete the global archive,
the archive dependency files, the object files and their dependency
files, if they exist.
(Gnatclean): Call Prj.Pars.Parse for All_Languages, not for Ada only.
2004-06-25 Thomas Quinot <quinot@act-europe.fr>
* sinfo.ads: Fix typo in comment.
* sem_dist.adb (Process_Remote_AST_Attribute): Simplify code that uses
the TSS for remote access-to-subprogram types, since these TSS are
always present once the type has been analyzed.
(RAS_E_Dereference): Same.
* sem_attr.adb (Analyze_Attribute): When analysis of an attribute
reference raises Bad_Attribute, mark the reference as analyzed so the
node (and any children resulting from rewrites that could have occurred
during the analysis that ultimately failed) is not analyzed again.
* exp_ch7.ads (Find_Final_List): Fix misaligned comment.
* exp_dist.adb: Minor comment fix.
* exp_ch4.adb (Expand_N_Allocator): For an allocator whose expected
type is an anonymous access type, no unchecked deallocation of the
allocated object can occur. If the object is controlled, attach it with
a count of 1. This allows attachment to the Global_Final_List, if
no other relevant list is available.
(Get_Allocator_Final_List): For an anonymous access type that is
the type of a discriminant or record component, the corresponding
finalisation list is the one of the scope of the type.
2004-06-25 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Replace_Type): When computing the signature of an
inherited subprogram, use the first subtype if the derived type
declaration has no constraint.
* exp_ch6.adb (Add_Call_By_Copy_Code): Check that formal is an array
before applying previous optimization. Minor code cleanup.
* exp_util.adb (Is_Possibly_Unaligned_Slice): If the component is
placed at the beginning of an unpacked record without explicit
alignment, a slice of it will be aligned and does not need a copy when
used as an actual.
2004-06-25 Ed Schonberg <schonberg@gnat.com>
PR ada/15591
PR ada/15592
* sem_ch8.adb (Attribute_Renaming): Reject renaming if the attribute
reference is written with expressions mimicking parameters.
2004-06-25 Hristian Kirtchev <kirtchev@gnat.com>
PR ada/15589
* sem_ch3.adb (Build_Derived_Record_Type): Add additional check to
STEP 2a. The constraints of a full type declaration of a derived record
type are checked for conformance with those declared in the
corresponding private extension declaration. The message
"not conformant with previous declaration" is emitted if an error is
detected.
2004-06-25 Vasiliy Fofanov <fofanov@act-europe.fr>
* g-traceb.ads: Document the need for -E binder switch in the spec.
* g-trasym.ads: Document the need for -E binder switch in the spec.
2004-06-25 Jose Ruiz <ruiz@act-europe.fr>
* sem_prag.adb: Add handling of pragma Detect_Blocking.
* snames.h, snames.ads, snames.adb: Add entry for pragma
Detect_Blocking.
* s-rident.ads: Change reference to pragma Detect_Blocking.
* targparm.ads, targparm.adb: Allow pragma Detect_Blocking in
system.ads.
* opt.ads (Detect_Blocking): New Boolean variable (defaulted to False)
to indicate whether pragma Detect_Blocking is active.
* par-prag.adb: Add entry for pragma Detect_Blocking.
* rtsfind.adb (RTU_Loaded): Fix the temporary kludge to get past bug
of not handling WITH.
Note that this replaces the previous update which was incorrect.
2004-06-25 Javier Miranda <miranda@gnat.com>
* sem_ch10.adb (Re_Install_Use_Clauses): Force the installation of the
use-clauses to have a clean environment.
* sem_ch8.adb (Install_Use_Clauses): Addition of a new formal to force
the installation of the use-clauses to stablish a clean environment in
case of compilation of a separate unit; otherwise the call to
use_one_package is protected by the barrier Applicable_Use.
* sem_ch8.ads (Install_Use_Clauses): Addition of a new formal to force
the installation of the use-clauses to stablish a clean environment in
case of compilation of a separate unit.
(End_Use_Clauses): Minor comment cleanup.
2004-06-25 Sergey Rybin <rybin@act-europe.fr>
* gnat_ugn.texi: Add description of the gnatpp 'files' switch
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 93775 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-06-14 14:16 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-06-14 14:16 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2967 bytes --]
Tested on x86-linux using the pre ssa merge tag.
--
2004-06-14 Pascal Obry <obry@gnat.com>
* gnat_ugn.texi: Document relocatable vs. dynamic Library_Kind on
Windows. Fix minor typo.
* mlib-tgt-mingw.adb: New implementation using the GCC -shared option
which is now supported on Windows. With this implementation using the
Library Project feature is no different on Windows than on UNIX.
2004-06-14 Vincent Celier <celier@gnat.com>
* makegpr.adb (Compile_Sources): Nothing to do when there are no
non-Ada sources.
* mlib-tgt-vxworks.adb (Library_Exists_For): Remove incorrect comment
* prj-part.adb (Parse_Single_Project): When a duplicate project name is
found, show the project name and the path of the previously parsed
project file.
2004-06-14 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Add_Call_By_Copy_Code): For an out-parameter that is an
array, avoid copying the actual before the call.
2004-06-14 Thomas Quinot <quinot@act-europe.fr>
* g-debpoo.adb: Remove alignment assumptions from GNAT.Debug_Pools.
Instead, allocate memory on worst-case alignment assumptions, and then
return an aligned address within the allocated zone.
2004-06-14 Robert Dewar <dewar@gnat.com>
* bindgen.adb (Gen_Adainit_Ada): Do not generate external references to
elab entities in predefined units in No_Run_Time_Mode.
(Gen_Adainit_C): Same fix
(Gen_Elab_Calls_Ada): Do not generate calls to elaborate predefined
units in No_Run_Time_Mode
(Gen_Elab_Calls_C): Same fix
* symbols-vms-alpha.adb: Minor reformatting
* g-debpoo.ads: Minor reformatting
* lib.adb (In_Same_Extended_Unit): Version working on node id's
* lib.ads (In_Same_Extended_Unit): Version working on node id's
* lib-xref.adb: Minor cleanup, use new version of In_Same_Extended_Unit
working on nodes.
* make.adb: Minor reformatting
* par-ch12.adb: Minor reformatting
* par-prag.adb: Add dummy entry for pragma Profile_Warnings
* prj-strt.adb: Minor reformatting
* restrict.ads, restrict.adb: Redo handling of profile restrictions to
be more general.
* sem_attr.adb: Minor reformatting
* sem_ch7.adb: Minor reformatting
* sem_elab.adb (Check_A_Call): Deal with problem of calling init proc
for type in the same unit as the object declaration.
* sem_prag.adb (Check_Arg_Is_External_Name): New procedure, allows
static string expressions and not just string literals.
Minor reformatting
(Set_Warning): Reset restriction warning flag for restriction pragma
Implement pragma Profile_Warnings
Implement pragma Profile (Restricted)
Give obolescent messages for old restrictions and pragmas
* snames.h, snames.ads, snames.adb: Add new entry for pragma
Profile_Warnings.
* s-rident.ads: Add declarations for restrictions required by profile
Restricted and profile Ravenscar.
* targparm.ads, targparm.adb: Allow pragma Profile in system.ads
* gnat_ugn.texi: Correct some missing entries in the list of GNAT
configuration pragmas.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 28658 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-06-11 13:38 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-06-11 13:38 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 7070 bytes --]
Tested on x86-linux using the pre ssa merge tag.
--
2004-06-11 Vincent Celier <celier@gnat.com>
* mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to
gnatsym, when symbol policy is Restricted.
* mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to
gnatsym, when symbol policy is Restricted.
* symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted,
read the symbol file.
(Finalize): Fail in symbol policy Restricted if a symbol in the original
symbol file is not in the object files. Do not create a new symbol file
when symbol policy is Restricted.
* gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used
in Scng.
* gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy
Restricted.
(Usage): Line for new switch -R
* make.adb (Initialize): When the platform is not VMS, add the
directory where gnatmake is invoked in the front of the path, if
gnatmake is invoked with directory information. Change the Scan_Args
while loop to a for loop.
(Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency:
if Depth is equal or greater than the proposed depth, there is nothing
to do.
(Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1
instead of 0.
* prj.ads: Add new symbol policy Restricted.
* prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction
with the new parameters Check_All_Labels and Case_Location.
* prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted
(Library_Symbol_File needs to be defined).
* prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels
and Case_Location If Check_All_Labels is True, check that all values of
the string type are used, and output warning(s) if they are not.
* prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels
and Case_Location.
* gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc"
* gnat_ugn.texi: Update documentation about the library directory in
Library Projects.
* makegpr.adb (Display_Command): In verbose mode, also display the
value of the CPATH env var, when the compiler is gcc.
(Initialize): Change the Scan_Args while loop to a for loop
(Compile_Individual_Sources): Change directory to object directory
before compilations.
* symbols.ads: New symbol policy Restricted.
2004-06-11 Olivier Hainque <hainque@act-europe.fr>
* a-except.adb (Raise_After_Setup family): Remove. The responsibility
is now taken care of internally in the Exception_Propagation package
and does not require clients assistance any more.
* a-exexpr.adb (Is_Setup_And_Not_Propagated,
Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New
functions. Helpers to maintain a predicate required in the handling of
occurrence transfer between tasks.
This is now handled internally and does not require clients assistance
for the setup/propagate separation anymore.
(Setup_Exception, Propagate_Exception): Simplify the Private_Data
allocation strategy, handle the Setup_And_Not_Propagated predicate and
document.
* s-taenca.adb (Check_Exception): Use raise_with_msg instead of
raise_after_setup, now that everything is handled internally within the
setup/propagation engine.
2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
* exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once.
Add additional conditions for the case of an actual being a simple
name or literal. Improve inlining by preventing the generation
of temporaries with a short lifetime (one use).
2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
PR ada/15587
* einfo.ads: Minor comment updates for Has_Completion and
E_Constant list of flags.
* sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations
and constant redeclarations now set the Has_Completion flag of their
defining identifiers.
* sem_ch7.adb (Analyze_Package_Spec): Add procedure
Inspect_Deferred_Constant_Completion.
Used to detect private deferred constants that have not been completed
either by a constant redeclaration or pragma Import. Emits error message
"constant declaration requires initialization expression".
* sem_prag.adb (Process_Import_Or_Interface): An Import pragma now
completes a deferred constant.
2004-06-11 Geert Bosch <bosch@gnat.com>
* eval_fat.adb (Decompose_Int): Fix rounding of negative numbers.
* s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in
calculating exponent for scaling denormal numbers.
(Leading_Part): Properly raise Constraint_Error for zero or negative
Adjustment.
(Remainder): Properly raise Constraint_Error for zero divisor.
2004-06-11 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb: Minor reformatting.
* exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit
dereference when accessing the entry parameter record.
(Check_Array_Type): Always check for possible implicit dereference.
(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
Abort if a pointer is still present (denoting that an implicit
dereference was left in the tree by the front-end).
* sem_attr.adb (Expand_Entry_Parameter): Generate an explicit
dereference when accessing the entry parameter record.
(Check_Array_Type): Always check for possible implicit dereference.
(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
Abort if a pointer is still present (denoting that an implicit
dereference was left in the tree by the front-end).
2004-06-11 Emmanuel Briot <briot@act-europe.fr>
* g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error
message, like the compiler itself does. Easier to parse the output.
* g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments.
* gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should
be base names, and not includes directories.
2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES),
so that dependencies are properly taken into account by make.
2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
PR ada/15622
* s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads,
exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic
2004-06-11 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (install-gnatlib): install target-specific run-time files.
* Make-lang.in: Remove obsolete targets.
2004-06-11 Ed Schonberg <schonberg@gnat.com>
* par-ch12.adb (P_Generic): Add scope before analyzing subprogram
specification, to catch misuses of program unit names.
* sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on
superfluous conversions in an instance.
2004-06-11 Ed Schonberg <schonberg@gnat.com>
PR ada/15403
* sem_ch12.adb (Save_References): If operator node has been folded to
enumeration literal, associated_node must be discarded.
2004-06-11 Jose Ruiz <ruiz@act-europe.fr>
* s-stchop-vxworks.adb: Add required pragma Convention to
Task_Descriptor because it is updated by a C function.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 18208 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-06-07 16:21 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-06-07 16:21 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 7879 bytes --]
Tested on x86-linux use the pre-ssa-merge tag.
--
2004-06-07 Robert Dewar <dewar@gnat.com>
* a-direct.ads, einfo.ads: Minor comment updates
* s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb,
s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb,
s-taprop-dummy.adb, s-taprop-os2.adb, s-taprop-solaris.adb,
s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb,
s-taprop-posix.adb, s-taprop.ads, exp_dbug.adb: Minor reformatting.
* s-interr-sigaction.adb: Remove unreferenced variable
(Attached_Interrupts). Minor reformatting.
Avoid use of variable I (replace by J).
* par-ch10.adb: Fix text of one error message
* checks.adb, checks.ads, cstand.adb, vms_data.ads, errout.ads,
exp_aggr.adb, exp_ch3.adb, exp_ch3.ads, exp_ch5.adb, exp_ch6.adb,
exp_ch9.adb, exp_code.adb, gnat1drv.adb, lib-load.adb, lib-writ.adb,
opt.adb, par.adb, opt.ads, par-ch11.adb, par-ch3.adb, par-ch4.adb,
par-ch5.adb, par-ch6.adb, par-ch8.adb, par-ch9.adb, par-prag.adb,
par-util.adb, scng.adb, sem_aggr.adb, sem_attr.adb, sem_cat.adb,
sem_ch10.adb, sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, sem_ch2.adb,
sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb,
sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, sem_eval.adb, sem_prag.adb,
sem_res.adb, sem_type.adb, sem_util.adb, sinfo.ads, snames.adb,
snames.ads, snames.h, sprint.adb, switch-c.adb: Modifications for Ada
2005 support.
2004-06-07 Doug Rupp <rupp@gnat.com>
* mlib-tgt-vms.adb: Rename mlib-tgt-vms.adb mlib-tgt-vms-alpha.adb
* s-vaflop-vms.adb: Rename s-vaflop-vms.adb to s-vaflop-vms-alpha.adb
* mlib-tgt-vms-ia64.adb: New file.
* Makefile.in: Rename mlib-tgt-vms.adb to mlib-tgt-vms-alpha.adb
Add mlib-tgt-vms-ia64.adb
Rename s-vaflop-vms.adb to s-vaflop-vms-alpha.adb.
Move to alpha specific ifeq section.
Add VMS specific versions of symbols.adb
Renaming of 5q vms files.
* 5qsystem.ads renamed to system-vms_64.ads.
2004-06-07 Vincent Celier <celier@gnat.com>
* a-calend.ads: Add a GNAT Note comment after function Time_Of to
explain that when a time of day corresponding to the non existing hour
on the day switching to DST is specified, Split may return a different
value for Seconds.
* gnatcmd.adb: Add processing of GNAT METRIC (for gnatmetric), similar
to GNAT PRETTY.
* g-os_lib.adb (OpenVMS): New Boolean value imported from System.
(Normalize_Pathname): Only resolve VMS logical names when on VMS.
* mlib-prj.adb (Build_Library): New flag Gtrasymobj_Needed, initialize
to False.
If Gtrasymobj_Needed is True, add the full path of g-trasym.obj to
the linking options.
(Build_Library.Check_Libs): On VMS, if there is a dependency on
g-trasym.ads, set Gtrasymobj_Needed to True.
* prj-attr.adb: Add new package Metrics for gnatmetric
* prj-nmsc.adb (Record_Other_Sources): Put source file names in
canonical case to take into account files with upper case characters on
Windows.
(Ada_Check): Load the reference symbol file name in the name buffer to
check it, not the symbol file name.
* snames.ads, snames.adb: Add standard name Metrics (name of project
file package for gnatmetric).
* vms_conv.ads: Add Metric to Comment_Type
* vms_conv.adb (Initialize): Add component dor Metric in Command_List
* vms_data.ads: Add qualifiers for GNAT METRIC
* makegpr.adb (Link_Executables): Take into account the switches
specified in package Linker of the main project.
2004-06-07 Thomas Quinot <quinot@act-europe.fr>
* bindgen.adb (Set_Unit_Number): Units is an instance of Table, and so
the index of the last element is Units.Last, not Units.Table'Last
(which is usually not a valid index within the actually allocated
storage for the table).
* exp_ch4.adb (Insert_Dereference_Action): Change predicate that
determines whether to generate a call to a checked storage pool
Dereference action.
Generate such a call only for a dereference that either comes from
source, or is the result of rewriting a dereference that comes from
source.
2004-06-07 Romain Berrendonner <berrendo@act-europe.fr>
* bindgen.adb (Gen_Output_File): Add support for GAP builds.
2004-06-07 Eric Botcazou <ebotcazou@act-europe.fr>
(gnat_to_gnu_entity) <E_Array_Subtype>: For multi-dimensional arrays at
file level, elaborate the stride for inner dimensions in alignment
units, not bytes.
* exp_ch5.adb: Correct wrong reference to Component_May_Be_Bit_Aligned
in a comment.
2004-06-07 Javier Miranda <miranda@gnat.com>
* exp_ch6.adb: Correct wrong modification in previous patch
2004-06-07 Vasiliy Fofanov <fofanov@act-europe.fr>
* g-trasym.ads: Corrected comment to properly reflect level of support
on VMS.
2004-06-07 Hristian Kirtchev <kirtchev@gnat.com>
* lib-xref.adb (Generate_Reference): Add nested function Is_On_LHS. It
includes case of a variable referenced on the left hand side of an
assignment, therefore remove redundant code. Variables and prefixes of
indexed or selected components are now marked as referenced on left
hand side. Warnings are now properly emitted when variables or prefixes
are assigned but not read.
* sem_warn.adb (Output_Unreferenced_Messages): Add additional checks to
left hand side referenced variables. Private access types do not
produce the warning "variable ... is assigned but never read".
Add also additional checks to left hand side referenced variables.
Aliased, renamed objects and access types do not produce the warning
"variable ... is assigned but never read" since other entities may read
the memory location.
2004-06-07 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: In the powerpc/vxworks-specific section, restore
EXTRA_GNATRTL_NONTASKING_OBJS and EXTRA_GNATRTL_TASKING_OBJS (removed
by mistake).
2004-06-07 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Refine the removal of
predefined operators.
Removes spurious type errors from g-trasym-vms.adb.
* sem_res.adb (Rewrite_Renamed_Operator): If intrinsic operator is
distinct from the operator appearing in the source, call appropriate
routine to insert conversions when needed, and complete resolution of
node.
(Resolve_Intrinsic_Operator): Fix cut-and-paste bug on transfer of
interpretations for rewritten right operand.
(Set_Mixed_Mode_Operand): Handle properly a universal real operand when
the other operand is overloaded and the context is a type conversion.
2004-06-07 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* ada-tree.def (BLOCK_STMT): Now has two operands.
(BREAK_STMT): New.
* ada-tree.h: (BLOCK_STMT_BLOCK): New macro.
* gigi.h: (gnat_poplevel): Now returns a tree.
* trans.c (end_block_stmt): Add arg; all callers changed.
(tree_transform, case N_Case_Statement): Make a BLOCK_STMT for a WHEN.
(start_block_stmt): Clear BLOCK_STMT_BLOCK.
(add_stmt): Set TREE_TYPE.
(gnat_expand_stmt, case BLOCK_STMT): Handle BLOCK_STMT_BLOCK.
(gnat_expand_stmt, case BREAK_STMT): New case.
* utils.c (gnat_poplevel): Return a BLOCK, if we made one.
2004-06-07 Jose Ruiz <ruiz@act-europe.fr>
* s-stchop.adsm s-stchop.adb, s-stchop-vxworks.adb: Remove the
procedure Set_Stack_Size that is not needed.
2004-06-07 Sergey Rybin <rybin@act-europe.fr>
* gnat_ugn.texi: Clarify the case when non-standard naming scheme is
used for gnatpp input file and for the files upon which it depends
2004-06-07 Ben Brosgol <brosgol@gnat.com>
* gnat_ugn.texi: Wordsmithing of "GNAT and Libraries" chapter
2004-06-07 Arnaud Charlet <charlet@act-europe.fr>
* gnatvsn.ads: Bump version numbers appropriately.
Add new build type.
2004-06-07 Pascal Obry <obry@gnat.com>
* gnat_ugn.texi: Improve comments about imported names and link names
on Windows. Add a note about the requirement to use -k gnatdll's option
when working with a DLL which has stripped stdcall symbols (no @nn
suffix).
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 74342 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-27 18:16 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-27 18:16 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3617 bytes --]
Tested on x86-linux using the pre ssa merge tag.
--
2004-05-27 Vincent Celier <celier@gnat.com>
* vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and
COMMENTS_LAYOUT=UNTOUCHED
* symbols-vms.adb, symbols-vms-alpha.adb: Renamed symbols-vms.adb to
symbols-vms-alpha.adb
2004-05-27 Thomas Quinot <quinot@act-europe.fr>
* sem.ads: Clarify documentation on checks suppression.
* einfo.ads (Is_Known_Non_Null): Minor comment typo fix and rephrasing.
2004-05-27 Ed Schonberg <schonberg@gnat.com>
* sem_util.adb (Is_Descendent_Of): Examine properly all ancestors in
the case of multiple derivations.
(Is_Object_Reference): For a selected component, verify that the prefix
is itself an object and not a value.
* sem_ch12.adb (Same_Instantiated_Constant): New name for
Same_Instantiated_Entity.
(Same_Instantiated_Variable): Subsidiary to
Check_Formal_Package_Instance, to recognize actuals for in-out generic
formals that are obtained from a previous formal package.
(Instantiate_Subprogram_Body): Emit proper error when
generating code and the proper body of a stub is missing.
* sem_ch4.adb (Remove_Address_Interpretations): If the operation still
has a universal interpretation, do the disambiguation here.
* exp_ch4.adb (Expand_N_Type_Conversion,
Expand_N_Unchecked_Type_Conversion): Special handling when target type
is Address, to avoid typing anomalies when Address is a visible integer
type.
* exp_ch6.adb (Expand_N_Subprogram_Body): Use Is_Descendent_Of_Address
to determine whether a subprogram should not be marked Pure, even when
declared in a pure package.
2004-05-27 Jose Ruiz <ruiz@act-europe.fr>
* gnat_ugn.texi: Replace pragma Ravenscar by pragma Profile.
* gnat_rm.texi: Replace Max_Entry_Queue_Depth by Max_Entry_Queue_Length
Document No_Dynamic_Attachment, that supersedes No_Dynamic_Interrupts.
Update the documentation about the Ravenscar profile, following the
definition found in AI-249.
* sem_prag.adb: Use FIFO_Within_Priorities and Ceiling_Locking when
setting the Profile (Ravenscar). This must be done in addition to
setting the required restrictions.
* rtsfind.ads: Add the set of operations defined in package
Ada.Interrupts.
* exp_ch6.adb: Check whether we are violating the No_Dynamic_Attachment
restriction.
2004-05-27 Eric Botcazou <ebotcazou@act-europe.fr>
lang-specs.h: Always require -c or -S and always redirect to /dev/null
if -gnatc or -gnats is passed.
2004-05-27 Hristian Kirtchev <kirtchev@gnat.com>
* sem_prag.adb (Sig_Flags): A Pragma_Unchecked_Union does not count as
a significant reference. Warnings are now properly emitted when a
discriminated type is not referenced.
* lib-xref.adb (Generate_Reference): A deferred constant completion,
record representation clause or record type discriminant does not
produce a reference to its corresponding entity. Warnings are now
properly emitted when deferred constants and record types are not
referenced.
2004-05-27 Geert Bosch <bosch@gnat.com>
* Makefile.in: Use long version of libm routines on ia64 gnu/linux.
Fixes ACATS Annex G tests.
2004-05-27 Robert Dewar <dewar@gnat.com>
* rtsfind.adb (RTU_Loaded): Temporary kludge to get past bug of not
handling WITH
2004-05-27 Arnaud Charlet <charlet@act-europe.fr>
* s-interr.adb (Server_Task): Take into account case of early return
from sigwait under e.g. linux.
2004-05-27 Sergey Rybin <rybin@act-europe.fr>
* gnat_ugn.texi: Add description for the new gnatpp options:
-rnb - replace the original source without creating its backup copy
-c0 - do not format comments
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 14916 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-24 17:31 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-24 17:31 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3667 bytes --]
Tested on x86-linux using the pre ssa merge tag
--
2004-05-24 Geert Bosch <bosch@gnat.com>
* a-numaux-x86.adb (Reduce): Reimplement using an approximation of Pi
with 192 bits of precision, sufficient to reduce a double-extended
arguments X with a maximum relative error of T'Machine_Epsilon, for X
in -2.0**32 .. 2.0**32.
(Cos, Sin): Always reduce arguments of 1/4 Pi or larger, to prevent
reduction by the processor, which only uses a 68-bit approximation of
Pi.
(Tan): Always reduce arguments and compute function either using
the processor's fptan instruction, or by dividing sin and cos as needed.
2004-05-24 Doug Rupp <rupp@gnat.com>
* adaint.c (__gnat_readdir): Cast CRTL function retun value to avoid
gcc error on 32/64 bit VMS.
2004-05-24 Olivier Hainque <hainque@act-europe.fr>
* init.c (__gnat_error_handler): Handle EEXIST as EACCES for SIGSEGVs,
since this is what we get for stack overflows although not documented
as such.
Document the issues which may require adjustments to our signal
handlers.
2004-05-24 Ed Schonberg <schonberg@gnat.com>
* inline.adb (Add_Scope_To_Clean): Do not add cleanup actions to the
enclosing dynamic scope if the instantiation is within a generic unit.
2004-05-24 Arnaud Charlet <charlet@act-europe.fr>
* exp_dbug.ads: Fix typo.
* Makefile.in: s-osinte-linux-ia64.ads was misnamed.
Rename it to its proper name: system-linux-ia64.ads
(stamp-gnatlib1): Remove extra target specific run time files when
setting up the rts directory.
2004-05-24 Javier Miranda <miranda@gnat.com>
* einfo.ads, einfo.adb (Limited_Views): Removed.
(Limited_View): New attribute that replaces the previous one. It is
now a bona fide package with the limited-view list through the
first_entity and first_private attributes.
* sem_ch10.adb (Install_Private_With_Clauses): Give support to
limited-private-with clause.
(Install_Limited_Withed_Unit): Install the private declarations of a
limited-private-withed package. Update the installation of the shadow
entities according to the new structure (see Build_Limited_Views)
(Build_Limited_Views): Replace the previous implementation of the
limited view by a package entity that references the first shadow
entity plus the first shadow private entity (required for limited-
private-with clause)
(New_Internal_Shadow_Entity): Code cleanup.
(Remove_Limited_With_Clause): Update the implementation to undo the
new work carried out by Build_Limited_Views.
(Build_Chain): Complete documentation.
Replace Ada0Y by Ada 0Y in comments
Minor reformating
* sem_ch3.adb (Array_Type_Declaration): In case of anonymous access
types the level of accessibility depends on the enclosing type
declaration.
* sem_ch8.adb (Find_Expanded_Name): Fix condition to detect shadow
entities. Complete documentation of previous change.
2004-05-24 Robert Dewar <dewar@gnat.com>
* namet.adb: Minor reformatting
Avoid use of name I (replace by J)
Minor code restructuring
* sem_ch6.adb: Minor reformatting
* lib-writ.adb: Do not set restriction as active if this is a
Restriction_Warning case.
* sem_prag.adb: Reset restriction warning flag if real pragma
restriction encountered.
* s-htable.adb: Minor reformatting
Change rotate count to 3 in Hash (improves hash for small strings)
* 5qsystem.ads: Add comments for type Address (no literals allowed).
* gnat_ugn.texi: Add new section of documentation "Code Generation
Control", which describes the use of -m switches.
2004-05-24 Eric Botcazou <ebotcazou@act-europe.fr>
(tree_transform) <N_Identifier>: Do the dereference directly through
the DECL_INITIAL for renamed variables.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 17379 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-19 16:00 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-19 16:00 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux using the pre ssa merge tag.
--
2004-05-19 Joel Brobecker <brobecker@gnat.com>
* exp_dbug.ads: Correct comments concerning handling of overloading,
since we no longer use $ anymore.
2004-05-19 Sergey Rybin <rybin@act-europe.fr>
* sem_ch10.adb (Optional_Subunit): When loading a subunit, do not
ignore errors if ASIS_Mode is set. This prevents creating ASIS trees
with illegal subunits.
2004-05-19 Ed Schonberg <schonberg@gnat.com>
* sem_ch6.adb (Check_Following_Pragma): When compiling a subprogram
body with front-end inlining enabled, check whether an inline pragma
appears immediately after the body and applies to it.
* sem_prag.adb (Cannot_Inline): Emit warning if front-end inlining is
enabled and the pragma appears after the body of the subprogram.
--
Index: exp_dbug.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dbug.ads,v
retrieving revision 1.7
diff -u -p -r1.7 exp_dbug.ads
--- exp_dbug.ads 23 Oct 2003 11:57:52 -0000 1.7
+++ exp_dbug.ads 19 May 2004 10:47:02 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -99,23 +99,19 @@ package Exp_Dbug is
-- subprograms, since overloading can legitimately result in a
-- case of two entities with exactly the same fully qualified names.
-- To distinguish between entries in a set of overloaded subprograms,
- -- the encoded names are serialized by adding one of the suffixes:
+ -- the encoded names are serialized by adding the suffix:
- -- $n (dollar sign)
-- __nn (two underscores)
-- where nn is a serial number (2 for the second overloaded function,
- -- 2 for the third, etc.). We use $ if this symbol is allowed, and
- -- double underscore if it is not. In the remaining examples in this
- -- section, we use a $ sign, but the $ is replaced by __ throughout
- -- these examples if $ sign is not available. A suffix of $1 is
- -- always omitted (i.e. no suffix implies the first instance).
+ -- 2 for the third, etc.). A suffix of __1 is always omitted (i.e. no
+ -- suffix implies the first instance).
-- These names are prefixed by the normal full qualification. So
-- for example, the third instance of the subprogram qrs in package
-- yz would have the name:
- -- yz__qrs$3
+ -- yz__qrs__3
-- A more subtle case arises with entities declared within overloaded
-- subprograms. If we have two overloaded subprograms, and both declare
@@ -128,7 +124,7 @@ package Exp_Dbug is
-- we are talking about. For this purpose, we use a more complex suffix
-- which has the form:
- -- $nn_nn_nn ...
+ -- __nn_nn_nn ...
-- where the nn values are the homonym numbers as needed for any of
-- the qualifying entities, separated by a single underscore. If all
@@ -141,13 +137,13 @@ package Exp_Dbug is
-- procedure Tuv is ... end; -- Name is yz__qrs__tuv
-- begin ... end Qrs;
- -- procedure Qrs (X: Int) is -- Name is yz__qrs$2
- -- procedure Tuv is ... end; -- Name is yz__qrs__tuv$2_1
- -- procedure Tuv (X: Int) is -- Name is yz__qrs__tuv$2_2
+ -- procedure Qrs (X: Int) is -- Name is yz__qrs__2
+ -- procedure Tuv is ... end; -- Name is yz__qrs__tuv__2_1
+ -- procedure Tuv (X: Int) is -- Name is yz__qrs__tuv__2_2
-- begin ... end Tuv;
- -- procedure Tuv (X: Float) is -- Name is yz__qrs__tuv$2_3
- -- type m is new float; -- Name is yz__qrs__tuv__m$2_3
+ -- procedure Tuv (X: Float) is -- Name is yz__qrs__tuv__2_3
+ -- type m is new float; -- Name is yz__qrs__tuv__m__2_3
-- begin ... end Tuv;
-- begin ... end Qrs;
-- end Yz;
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.22
diff -u -p -r1.22 sem_ch10.adb
--- sem_ch10.adb 17 May 2004 13:20:44 -0000 1.22
+++ sem_ch10.adb 19 May 2004 10:47:03 -0000
@@ -948,14 +948,20 @@ package body Sem_Ch10 is
-- Errout to ignore all errors. Note that Fatal_Error will still
-- be set, so we will be able to check for this case below.
- Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ if not ASIS_Mode then
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ end if;
+
Unum :=
Load_Unit
(Load_Name => Subunit_Name,
Required => False,
Subunit => True,
Error_Node => N);
- Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+
+ if not ASIS_Mode then
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ end if;
-- All done if we successfully loaded the subunit
Index: sem_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch6.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_ch6.adb
--- sem_ch6.adb 14 May 2004 13:55:11 -0000 1.20
+++ sem_ch6.adb 19 May 2004 10:47:03 -0000
@@ -790,6 +790,33 @@ package body Sem_Ch6 is
Missing_Ret : Boolean;
P_Ent : Entity_Id;
+ procedure Check_Following_Pragma;
+ -- If front-end inlining is enabled, look ahead to recognize a pragma
+ -- that may appear after the body.
+
+ procedure Check_Following_Pragma is
+ Prag : Node_Id;
+ begin
+ if Front_End_Inlining
+ and then Is_List_Member (N)
+ and then Present (Spec_Decl)
+ and then List_Containing (N) = List_Containing (Spec_Decl)
+ then
+ Prag := Next (N);
+
+ if Present (Prag)
+ and then Nkind (Prag) = N_Pragma
+ and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline
+ and then
+ Chars
+ (Expression (First (Pragma_Argument_Associations (Prag))))
+ = Chars (Body_Id)
+ then
+ Analyze (Prag);
+ end if;
+ end if;
+ end Check_Following_Pragma;
+
begin
if Debug_Flag_C then
Write_Str ("==== Compiling subprogram body ");
@@ -1141,13 +1168,15 @@ package body Sem_Ch6 is
elsif Present (Spec_Id)
and then Expander_Active
- and then (Is_Always_Inlined (Spec_Id)
- or else (Has_Pragma_Inline (Spec_Id)
- and then
- (Front_End_Inlining
- or else Configurable_Run_Time_Mode)))
then
- Build_Body_To_Inline (N, Spec_Id);
+ Check_Following_Pragma;
+
+ if Is_Always_Inlined (Spec_Id)
+ or else (Has_Pragma_Inline (Spec_Id)
+ and then (Front_End_Inlining or else Configurable_Run_Time_Mode))
+ then
+ Build_Body_To_Inline (N, Spec_Id);
+ end if;
end if;
-- Ada 0Y (AI-262): In library subprogram bodies, after the analysis
@@ -1169,6 +1198,7 @@ package body Sem_Ch6 is
Process_End_Label (HSS, 't', Current_Scope);
End_Scope;
Check_Subprogram_Order (N);
+ Set_Analyzed (Body_Id);
-- If we have a separate spec, then the analysis of the declarations
-- caused the entities in the body to be chained to the spec id, but
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.30
diff -u -p -r1.30 sem_prag.adb
--- sem_prag.adb 17 May 2004 13:20:44 -0000 1.30
+++ sem_prag.adb 19 May 2004 10:47:04 -0000
@@ -2856,15 +2856,17 @@ package body Sem_Prag is
procedure Set_Inline_Flags (Subp : Entity_Id);
-- Sets Is_Inlined and Has_Pragma_Inline flags for Subp
- function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
+ function Cannot_Inline (Subp : Entity_Id) return Boolean;
-- Do not set the inline flag if body is available and contains
-- exception handlers, to prevent undefined symbols at link time.
+ -- Emit warning if front-end inlining is enabled and the pragma
+ -- appears too late.
- ----------------------------
- -- Back_End_Cannot_Inline --
- ----------------------------
+ -------------------
+ -- Cannot_Inline --
+ -------------------
- function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
+ function Cannot_Inline (Subp : Entity_Id) return Boolean is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
begin
@@ -2876,12 +2878,19 @@ package body Sem_Prag is
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
+ if Front_End_Inlining
+ and then Analyzed (Corresponding_Body (Decl))
+ then
+ Error_Msg_N ("pragma appears too late, ignored?", N);
+ return True;
+
-- If the subprogram is a renaming as body, the body is
-- just a call to the renamed subprogram, and inlining is
-- trivially possible.
- if Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
- N_Subprogram_Renaming_Declaration
+ elsif
+ Nkind (Unit_Declaration_Node (Corresponding_Body (Decl)))
+ = N_Subprogram_Renaming_Declaration
then
return False;
@@ -2897,7 +2906,7 @@ package body Sem_Prag is
return False;
end if;
- end Back_End_Cannot_Inline;
+ end Cannot_Inline;
-----------------
-- Make_Inline --
@@ -2911,7 +2920,7 @@ package body Sem_Prag is
if Etype (Subp) = Any_Type then
return;
- elsif Back_End_Cannot_Inline (Subp) then
+ elsif Cannot_Inline (Subp) then
Applies := True; -- Do not treat as an error.
return;
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-05-17 13:52 Arnaud Charlet
@ 2004-05-17 14:06 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-17 14:06 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 165 bytes --]
Forgot the attachment... Here it is.
> Tested on x86-linux use the tree-ssa-pre-merge tag
>
> Various clean ups, and progress in the function-at-a-time conversion
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 67440 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-17 13:52 Arnaud Charlet
2004-05-17 14:06 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-17 13:52 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux use the tree-ssa-pre-merge tag
Various clean ups, and progress in the function-at-a-time conversion
--
2004-05-17 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
Part of function-at-a-time conversion
* misc.c (adjust_decl_rtl): Deleted.
(LANG_HOOKS_PUSHLEVEL, LANG_HOOKS_POPLEVEL, LANG_HOOKS_SET_BLOCK):
Define.
* gigi.h: (adjust_decl_rtl, kept_level_p, set_block): Deleted.
(add_decl_stmt, add_stmt, block_has_vars): New functions.
(gnat_pushlevel, gnat_poplevel): Renamed from pushlevel and poplevel.
* decl.c (elaborate_expression, maybe_pad_type): Call add_decl_stmt
when making a decl.
(gnat_to_gnu_entity): Likewise.
Use add_stmt to update setjmp buffer.
Set TREE_ADDRESSABLE instead of calling put_var_into_stack and
flush_addressof.
No longer call adjust_decl_rtl.
(DECL_INIT_BY_ASSIGN_P): New macro.
(DECL_STMT_VAR): Likewise.
* trans.c (gigi): Call start_block_stmt to make the outermost
BLOCK_STMT.
(gnat_to_code, gnu_to_gnu, tree_transform, process_decls, process_type):
Call start_block_stmt and end_block_stmt temporarily.
Use gnat_expand_stmt instead of expand_expr_stmt.
(add_decl_stmt): New function.
(tree_transform): Call it.
(add_stmt): Also emit initializing assignment for DECL_STMT if needed.
(end_block_stmt): Set type and NULL_STMT.
(gnat_expand_stmt): Make recursize call instead of calling
expand_expr_stmt.
(gnat_expand_stmt, case DECL_STMT): New case.
(set_lineno_from_sloc): Do nothing if global.
(gnu_block_stmt_node, gnu_block_stmt_free_list): New variables.
(start_block_stmt, add_stmt, end_block_stmt): New functions.
(build_block_stmt): Call them.
(gnat_to_code): Don't expand NULL_STMT.
(build_unit_elab): Rename pushlevel and poplevel to gnat_* and change
args.
(tree_transform): Likewise.
(tree_transform, case N_Null_Statement): Return NULL_STMT.
(gnat_expand_stmt, case NULL_STMT): New case.
(gnat_expand_stmt, case IF_STMT): Allow nested IF_STMT to have no
IF_STMT_TRUE.
* utils2.c (gnat_mark_addressable, case VAR_DECL): Do not set
TREE_ADDRESSABLE.
* utils.c (create_var_decl): Do not call expand_decl or
expand_decl_init.
Set TREE_ADDRESSABLE instead of calling gnat_mark_addressable.
Set DECL_INIT_BY_ASSIGN_P when needed and do not generate MODIFY_EXPR
here.
(struct e_stack): Add chain_next to GTY.
(struct binding_level): Deleted.
(struct ada_binding_level): New struct.
(free_block_chain): New.
(global_binding_level, clear_binding_level): Deleted.
(global_bindings_p): Rework to see if no chain.
(kept_level_p, set_block): Deleted.
(gnat_pushlevel): Renamed from pushlevel and extensive reworked to use
new data structure and work directly on BLOCK node.
(gnat_poplevel): Similarly.
(get_decls): Look at BLOCK_VARS.
(insert_block): Work directly on BLOCK node.
(block_has_var): New function.
(pushdecl): Rework for new binding structures.
(gnat_init_decl_processing): Rename and rework calls to pushlevel and
poplevel.
(build_subprog_body): Likewise.
(end_subprog_body): Likewise; also set up BLOCK in DECL_INITIAL.
* ada-tree.def (DECL_STMT, NULL_STMT): New codes.
* ada-tree.h: (DECL_INIT_BY_ASSIGN_P): New macro.
(DECL_STMT_VAR): Likewise.
2004-05-17 Robert Dewar <dewar@gnat.com>
* restrict.ads, restrict.adb (Process_Restriction_Synonym): New
procedure
* sem_prag.adb (Analyze_Pragma, case Restrictions): Cleanup handling
of restriction synonyums by using
Restrict.Process_Restriction_Synonyms.
* snames.ads, snames.adb: Add entries for Process_Restriction_Synonym
* s-restri.ads (Tasking_Allowed): Correct missing comment
* s-rident.ads: Add entries for restriction synonyms
* ali.adb: Fix some problems with badly formatted ALI files that can
result in infinite loops.
* s-taprop-lynxos.adb, s-tpopsp-lynxos.adb, s-taprop-tru64.adb,
s-tpopsp-posix-foreign.adb, s-taprop-irix.adb, s-interr-sigaction.adb,
s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb,
s-taprop-dummy.adb, s-interr-dummy.adb, s-taprop-os2.adb,
s-taprop-solaris.adb, s-tpopsp-solaris.adb, s-asthan-vms.adb,
s-inmaop-vms.adb, s-interr-vms.adb, s-taprop-vms.adb,
s-tpopde-vms.adb, s-taprop-mingw.adb, s-interr-vxworks.adb,
s-taprop-vxworks.adb, s-tpopsp-vxworks.adb, s-taprop-posix.adb,
s-tpopsp-posix.adb, s-tratas-default.adb, a-dynpri.adb,
a-tasatt.adb, a-taside.adb, a-taside.ads, exp_attr.adb,
exp_ch9.adb, g-thread.adb, rtsfind.ads, sem_attr.adb,
s-interr.adb, s-interr.ads, s-soflin.ads, s-taasde.adb,
s-taasde.ads, s-taenca.adb, s-taenca.ads, s-taprop.ads,
s-tarest.adb, s-tarest.ads, s-tasdeb.adb, s-tasdeb.ads,
s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads,
s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads,
s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads,
s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads,
s-tpoben.adb, s-tpobop.adb, s-tpobop.ads, s-tporft.adb,
s-tposen.adb, s-tposen.ads, s-tratas.adb, s-tratas.ads: Change Task_ID
to Task_Id (minor cleanup).
2004-05-17 Vincent Celier <celier@gnat.com>
* g-os_lib.adb (Normalize_Pathname.Final_Value): Remove trailing
directory separator.
* prj-proc.adb (Recursive_Process): Inherit attribute Languages from
project being extended, if Languages is not declared in extending
project.
2004-05-17 Javier Miranda <miranda@gnat.com>
* sem_ch10.adb (Install_Limited_Withed_Unit): Do not install the
limited view of a visible sibling.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-14 14:29 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-14 14:29 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3401 bytes --]
Tested on x86-linux using the pre sse tag
--
2004-05-14 Robert Dewar <dewar@gnat.com>
* gnat_ugn.texi: Minor change to -gnatS documentation
* sprint.adb: Remove some instances of Assert (False) and for this
purpose replace them by output of a ??? string.
* checks.adb, exp_aggr.adb, sem_elim.adb: Remove useless pragma
Assert (False).
* lib-writ.adb, lib-load.adb, lib.ads, lib.adb: Remove Dependent_Unit
flag processing. This was suppressing required dependencies in
No_Run_Time mode and is not needed since the binder does not generate
references for things in libgnat anyway.
* sem_ch3.adb (Access_Type_Declaration): Reorganize code to avoid GCC
warning.
2004-05-14 Thomas Quinot <quinot@act-europe.fr>
* gnat_ugn.texi: Document AIX-specific issue with initialization of
resolver library.
* exp_ch4.adb (Insert_Dereference_Action): Do not generate dereference
action for the case of an actual parameter in an init proc call.
2004-05-14 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Analyze_Selected_Component): If prefix is a protected
subtype, check visible entities in base type.
* exp_ch7.adb (Clean_Simple_Protected_Objects): Do not generate cleanup
actions if the object is a renaming.
* sem_ch12.adb (Same_Instantiated_Entity): Predicate for
Check_Formal_Package_Instance, to determine more precisely when the
formal and the actual denote the same entity.
2004-05-14 Javier Miranda <miranda@gnat.com>
* par-ch10.adb (P_Context_Clause): Complete documentation on AI-262
* sem_ch10.adb (Analyze_With_Clause): After analyzed, the entity
corresponding to a private_with must be removed from visibility; it
will be made visible later, just before we analyze the private part of
the package.
(Check_Private_Child_Unit): Allow private_with clauses in public
siblings.
(Install_Siblings): Make visible the private entities of private-withed
siblings.
(Install_Withed_Unit): Do not install the private withed unit if we
are compiling a package declaration and the Private_With_OK flag was
not set by the caller. These declarations will be installed later,
just before we analyze the private part of the package.
* sem_ch3.adb (Analyze_Object_Declaration): In case of errors detected
during the evaluation of the expression that initializes the object,
decorate it with the expected type to avoid cascade errors.
Code cleanup.
* sem_ch6.adb (Analyze_Subprogram_Body): If we are compiling a library
subprogram we have to install the private_with clauses after its
specification has been analyzed (as documented in AI-262.TXT).
* sem_ch8.adb (Has_Private_With): New function. Determines if the
current compilation unit has a private with on a given entity.
(Find_Direct_Name): Detect the Beaujolais problem described in
AI-262.TXT
* sem_utils.ads, sem_util.adb (Is_Ancestor_Package): New function. It
provides the functionality of the function Is_Ancestor that was
previously available in sem_ch10. It has been renamed to avoid
overloading.
* sprint.adb (Sprint_Node_Actual): Print limited_with clauses
2004-05-14 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils.c (build_vms_descriptor): Use SImode pointers.
2004-05-14 Vasiliy Fofanov <fofanov@act-europe.fr>
* gnat_ugn.texi: Revised chapter "GNAT and Libraries".
2004-05-14 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 19460 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-10 17:17 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-10 17:17 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5078 bytes --]
Tested on x86-linux
--
2004-05-10 Doug Rupp <rupp@gnat.com>
* 5qsystem.ads: Remove Short_Address subtype declaration. Moved to
system.aux_dec.
* s-auxdec.ads: Add Short_Address subtype (moved here from System).
* Makefile.in: [VMS]: Add translation for 5qauxdec.ads.
* init.c: [VMS] Macroize LIB$ calls for IA64 and Alpha.
Fixes undefined symbols in IA64 gnatlib.
* 5vinmaop.adb: Reference s-auxdec for Short_Address.
* 5xsystem.ads, 5vsystem.ads: Back out last change (addition of subtype
Short_Address). This will be moved to system.auxdec.
2004-05-10 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb: Replace test for presence of a node that is always
present with a call to Discard_Node.
* sem_ch10.adb (Analyze_Compilation_Unit): Remove superfluous call to
Analyze on the library unit node after generation of distribution stub
constructs. The call was a no-op because Unit_Node has already been
Analyzed, and the tree fragments for the distribution stubs are
analyzed as they are inserted in Exp_Dist.
Update comment regarding to distribution stubs to reflect that we
do not generate stub in separate files anymore.
* einfo.ads: Clarify the fact that a tagged private type has the
E_Record_Type_With_Private Ekind.
* erroutc.adb: Minor reformatting
* erroutc.ads (Max_Msg_Length): Increase to cover possible larger
values if line length is increased using -gnatyM (noticed during code
reading).
* eval_fat.adb: Minor reformatting
Put spaces around exponentiation operator
2004-05-10 Ed Schonberg <schonberg@gnat.com>
PR ada/15005
* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): If prefix
has been rewritten as an explicit dereference, retrieve type of
original node to check for possibly unconstrained record type.
2004-05-10 Ed Schonberg <schonberg@gnat.com>
* exp_ch7.adb (Check_Visibly_Controlled): If given operation is not
overriding, use the operation of the parent unconditionally.
* sem_ch4.adb (Remove_Address_Interpretations): Remove address
operation when either operand is a literal, to avoid further
ambiguities.
* sem_ch6.adb (New_Overloaded_Entity): If new entity is inherited and
overridden by a previous explicit declaration, mark the previous entity
as overriding.
* sem_disp.adb (Check_Dispatching_Operation): New predicate
Is_Visibly_Controlled, to determine whether a declaration of a
primitive control operation for a derived type overrides an inherited
one. Add warning if the explicit declaration does not override.
2004-05-10 Vincent Celier <celier@gnat.com>
* gnatls.adb (Gnatls): Initialize Snames, to avoid assertion error in
some cases when the sources are no longer present.
* make.adb (Collect_Arguments): Fail if an external source, not part
of any project need to be compiled, when switch -x has not been
specified.
* makeusg.adb: Document new switch -x
* opt.ads (External_Unit_Compilation_Allowed): New Boolean flag,
defaulted to False.
* switch-m.adb (Scan_Make_Switches): New switch -x
* vms_data.ads: Add VMS qualifier /NON_PROJECT_UNIT_COMPILATION for
gnatmake switch -x.
* gnat_ugn.texi: Document new gnatmake switch -x
2004-05-10 Eric Botcazou <ebotcazou@act-europe.fr>
* misc.c (gnat_init_options): Set flag_zero_initialized_in_bss to 0.
* utils.c (create_var_decl): Do not modify the DECL_COMMON flag.
(process_attributes): Likewise.
2004-05-10 Joel Brobecker <brobecker@gnat.com>
* s-inmaop.ads: Fix spelling mistake in one of the comments.
2004-05-10 Robert Dewar <dewar@gnat.com>
* gnat_ugn.texi: Document that for config pragma files, the maximum
line length is always 32767.
* gnat_rm.texi: For pragma Eliminate, note that concatenation of string
literals is now allowed.
* gnat-style.texi: Remove statement about splitting long lines before
an operator rather than after, since we do not follow this rule at all.
Clarify rule (really lack of rule) for spaces around exponentiation
* sem_elim.adb: Allow concatenation of string literals as well as a
single string literal for pragma arguments.
* sem_prag.ads, sem_prag.adb: (Is_Config_Static_String): New function
* a-textio.adb (Terminate_Line): Do not add line feed if nothing
written for append case.
* frontend.adb: Changes to avoid checking max line length in config
pragma files.
* g-os_lib.ads: Minor reformatting
* mlib-utl.adb: Do not define Max_Line_Length locally (definition was
wrong in any case. Instead use standard value. Noticed during code
reading.
* opt.ads (Max_Line_Length): New field, used to implement removal of
limitation on length of lines when scanning config pragma files.
* osint.ads, prj-dect.adb, prj-strt.adb, prj-tree.adb,
makeutl.ads, makeutl.adb: Minor reformatting
* scn.adb: Do not check line length while scanning config pragma files
Do not check line length while scanning out license information
* scng.adb: Changes to avoid line length checks while parsing config
pragma files.
2004-05-10 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 19347 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-05 12:49 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-05 12:49 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5496 bytes --]
Tested on x86-linux
--
2004-05-05 Emmanuel Briot <briot@act-europe.fr>
* g-os_lib.ads (Invalid_Time): New constant
* adaint.h, adaint.c (__gnat_file_time_name, __gnat_file_time_fd): Now
return OS_Time instead of time_t to match what is imported by Ada.
Now return -1 if the file doesn't exist, instead of a random value
2004-05-05 Robert Dewar <dewar@gnat.com>
* usage.adb: Add line for -gnatR?s switch
* sem_ch13.adb, exp_ch2.adb: Minor reformatting
* g-regpat.ads, g-regpat.adb: Add documentation on handling of Size
and for Match (Data_First, Data_last)
* lib-writ.adb (Write_With_Lines): Ensure that correct index number is
written when we are dealing with multi-unit files.
2004-05-05 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: Remove unused targets and variables.
2004-05-05 Vincent Celier <celier@gnat.com>
* switch-m.adb: New gnatmake switch -eI
* vms_data.ads: Add VMS equivalents of new gnatclean swith -innn and
of new gnatmake switch -eInnn.
* makegpr.adb: Take into account new parameters Index and Src_Index in
Prj.Util.
* clean.adb: Implement support for multi-unit sources, including new
switch -i.
* gnatcmd.adb (GNATCmd): Call Prj.Util.Value_Of with new parameter
Src_Index.
* make.ads, make.adb (Insert_Q): New parameter Index, defaulted to 0
(Extract_From_Q): New out parameter Index
(Mark, Is_Marked): Subprograms moved to Makeutl
(Switches_Of): New parameter Source_Index
(Add_Switch): New parameter Index
(Check): New parameter Source_Index
(Collect_Arguments): New parameter Source_Index
(Collect_Arguments_And_Compile): New parameter Source_Index
(Compile): New parameter Source_Index
Put subprograms in alphabetical order
Add support for multi-source sources, including in project files.
* makeutl.ads, makeutl.adb (Unit_Index_Of): New function
(Mark, Is_Marked, Delete_All_Marks): New subprograms, moved from
Make.
* makeusg.adb: New gnatmake switch -eInnn
* mlib-prj.adb (Build_Library): Add new parameter Src_Index to call to
Prj.Util.Value_Of.
* opt.ads (Main_Index): New variable, defaulted to 0.
* osint.ads, osinte.adb (Add_File): New parameter Index
(Current_Source_Index): New function
* prj.adb: Take into account new components Index and Src_Index
* prj.ads (String_Element): New component Index
(Variable_Value): New component Index
(Array_Element): New component Src_Index
* prj-attr.adb: Indicate that optional index may be specified for
attributes Main, Executable, Spec, Body and some of Switches.
* prj-attr.ads (Attribute_Kind): New values for optional indexes
(Attribute_Record): New component Optional_Index
* prj-com.ads (File_Name_Data): New component Index
* prj-dect.adb (Parse_Attribute_Declaration): Process optional index
* prj-env.adb (Put): Output optional index
* prj-makr.adb: Put indexes for multi-unit sources in SFN pragmas and
attributes Spec and Body.
* prj-nmsc.adb: Process optional indexes
* prj-pp.adb: Ouput "at" for optional indexes
* prj-proc.adb: Take into account optional indexes
* prj-strt.ads, prj-strt.adb (Terms): New Boolean parameter
Optional_Index. For string literal,
process optional index when Optional_Index is True.
(Parse_Expresion): New Boolean parameter Optional_Index
* prj-tree.ads, prj-tree.adb (Source_Index_Of): New function
(Set_Source_Index_Of): New procedure
* prj-util.adb (Executable_Of, Value_Of): Take into account optional
index.
* prj-util.ads (Executable_Of): New parameter Index
(Value_Of (Name_Id, Array_Element_Id) returning Variable_Value):
New parameter Src_Index, defaulted to 0.
2004-05-05 Ed Schonberg <schonberg@gnat.com>
PR ada/15257
* sem_ch3.adb (Access_Definition): If this is an access parameter
whose designated type is imported through a limited_with clause, do
not add the enclosing subprogram to the list of private dependents of
the type.
2004-05-05 Ed Schonberg <schonberg@gnat.com>
PR ada/15258
* sem_ch6.adb (Base_Types_Match): True if one type is imported through
a limited_with clause, and the other is its non-limited view.
2004-05-05 Thomas Quinot <quinot@act-europe.fr>
* cstand.adb (Create_Standard): Initialize Stand.Boolean_Literals.
* exp_attr.adb, exp_ch5.adb, exp_ch9.adb, exp_disp.adb,
exp_fixd.adb, sem_attr.adb, sem_dist.adb, sem_util.adb: Use
Stand.Boolean_Literals to produce references to entities
Standard_False and Standard_True from compile-time computed boolean
values.
* stand.ads (Boolean_Literals): New variable, provides the entity
values for False and True, for use by the expander.
2004-05-05 Doug Rupp <rupp@gnat.com>
* 5vinmaop.adb, 5[vx]system.ads: Add Short_Address subtype
5vinmaop.adb: Unchecked convert Short_Address vice Address
* adaint.c, raise.c: Caste CRTL function return value
to avoid gcc error on 32/64 bit IVMS.
* Makefile.in [VMS]: Use iar archiver if host = Alpha/VMS and
target = IA64/VMS.
* init.c[VMS]: Only call Alpha specific __gnat_error_prehandler IN_RTS.
* 5qsystem.ads (Address): Declare as Long_Integer
(Short_Address): Declare as 32 bit subtype of Address
Declare abstract address operations to avoid gratuitous ambiguities.
2004-05-05 Jose Ruiz <ruiz@act-europe.fr>
* gnat_rm.texi: Use the new restriction Simple_Barriers (AI-249)
instead of the old Boolean_Entry_Barriers.
Ditto for No_Task_Attributes_Package instead of No_Task_Attributes.
2004-05-05 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 52511 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-05-03 12:46 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-05-03 12:46 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3686 bytes --]
Tested on x86-linux
--
2004-05-03 Olivier Hainque <hainque@act-europe.fr>
PR ada/15152
* exp_ch2.adb (Expand_Current_Value): Leave Machine_Code Asm arguments
alone. Replacing object references by literals is inappropriate in a
so low level context.
2004-05-03 Arnaud Charlet <charlet@act-europe.fr>
* a-exexpr.adb: Add comments
2004-05-03 Joel Brobecker <brobecker@gnat.com>
* a-tags.adb (Tag_Table): Add Index_Check pragma Suppress. Allows us to
declare the Ancestor_Tags array in Type_Specific_Data with a small size
without risking a bounds check error when accessing one of its
components.
(Type_Specific_Data): Define Ancestor_Tags as a small array.
This prevents us from hitting a limitation during the debug info
generation when using stabs.
* a-tags.adb (Dispatch_Table): Define the Prims_Ptr component as a
small array.
This prevents us from hitting a limitation during the debug info
generation when using stabs.
2004-05-03 Eric Botcazou <ebotcazou@act-europe.fr>
lang-specs.h: Remove -gnatz* from specs.
2004-05-03 Vincent Celier <celier@gnat.com>
* gprmake.adb, makegpr.ads, makegpr.adb: New files.
* Make-lang.in, Makefile.in: Add gprmake
2004-05-03 Thomas Quinot <quinot@act-europe.fr>
* sem_aggr.adb: Fix typo in comment.
2004-05-03 Robert Dewar <dewar@gnat.com>
* make.adb: Minor reformatting
* rtsfind.ads, rtsfind.adb: (RTU_Loaded): New function
* sem_attr.adb (Eval_Attribute, case Type_Class): Fix check for address
so that it works when address is not a private type.
* sem_ch13.adb (Check_Expr_Constants, case N_Integer_Literal): Deal
properly with rewritten unchecked conversions. This prevents
order-of-elaboration issues that can otherwise arise.
(Minimum_Size): Don't check size of access types under VMS
* sem_ch4.adb (Remove_Address_Interpretation): New circuit to remove
interpretations of integer literals as type System.Address.
* sem_util.ads, sem_util.adb (Is_Descendent_Of_Address): New function
(Is_Descendent_Of): New function
2004-05-03 Jose Ruiz <ruiz@act-europe.fr>
* sem_prag.adb: Boolean_Entry_Barriers is a synonym of Simple_Barriers.
Max_Entry_Queue_Depth is a synonym of Max_Entry_Queue_Length.
No_Dynamic_Interrupts is a synonym of No_Dynamic_Attachment.
* sem_res.adb: Use the new restriction Max_Entry_Queue_Length instead
of the old Max_Entry_Queue_Depth.
* snames.adb: Boolean_Entry_Barriers is a synonym of Simple_Barriers.
Max_Entry_Queue_Depth is a synonym of Max_Entry_Queue_Length
No_Dynamic_Interrupts is a synonym of No_Dynamic_Attachment
* snames.ads: New entry for proper handling of Boolean_Entry_Barriers.
New entry for proper handling of Max_Entry_Queue_Depth.
New entry for proper handling of No_Dynamic_Interrupts.
* s-rident.ads: Adding restriction Simple_Barriers (AI-00249) that
supersedes the GNAT specific restriction Boolean_Entry_Barriers.
Adding restriction Max_Entry_Queue_Length (AI-00249) that supersedes
the GNAT specific restriction Max_Entry_Queue_Depth.
Adding restriction No_Dynamic_Attachment (AI-00249) that supersedes
the GNAT specific restriction No_Dynamic_Interrupts.
* restrict.ads, restrict.adb: Use the new restriction Simple_Barriers
instead of the old Boolean_Entry_Barriers.
Use the new restriction No_Dynamic_Attachment instead of the old
No_Dynamic_Interrupts.
* exp_ch9.adb: Check restriction Simple_Barriers (AI-00249) that
supersedes the GNAT specific restriction Boolean_Entry_Barriers.
* gnatbind.adb: Use the new restriction Max_Entry_Queue_Length instead
of the old Max_Entry_Queue_Depth.
2004-05-03 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 26602 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-29 15:39 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-29 15:39 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-04-29 Ed Schonberg <schonberg@gnat.com>
* checks.adb (Enable_Range_Check): If the prefix of an index component
is an access to an unconstrained array, perform check unconditionally.
2004-04-29 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_field): Also call make_packable_type if
Component_Clause.
2004-04-29 Olivier Hainque <hainque@act-europe.fr>
* init.c (__gnat_install_handler, __gnat_error_handler): Remove
alternate stack setting. There was no support for the tasking cases
and the changes eventually caused a number of side-effect failures in
the non-tasking case too.
2004-04-29 Eric Botcazou <ebotcazou@act-europe.fr>
lang-specs.h: Redirect output to /dev/null if -gnatc or -gnatz or
-gnats is passed.
2004-04-29 Vincent Celier <celier@gnat.com>
* make.adb (Gnatmake): Increase max size of argument array for
gnatbind for the potential addition of -F.
If there are Stand-Alone Library projects, invoke gnatbind with -F to
be sure that elaboration flags will be checked.
* switch-c.adb: Correct call to Scan_Pos for -gnateI
2004-04-29 Thomas Quinot <quinot@act-europe.fr>
* sem_warn.adb (Check_References): Move '<access-variable> may be
null' warning out of under Warn_On_No_Value_Assigned.
2004-04-29 Ed Falis <falis@gnat.com>
* gnat_ugn.texi: Fixed texi error
2004-04-29 Robert Dewar <dewar@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Unconditionally remove
abstract operations if they come from predefined files.
* gnat_rm.texi: Fix bad doc for pragma Elaboration_Checks (should be
Dynamic, not RM).
* s-addope.adb: Correct obvious error in mod function
--
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.19
diff -u -p -r1.19 checks.adb
--- checks.adb 19 Apr 2004 15:19:56 -0000 1.19
+++ checks.adb 29 Apr 2004 14:40:33 -0000
@@ -3379,6 +3379,16 @@ package body Checks is
if Is_Access_Type (Atyp) then
Atyp := Designated_Type (Atyp);
+
+ -- If the prefix is an access to an unconstrained array,
+ -- perform check unconditionally: it depends on the bounds
+ -- of an object and we cannot currently recognize whether
+ -- the test may be redundant.
+
+ if not Is_Constrained (Atyp) then
+ Set_Do_Range_Check (N, True);
+ return;
+ end if;
end if;
Indx := First_Index (Atyp);
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.41
diff -u -p -r1.41 decl.c
--- decl.c 27 Apr 2004 10:49:37 -0000 1.41
+++ decl.c 29 Apr 2004 14:40:33 -0000
@@ -4998,11 +4998,11 @@ gnat_to_gnu_field (Entity_Id gnat_field,
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
- /* If we are packing this record or we have a specified size that's
- smaller than that of the field type and the field type is also a record
- that's BLKmode and with a small constant size, see if we can get a
- better form of the type that allows more packing. If we can, show
- a size was specified for it if there wasn't one so we know to
+ /* If we are packing this record, have a specified size that's smaller than
+ that of the field type, or a position is specified, and the field type
+ is also a record that's BLKmode and with a small constant size, see if
+ we can get a better form of the type that allows more packing. If we
+ can, show a size was specified for it if there wasn't one so we know to
make this a bitfield and avoid making things wider. */
if (TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_MODE (gnu_field_type) == BLKmode
@@ -5010,7 +5010,8 @@ gnat_to_gnu_field (Entity_Id gnat_field,
&& compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
&& (packed
|| (gnu_size != 0 && tree_int_cst_lt (gnu_size,
- TYPE_SIZE (gnu_field_type)))))
+ TYPE_SIZE (gnu_field_type)))
+ || Present (Component_Clause (gnat_field))))
{
gnu_field_type = make_packable_type (gnu_field_type);
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.30
diff -u -p -r1.30 init.c
--- init.c 6 Apr 2004 14:21:12 -0000 1.30
+++ init.c 29 Apr 2004 14:40:33 -0000
@@ -370,7 +370,6 @@ __gnat_initialize (void)
exclude this case in the above test. */
#include <signal.h>
-#include <setjmp.h>
#include <sys/siginfo.h>
static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *);
@@ -388,7 +387,6 @@ __gnat_error_handler (int sig, siginfo_t
static int recurse = 0;
struct sigcontext *mstate;
const char *msg;
- jmp_buf handler_jmpbuf;
/* If this was an explicit signal from a "kill", just resignal it. */
if (SI_FROMUSER (sip))
@@ -398,43 +396,6 @@ __gnat_error_handler (int sig, siginfo_t
}
/* Otherwise, treat it as something we handle. */
-
- /* We are now going to raise the exception corresponding to the signal we
- caught, which may eventually end up resuming the application code if the
- exception is handled.
-
- When the exception is handled, merely arranging for the *exception*
- handler's context (stack pointer, program counter, other registers, ...)
- to be installed is *not* enough to let the kernel think we've left the
- *signal* handler. This has annoying implications if an alternate stack
- has been setup for this *signal* handler, because the kernel thinks we
- are still running on that alternate stack even after the jump, which
- causes trouble at least as soon as another signal is raised.
-
- We deal with this by forcing a "local" longjmp within the signal handler
- below, forcing the "on alternate stack" indication to be reset (kernel
- wise) on the way. If no alternate stack has been setup, this should be a
- neutral operation. Otherwise, we will be in a delicate situation for a
- short while because we are going to run the exception propagation code
- within the alternate stack area (that is, with the stack pointer inside
- the alternate stack bounds), but with the corresponding flag off from the
- kernel's standpoint. We expect this to be ok as long as the propagation
- code does not trigger a signal itself, which is expected.
-
- ??? A better approach would be to at least delay this operation until the
- last second, that is, until just before we jump to the exception handler,
- if any. */
-
- if (setjmp (handler_jmpbuf) == 0)
- {
-#define JB_ONSIGSTK 0
-
- /* Arrange for the "on alternate stack" flag to be reset. See the
- comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
- handler_jmpbuf [JB_ONSIGSTK] = 0;
- longjmp (handler_jmpbuf, 1);
- }
-
switch (sig)
{
case SIGSEGV:
@@ -494,36 +455,12 @@ __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 is a mininum to be able to propagate an exception using 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! */
act.sa_handler = (void (*) (int)) __gnat_error_handler;
- act.sa_flags = SA_ONSTACK | SA_RESTART | SA_NODEFER | SA_SIGINFO;
+ act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO;
sigemptyset (&act.sa_mask);
/* Do not install handlers if interrupt state is "System" */
Index: lang-specs.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lang-specs.h,v
retrieving revision 1.8
diff -u -p -r1.8 lang-specs.h
--- lang-specs.h 3 Dec 2003 11:47:52 -0000 1.8
+++ lang-specs.h 29 Apr 2004 14:40:33 -0000
@@ -6,7 +6,7 @@
* *
* C Header 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- *
@@ -40,4 +40,5 @@
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \
%i %{S:%W{o*}%{!o*:-o %b.s}} \
+ %{!S:%{gnatc*|gnatz*|gnats*: -o %j}} \
%{!gnatc*:%{!gnatz*:%{!gnats*:%(invoke_as)}}}", 0, 0, 0},
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.35
diff -u -p -r1.35 make.adb
--- make.adb 19 Apr 2004 15:19:59 -0000 1.35
+++ make.adb 29 Apr 2004 14:40:33 -0000
@@ -344,6 +344,7 @@ package body Make is
-- These flags are reset to True for each invokation of procedure Gnatmake.
Shared_String : aliased String := "-shared";
+ Force_Elab_Flags_String : aliased String := "-F";
No_Shared_Switch : aliased Argument_List := (1 .. 0 => null);
Shared_Switch : aliased Argument_List := (1 => Shared_String'Access);
@@ -3323,6 +3324,8 @@ package body Make is
-- The current working directory, used to modify some relative path
-- switches on the command line when a project file is used.
+ There_Are_Stand_Alone_Libraries : Boolean := False;
+
begin
Gnatmake_Called := True;
@@ -4428,6 +4431,10 @@ package body Make is
for Proj1 in Projects.First .. Projects.Last loop
+ if Projects.Table (Proj1).Standalone_Library then
+ There_Are_Stand_Alone_Libraries := True;
+ end if;
+
if Projects.Table (Proj1).Library
and then not Projects.Table (Proj1).Flag1
then
@@ -4643,7 +4650,7 @@ package body Make is
if Do_Bind_Step then
Bind_Step : declare
Args : Argument_List
- (Binder_Switches.First .. Binder_Switches.Last + 1);
+ (Binder_Switches.First .. Binder_Switches.Last + 2);
-- The arguments for the invocation of gnatbind
Last_Arg : Natural := Binder_Switches.Last;
@@ -4703,6 +4710,11 @@ package body Make is
for J in Binder_Switches.First .. Last_Arg loop
Args (J) := Binder_Switches.Table (J);
end loop;
+
+ if There_Are_Stand_Alone_Libraries then
+ Last_Arg := Last_Arg + 1;
+ Args (Last_Arg) := Force_Elab_Flags_String'Access;
+ end if;
if Main_Project /= No_Project then
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.19
diff -u -p -r1.19 sem_ch4.adb
--- sem_ch4.adb 19 Apr 2004 15:20:05 -0000 1.19
+++ sem_ch4.adb 29 Apr 2004 14:40:34 -0000
@@ -30,7 +30,9 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
+with Fname; use Fname;
with Itypes; use Itypes;
+with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -4344,22 +4346,32 @@ package body Sem_Ch4 is
--------------------------------
procedure Remove_Abstract_Operations (N : Node_Id) is
- I : Interp_Index;
- It : Interp;
- Abstract_Op : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Abstract_Op : Entity_Id := Empty;
-- AI-310: If overloaded, remove abstract non-dispatching
- -- operations.
+ -- operations. We activate this if either extensions are
+ -- enabled, or if the abstract operation in question comes
+ -- from a predefined file. This latter test allows us to
+ -- use abstract to make operations invisible to users. In
+ -- particular, if type Address is non-private and abstract
+ -- subprograms are used to hide its operators, they will be
+ -- truly hidden.
begin
- if Extensions_Allowed
- and then Is_Overloaded (N)
- then
+ if Is_Overloaded (N) then
Get_First_Interp (N, I, It);
+
while Present (It.Nam) loop
if not Is_Type (It.Nam)
and then Is_Abstract (It.Nam)
and then not Is_Dispatching_Operation (It.Nam)
+ and then
+ (Extensions_Allowed
+ or else Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (It.Nam))))
+
then
Abstract_Op := It.Nam;
Remove_Interp (I);
Index: sem_warn.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_warn.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_warn.adb
--- sem_warn.adb 5 Apr 2004 14:57:41 -0000 1.13
+++ sem_warn.adb 29 Apr 2004 14:40:34 -0000
@@ -384,8 +384,7 @@ package body Sem_Warn is
then
null;
- elsif Warn_On_No_Value_Assigned
- and then Present (UR)
+ elsif Present (UR)
and then Is_Access_Type (Etype (E1))
then
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.12
diff -u -p -r1.12 switch-c.adb
--- switch-c.adb 1 Apr 2004 10:04:40 -0000 1.12
+++ switch-c.adb 29 Apr 2004 14:40:34 -0000
@@ -386,7 +386,7 @@ package body Switch.C is
when 'I' =>
Ptr := Ptr + 1;
- Scan_Pos (Switch_Chars, 999, Ptr, Multiple_Unit_Index);
+ Scan_Pos (Switch_Chars, Max, Ptr, Multiple_Unit_Index);
-- -gnatem (mapping file)
Index: gnat_ugn.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat_ugn.texi,v
retrieving revision 1.5
diff -u -p -r1.5 gnat_ugn.texi
--- gnat_ugn.texi 28 Apr 2004 14:57:15 -0000 1.5
+++ gnat_ugn.texi 29 Apr 2004 14:40:35 -0000
@@ -6935,7 +6935,7 @@ See also the packages @code{GNAT.Traceba
@ifclear vms
Note that on x86 ports, you must not use @option{-fomit-frame-pointer}
@code{gcc} option.
-@end ifclear vms
+@end ifclear
@item ^-F^/FORCE_ELABS_FLAGS^
@cindex @option{^-F^/FORCE_ELABS_FLAGS^} (@command{gnatbind})
Index: gnat_rm.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat_rm.texi,v
retrieving revision 1.19
diff -u -p -r1.19 gnat_rm.texi
--- gnat_rm.texi 23 Apr 2004 10:58:32 -0000 1.19
+++ gnat_rm.texi 29 Apr 2004 14:40:35 -0000
@@ -1308,16 +1308,17 @@ debug procedures in the middle of declar
Syntax:
@smallexample @c ada
-pragma Elaboration_Checks (RM | Static);
+pragma Elaboration_Checks (Dynamic | Static);
@end smallexample
@noindent
This is a configuration pragma that provides control over the
elaboration model used by the compilation affected by the
-pragma. If the parameter is RM, then the dynamic elaboration
+pragma. If the parameter is @code{Dynamic},
+then the dynamic elaboration
model described in the Ada Reference Manual is used, as though
the @code{-gnatE} switch had been specified on the command
-line. If the parameter is Static, then the default GNAT static
+line. If the parameter is @code{Static}, then the default GNAT static
model is used. This configuration pragma overrides the setting
of the command line. For full details on the elaboration models
used by the GNAT compiler, see section ``Elaboration Order
Index: s-addope.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-addope.adb,v
retrieving revision 1.1
diff -u -p -r1.1 s-addope.adb
--- s-addope.adb 23 Apr 2004 10:58:30 -0000 1.1
+++ s-addope.adb 29 Apr 2004 14:40:35 -0000
@@ -81,7 +81,7 @@ package body System.Address_Operations i
function ModA (Left, Right : Address) return Address is
begin
- return A (I (Left) and I (Right));
+ return A (I (Left) mod I (Right));
end ModA;
---------
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-27 11:21 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-27 11:21 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-04-27 Ed Schonberg <schonberg@gnat.com>
* a-wtmoio.ads: Formal type must be a modular type, not a signed
integer type.
2004-04-27 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, case object): Call
__builtin_update_setjmp_buf.
* gigi.h (update_setjmp_buf): Deleted.
(ADT_update_setjmp_buf_decl, update_setjmp_buf_decl): New.
* misc.c: (update_setjmp_buf): Deleted.
* trans.c (gnat_to_gnu): Call do_pending_stack_adjust and emit_queue
around block of RTL.
* utils.c (init_gigi_decls): Initialize update_setjmp_buf.
--
Index: a-wtmoio.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-wtmoio.ads,v
retrieving revision 1.4
diff -u -p -r1.4 a-wtmoio.ads
--- a-wtmoio.ads 24 Apr 2003 17:53:57 -0000 1.4
+++ a-wtmoio.ads 27 Apr 2004 09:40:26 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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 --
@@ -42,7 +42,7 @@
-- difference in semantics so that it is invisible to the Ada programmer.
private generic
- type Num is range <>;
+ type Num is mod <>;
package Ada.Wide_Text_IO.Modular_IO is
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.40
diff -u -p -r1.40 decl.c
--- decl.c 23 Apr 2004 10:58:30 -0000 1.40
+++ decl.c 27 Apr 2004 09:40:27 -0000
@@ -1048,7 +1048,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
|| (flag_stack_check && ! STACK_CHECK_BUILTIN
&& 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
STACK_CHECK_MAX_VAR_SIZE))))
- update_setjmp_buf (TREE_VALUE (gnu_block_stack));
+ expand_expr_stmt
+ (build_call_1_expr (update_setjmp_buf_decl,
+ build_unary_op
+ (ADDR_EXPR, NULL_TREE,
+ TREE_VALUE (gnu_block_stack))));
/* If this is a public constant or we're not optimizing and we're not
making a VAR_DECL for it, make one just for export or debugger
Index: gigi.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gigi.h,v
retrieving revision 1.22
diff -u -p -r1.22 gigi.h
--- gigi.h 21 Apr 2004 10:10:31 -0000 1.22
+++ gigi.h 27 Apr 2004 09:40:27 -0000
@@ -58,10 +58,6 @@ extern tree emit_stack_check (tree);
/* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
extern tree make_transform_expr (Node_Id);
-/* Update the setjmp buffer BUF with the current stack pointer. We assume
- here that a __builtin_setjmp was done to BUF. */
-extern void update_setjmp_buf (tree);
-
/* GNU_TYPE is a type. Determine if it should be passed by reference by
default. */
extern int default_pass_by_ref (tree);
@@ -346,6 +342,7 @@ enum standard_datatypes
ADT_get_excptr_decl,
ADT_setjmp_decl,
ADT_longjmp_decl,
+ ADT_update_setjmp_buf_decl,
ADT_raise_nodefer_decl,
ADT_begin_handler_decl,
ADT_end_handler_decl,
@@ -369,6 +366,7 @@ extern GTY(()) tree gnat_raise_decls[(in
#define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl]
#define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl]
#define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl]
+#define update_setjmp_buf_decl gnat_std_decls[(int) ADT_update_setjmp_buf_decl]
#define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl]
#define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl]
#define end_handler_decl gnat_std_decls[(int) ADT_end_handler_decl]
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/misc.c,v
retrieving revision 1.79
diff -u -p -r1.79 misc.c
--- misc.c 19 Mar 2004 14:34:47 -0000 1.79
+++ misc.c 27 Apr 2004 09:40:27 -0000
@@ -671,40 +671,6 @@ make_transform_expr (Node_Id gnat_node)
return gnu_result;
}
\f
-/* Update the setjmp buffer BUF with the current stack pointer. We assume
- here that a __builtin_setjmp was done to BUF. */
-
-void
-update_setjmp_buf (tree buf)
-{
- enum machine_mode sa_mode = Pmode;
- rtx stack_save;
-
-#ifdef HAVE_save_stack_nonlocal
- if (HAVE_save_stack_nonlocal)
- sa_mode = insn_data[(int) CODE_FOR_save_stack_nonlocal].operand[0].mode;
-#endif
-#ifdef STACK_SAVEAREA_MODE
- sa_mode = STACK_SAVEAREA_MODE (SAVE_NONLOCAL);
-#endif
-
- stack_save
- = gen_rtx_MEM (sa_mode,
- memory_address
- (sa_mode,
- plus_constant (expand_expr
- (build_unary_op (ADDR_EXPR, NULL_TREE, buf),
- NULL_RTX, VOIDmode, 0),
- 2 * GET_MODE_SIZE (Pmode))));
-
-#ifdef HAVE_setjmp
- if (HAVE_setjmp)
- emit_insn (gen_setjmp ());
-#endif
-
- emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX);
-}
-\f
/* These routines are used in conjunction with GCC exception handling. */
/* Map compile-time to run-time tree for GCC exception handling scheme. */
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.54
diff -u -p -r1.54 trans.c
--- trans.c 23 Apr 2004 10:58:31 -0000 1.54
+++ trans.c 27 Apr 2004 09:40:27 -0000
@@ -265,6 +265,8 @@ gnat_to_gnu (Node_Id gnat_node)
we do generates RTL and returns error_mark_node. */
if (!global_bindings_p ())
{
+ do_pending_stack_adjust ();
+ emit_queue ();
start_sequence ();
emit_note (NOTE_INSN_DELETED);
made_sequence = true;
@@ -285,14 +287,19 @@ gnat_to_gnu (Node_Id gnat_node)
gigi_abort (303);
}
+ do_pending_stack_adjust ();
+ emit_queue ();
gnu_root = make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()),
gnat_node);
end_sequence ();
}
else if (made_sequence)
{
- rtx insns = first_nondeleted_insn (get_insns ());
+ rtx insns;
+ do_pending_stack_adjust ();
+ emit_queue ();
+ insns = first_nondeleted_insn (get_insns ());
end_sequence ();
if (insns)
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.54
diff -u -p -r1.54 utils.c
--- utils.c 23 Apr 2004 10:58:31 -0000 1.54
+++ utils.c 27 Apr 2004 09:40:27 -0000
@@ -688,6 +688,18 @@ init_gigi_decls (tree long_long_float_ty
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
+ /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
+ address. */
+ update_setjmp_buf_decl
+ = create_subprog_decl
+ (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+ DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
+ DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
+
main_identifier_node = get_identifier ("main");
}
\f
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-26 12:30 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-26 12:30 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-04-26 Thomas Quinot <quinot@act-europe.fr>
* sem_dist.adb, exp_dist.adb: When constructing a RAS value for a local
subprogram for which no pragma All_Calls_Remote applies, store the
address of the real subprogram in the underlying record type, so local
dereferences do not go through the PCS.
2004-04-26 Robert Dewar <dewar@gnat.com>
* i-c.ads: Add some type qualifications to avoid ambiguities when
compiling with s-auxdec.ads and a non-private address type.
2004-04-26 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.rtl: Fix error in previous check-in:
Add s-addope.o to non tasking object list (rather than tasking object
list).
2004-04-26 Javier Miranda <miranda@gnat.com>
* sem_aggr.adb: Fix typo in comments
(Resolve_Aggr_Expr): Propagate the type to the nested aggregate.
Required to check the null-exclusion attribute.
* sem_attr.adb (Resolve_Attribute): Check the accessibility level in
case of anonymous access types in record and array components. For a
component definition the level is the same of the enclosing composite
type.
* sem_ch3.adb (Analyze_Component_Declaration): In case of components
that are anonymous access types the level of accessibility depends on
the enclosing type declaration. In order to have this information, set
the scope of the anonymous access type to the enclosing record type
declaration.
(Array_Type_Declaration): In case of components that are anonymous
access types the level of accessibility depends on the enclosing type
declaration. In order to have this information, set the scope of the
anonymous access type to the enclosing array type declaration.
* sem_ch3.adb (Array_Type_Declaration): Set the scope of the anonymous
access type.
* sem_ch8.adb (Analyze_Object_Renaming): Add check to verify that
renaming of anonymous access-to-constant types allowed if and only if
the renamed object is access-to-constant.
* sem_util.adb (Type_Access_Level): In case of anonymous access types
that are component_definition or discriminants of a nonlimited type,
the level is the same as that of the enclosing component type.
2004-04-26 Sergey Rybin <rybin@act-europe.fr>
* sem_elim.adb: Some minor code reorganization from code reading. Fix
misprint in the function name (File_Name_Match).
--
Index: exp_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dist.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_dist.adb
--- exp_dist.adb 23 Apr 2004 10:58:30 -0000 1.10
+++ exp_dist.adb 26 Apr 2004 10:24:48 -0000
@@ -1193,15 +1193,14 @@ package body Exp_Dist is
Proc_Decls : constant List_Id := New_List;
Proc_Statements : constant List_Id := New_List;
- Proc_Spec : Node_Id;
-
- Proc : Node_Id;
-
- Param : Node_Id;
- Package_Name : Node_Id;
- Subp_Id : Node_Id;
- Asynch_P : Node_Id;
- Return_Value : Node_Id;
+ Proc_Spec : Node_Id;
+ Proc : Node_Id;
+ Local_Addr : Entity_Id;
+ Package_Name : Entity_Id;
+ Subp_Id : Entity_Id;
+ Asynch_P : Entity_Id;
+ Origin : Entity_Id;
+ Return_Value : Entity_Id;
All_Calls_Remote : Entity_Id;
-- True if an All_Calls_Remote pragma applies to the RCI unit
@@ -1210,65 +1209,106 @@ package body Exp_Dist is
Loc : constant Source_Ptr := Sloc (N);
- procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id);
- -- Set a field name for the return value
-
- procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id)
+ function Set_Field
+ (Field_Name : Name_Id;
+ Value : Node_Id) return Node_Id;
+ -- Construct an assignment that sets the named component in the
+ -- returned record
+
+ ---------------
+ -- Set_Field --
+ ---------------
+
+ function Set_Field
+ (Field_Name : Name_Id;
+ Value : Node_Id) return Node_Id
is
begin
- Append_To (Proc_Statements,
+ return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Return_Value, Loc),
Selector_Name => Make_Identifier (Loc, Field_Name)),
- Expression => Value));
+ Expression => Value);
end Set_Field;
-- Start of processing for Add_RAS_Access_Attribute
begin
- Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
- Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
- Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Local_Addr := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
+ Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
+ Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+ Origin := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
All_Calls_Remote :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
-- Create the object which will be returned of type Fat_Type
- Append_To (Proc_Decls,
+ Append_List_To (Proc_Decls, New_List (
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Origin,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc)))),
+
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Value,
Object_Definition =>
- New_Occurrence_Of (Fat_Type, Loc)));
+ New_Occurrence_Of (Fat_Type, Loc))));
-- Initialize the fields of the record type with the appropriate data
- Set_Field (Name_Ras,
- OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc)));
+ Append_List_To (Proc_Statements, New_List (
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Not (Loc,
+ New_Occurrence_Of (All_Calls_Remote, Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Origin, Loc),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ New_Occurrence_Of (
+ RTE (RE_Get_Local_Partition_Id), Loc)))),
+
+ Then_Statements => New_List (
+ Set_Field (Name_Ras,
+ OK_Convert_To (RTE (RE_Unsigned_64),
+ New_Occurrence_Of (Local_Addr, Loc)))),
+
+ Else_Statements => New_List (
+ Set_Field (Name_Ras,
+ Make_Integer_Literal (Loc, Uint_0)))),
+
+ Set_Field (Name_Origin,
+ Unchecked_Convert_To (Standard_Integer,
+ New_Occurrence_Of (Origin, Loc))),
- Set_Field (Name_Origin,
- Unchecked_Convert_To (Standard_Integer,
+ Set_Field (Name_Receiver,
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
+ New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc)))));
-
- Set_Field (Name_Receiver,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc))));
+ New_Occurrence_Of (Package_Name, Loc)))),
- Set_Field (Name_Subp_Id,
- New_Occurrence_Of (Subp_Id, Loc));
+ Set_Field (Name_Subp_Id,
+ New_Occurrence_Of (Subp_Id, Loc)),
- Set_Field (Name_Async,
- New_Occurrence_Of (Asynch_P, Loc));
+ Set_Field (Name_Async,
+ New_Occurrence_Of (Asynch_P, Loc))));
-- Return the newly created value
@@ -1286,7 +1326,7 @@ package body Exp_Dist is
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier => Param,
+ Defining_Identifier => Local_Addr,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Index: i-c.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/i-c.ads,v
retrieving revision 1.4
diff -u -p -r1.4 i-c.ads
--- i-c.ads 21 Oct 2003 13:42:08 -0000 1.4
+++ i-c.ads 26 Apr 2004 10:24:48 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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 --
@@ -50,10 +50,14 @@ pragma Pure (C);
-- Signed and Unsigned Integers. Note that in GNAT, we have ensured that
-- the standard predefined Ada types correspond to the standard C types
+ -- Note: the Integer qualifications used in the declaration of type long
+ -- avoid ambiguities when compiling in the presence of s-auxdec.ads and
+ -- a non-private system.address type.
+
type int is new Integer;
type short is new Short_Integer;
- type long is range -(2 ** (System.Parameters.long_bits - 1))
- .. +(2 ** (System.Parameters.long_bits - 1)) - 1;
+ type long is range -(2 ** (System.Parameters.long_bits - Integer'(1)))
+ .. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1;
type signed_char is range SCHAR_MIN .. SCHAR_MAX;
for signed_char'Size use CHAR_BIT;
@@ -67,9 +71,13 @@ pragma Pure (C);
subtype plain_char is unsigned_char; -- ??? should be parametrized
+ -- Note: the Integer qualifications used in the declaration of ptrdiff_t
+ -- avoid ambiguities when compiling in the presence of s-auxdec.ads and
+ -- a non-private system.address type.
+
type ptrdiff_t is
- range -(2 ** (Standard'Address_Size - 1)) ..
- +(2 ** (Standard'Address_Size - 1) - 1);
+ range -(2 ** (Standard'Address_Size - Integer'(1))) ..
+ +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
type size_t is mod 2 ** Standard'Address_Size;
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.9
diff -u -p -r1.9 Makefile.rtl
--- Makefile.rtl 23 Apr 2004 10:58:30 -0000 1.9
+++ Makefile.rtl 26 Apr 2004 10:24:48 -0000
@@ -40,7 +40,6 @@ GNATRTL_TASKING_OBJS= \
g-semaph$(objext) \
g-signal$(objext) \
g-thread$(objext) \
- s-addope$(objext) \
s-asthan$(objext) \
s-inmaop$(objext) \
s-interr$(objext) \
@@ -271,6 +270,7 @@ GNATRTL_NONTASKING_OBJS= \
ioexcept$(objext) \
machcode$(objext) \
s-addima$(objext) \
+ s-addope$(objext) \
s-arit64$(objext) \
s-assert$(objext) \
s-atacco$(objext) \
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_aggr.adb
--- sem_aggr.adb 29 Mar 2004 12:03:16 -0000 1.13
+++ sem_aggr.adb 26 Apr 2004 10:24:48 -0000
@@ -960,7 +960,7 @@ package body Sem_Aggr is
Aggr_Typ : constant Entity_Id := Etype (Typ);
-- This is the unconstrained array type, which is the type
- -- against which the aggregate is to be resoved. Typ itself
+ -- against which the aggregate is to be resolved. Typ itself
-- is the array type of the context which may not be the same
-- subtype as the subtype for the final aggregate.
@@ -977,7 +977,7 @@ package body Sem_Aggr is
-- formal parameter. Consequently we also need to test for
-- N_Procedure_Call_Statement or N_Function_Call.
- Set_Etype (N, Aggr_Typ); -- may be overridden later on.
+ Set_Etype (N, Aggr_Typ); -- may be overridden later on
-- Ada 0Y (AI-231): Propagate the null_exclusion attribute to the
-- components of the array aggregate
@@ -1398,6 +1398,12 @@ package body Sem_Aggr is
return Failure;
end if;
end if;
+
+ -- Ada 0Y (AI-231): Propagate the type to the nested aggregate.
+ -- Required to check the null-exclusion attribute (if present).
+ -- This value may be overridden later on.
+
+ Set_Etype (Expr, Etype (N));
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.23
diff -u -p -r1.23 sem_attr.adb
--- sem_attr.adb 21 Apr 2004 10:10:31 -0000 1.23
+++ sem_attr.adb 26 Apr 2004 10:24:49 -0000
@@ -6645,8 +6645,37 @@ package body Sem_Attr is
or else
Attr_Id = Attribute_Unchecked_Access)
and then (Ekind (Btyp) = E_General_Access_Type
- or else Ekind (Btyp) = E_Anonymous_Access_Type)
+ or else Ekind (Btyp) = E_Anonymous_Access_Type)
then
+ -- Ada 0Y (AI-230): Check the accessibility of anonymous access
+ -- types in record and array components. For a component defini
+ -- tion the level is the same of the enclosing composite type.
+
+ if Extensions_Allowed
+ and then Ekind (Btyp) = E_Anonymous_Access_Type
+ and then (Is_Array_Type (Scope (Btyp))
+ or else Ekind (Scope (Btyp)) = E_Record_Type)
+ and then Object_Access_Level (P)
+ > Type_Access_Level (Btyp)
+ then
+ -- In an instance, this is a runtime check, but one we
+ -- know will fail, so generate an appropriate warning.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?non-local pointer cannot point to local object", P);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", P);
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Typ);
+ else
+ Error_Msg_N
+ ("non-local pointer cannot point to local object", P);
+ end if;
+ end if;
+
if Is_Dependent_Component_Of_Mutable_Object (P) then
Error_Msg_N
("illegal attribute for discriminant-dependent component",
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.38
diff -u -p -r1.38 sem_ch3.adb
--- sem_ch3.adb 21 Apr 2004 10:10:31 -0000 1.38
+++ sem_ch3.adb 26 Apr 2004 10:24:49 -0000
@@ -993,6 +993,12 @@ package body Sem_Ch3 is
(Related_Nod => N,
N => Access_Definition (Component_Definition (N)));
+ -- Ada 0Y (AI-230): In case of components that are anonymous access
+ -- types the level of accessibility depends on the enclosing type
+ -- declaration
+
+ Set_Scope (T, Current_Scope); -- Ada 0Y (AI-230)
+
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
@@ -2992,6 +2998,12 @@ package body Sem_Ch3 is
Element_Type := Access_Definition
(Related_Nod => Related_Id,
N => Access_Definition (Component_Def));
+
+ -- Ada 0Y (AI-230): In case of components that are anonymous access
+ -- types the level of accessibility depends on the enclosing type
+ -- declaration
+
+ Set_Scope (Element_Type, T); -- Ada 0Y (AI-230)
-- Ada 0Y (AI-254)
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.19
diff -u -p -r1.19 sem_ch8.adb
--- sem_ch8.adb 19 Apr 2004 15:20:06 -0000 1.19
+++ sem_ch8.adb 26 Apr 2004 10:24:49 -0000
@@ -687,17 +687,25 @@ package body Sem_Ch8 is
elsif Present (Access_Definition (N)) then
- if Null_Exclusion_Present (Access_Definition (N)) then
- Error_Msg_N ("(Ada 0Y): null-excluding attribute ignored "
- & "('R'M 8.5.1(6))?", N);
- Set_Null_Exclusion_Present (Access_Definition (N), False);
- end if;
-
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (N));
+
Analyze_And_Resolve (Nam, T);
+ -- Ada 0Y (AI-230): Renaming of anonymous access-to-constant types
+ -- allowed if and only if the renamed object is access-to-constant
+
+ if Constant_Present (Access_Definition (N))
+ and then not Is_Access_Constant (Etype (Nam))
+ then
+ Error_Msg_N ("(Ada 0Y): the renamed object is not "
+ & "access-to-constant ('R'M 8.5.1(6))", N);
+
+ elsif Null_Exclusion_Present (Access_Definition (N)) then
+ Error_Msg_N ("(Ada 0Y): null-excluding attribute ignored "
+ & "('R'M 8.5.1(6))?", N);
+ end if;
else
pragma Assert (False);
null;
Index: sem_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_dist.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_dist.adb
--- sem_dist.adb 23 Apr 2004 10:58:31 -0000 1.10
+++ sem_dist.adb 26 Apr 2004 10:24:49 -0000
@@ -295,7 +295,7 @@ package body Sem_Dist is
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
- Parameter : Node_Id;
+ Local_Addr : Node_Id;
begin
-- Check if we have to expand the access attribute
@@ -346,14 +346,17 @@ package body Sem_Dist is
All_Calls_Remote_E := Standard_False;
end if;
- Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
+ Local_Addr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Remote_Subp, Loc),
+ Attribute_Name => Name_Address);
Tick_Access_Conv_Call :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Attribute_Subp, Loc),
Parameter_Associations =>
New_List (
- Parameter,
+ Local_Addr,
Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc),
Index: sem_elim.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elim.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_elim.adb
--- sem_elim.adb 23 Apr 2004 10:58:31 -0000 1.11
+++ sem_elim.adb 26 Apr 2004 10:24:49 -0000
@@ -376,7 +376,7 @@ package body Sem_Elim is
P : Source_Ptr;
Sindex : Source_File_Index;
- function File_Mame_Match return Boolean;
+ function File_Name_Match return Boolean;
-- This function is supposed to be called when Idx points
-- to the beginning of the new file name, and Name_Buffer
-- is set to contain the name of the proper source file
@@ -436,45 +436,64 @@ package body Sem_Elim is
end if;
end Different_Trace_Lengths;
- function File_Mame_Match return Boolean is
- Tmp_Idx : Positive := 1;
- End_Idx : Positive := 1;
- -- Initializations are to stop warnings
-
- -- But are warnings possibly valid ???
- -- Why are loops below guaranteed to exit ???
+ ---------------------
+ -- File_Name_Match --
+ ---------------------
+
+ function File_Name_Match return Boolean is
+ Tmp_Idx : Natural;
+ End_Idx : Natural;
begin
if Idx = 0 then
return False;
end if;
- for J in Idx .. Last loop
- if Sloc_Trace (J) = ':' then
- Tmp_Idx := J - 1;
+ -- Find first colon. If no colon, then return False.
+ -- If there is a colon, Tmp_Idx is set to point just
+ -- before the colon.
+
+ Tmp_Idx := Idx - 1;
+ loop
+ if Tmp_Idx >= Last then
+ return False;
+ elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
exit;
+ else
+ Tmp_Idx := Tmp_Idx + 1;
end if;
end loop;
- for J in reverse Idx .. Tmp_Idx loop
- if Sloc_Trace (J) /= ' ' then
- End_Idx := J;
+ -- Find last non-space before this colon. If there
+ -- is no no space character before this colon, then
+ -- return False. Otherwise, End_Idx set to point to
+ -- this non-space character.
+
+ End_Idx := Tmp_Idx;
+ loop
+ if End_Idx < Idx then
+ return False;
+ elsif Sloc_Trace (End_Idx) /= ' ' then
exit;
+ else
+ End_Idx := End_Idx - 1;
end if;
end loop;
+ -- Now see if file name matches what is in Name_Buffer
+ -- and if so, step Idx past it and return True. If the
+ -- name does not match, return False.
+
if Sloc_Trace (Idx .. End_Idx) =
Name_Buffer (1 .. Name_Len)
then
Idx := Tmp_Idx + 2;
-
Idx := Skip_Spaces;
-
return True;
else
return False;
end if;
- end File_Mame_Match;
+ end File_Name_Match;
--------------------
-- Line_Num_Match --
@@ -548,7 +567,7 @@ package body Sem_Elim is
Idx := Skip_Spaces;
while Idx > 0 loop
- if not File_Mame_Match then
+ if not File_Name_Match then
goto Continue;
elsif not Line_Num_Match then
goto Continue;
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.28
diff -u -p -r1.28 sem_util.adb
--- sem_util.adb 21 Apr 2004 10:10:32 -0000 1.28
+++ sem_util.adb 26 Apr 2004 10:24:49 -0000
@@ -6101,9 +6101,16 @@ package body Sem_Util is
-- declared at the library level to ensure that names such as
-- X.all'access don't fail static accessibility checks.
+ -- Ada 0Y (AI-230): In case of anonymous access types that are
+ -- component_definition or discriminants of a nonlimited type,
+ -- the level is the same as that of the enclosing component type.
+
Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
- if Ekind (Btyp) = E_Anonymous_Access_Type then
+ if Ekind (Btyp) = E_Anonymous_Access_Type
+ and then not Is_Array_Type (Scope (Btyp)) -- Ada 0Y (AI-230)
+ and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 0Y (AI-230)
+ then
return Scope_Depth (Standard_Standard);
end if;
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-23 10:59 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-23 10:59 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3066 bytes --]
Tested on x86-linux
--
2004-04-23 Emmanuel Briot <briot@act-europe.fr>
* adaint.c (__gnat_try_lock): No longer requires that the parent
directory be writable, the directory itself is enough.
(gnat_is_absolute_path): Change profile, so that the call from
GNAT.OS_Lib can be made more efficient.
* adaint.h (gnat_is_absolute_path): Change profile, so that the call
from GNAT.OS_Lib can be made more efficient.
* g-os_lib.adb (Is_Absolute_Path): More efficient implementation, avoid
one copy of the file name. Found by code reading.
2004-04-23 Vincent Celier <celier@gnat.com>
* gnat_ugn.texi: Add documentation for gnatmake switch -eL
Correct documentation on gnatmake switches transmitted to the compiler
* ali.ads: Minor comment fix
2004-04-23 Javier Miranda <miranda@gnat.com>
* sem_ch6.adb: (Confirming Types): Code cleanup
* decl.c (gnat_to_gnu_entity): Give support to anonymous access to
subprogram types: E_Anonymous_Access_Subprogram_Type and
E_Anonymous_Access_Protected_Subprogram_Type.
2004-04-23 Thomas Quinot <quinot@act-europe.fr>
* sem_dist.adb: Add a new paramter to the RAS_Access TSS indicating
whether a pragma All_Calls_Remote applies to the subprogram on which
'Access is taken.
No functional change is introduced by this revision; the new parameter
will be used to allow calls to local RCI subprograms to be optimized
to not use the PCS in the case where no pragma All_Calls_Remote applies,
as is already done in the PolyORB implementation of the DSA.
* exp_dist.adb: Add a new paramter to the RAS_Access TSS indicating
whether a pragma All_Calls_Remote applies to the subprogram on which
'Access is taken.
No functional change is introduced by this revision; the new parameter
will be used to allow calls to local RCI subprograms to be optimized
to not use the PCS in the case where no pragma All_Calls_Remote applies,
as is already done in the PolyORB implementation of the DSA.
2004-04-23 Robert Dewar <dewar@gnat.com>
* Makefile.rtl: Add entry for s-addope.o in run time library list
* Make-lang.in: Add entry for s-addope.o to GNAT1 objects
* s-addope.ads, s-addope.adb: New files.
* s-carsi8.adb, s-carun8.adb, s-casi16.adb, s-casi32.adb,
s-casi64.adb, s-caun16.adb, s-caun32.adb, s-caun64.adb,
s-finimp.adb, s-geveop.adb, s-stoele.adb: Modifications to allow
System.Address to be non-private and signed.
* sem_elim.adb: Minor reformatting (fairly extensive)
Some minor code reorganization from code reading
Add a couple of ??? comments
2004-04-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform, build_unit_elab): Don't call getdecls.
(tree_transform, case N_If_Statement): Remove non-determinism.
* utils.c (begin_subprog_body): Just set DECL_CONTEXT in PARM_DECL.
2004-04-23 Sergey Rybin <rybin@act-europe.fr>
* gnat_rm.texi: Small fixes in the changes made in the 'pragma
Eliminate' section.
* snames.ads, snames.adb: Remove Name_Homonym_Number (Homonym_Number is
no longer used as a parameter name for Eliminate pragma).
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 24863 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-21 10:13 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-21 10:13 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3740 bytes --]
Tested on x86-linux
--
2004-04-21 Pascal Obry <obry@gnat.com>
* adaint.c (__gnat_portable_spawn): Quote first argument (argv[0])
passed to spawnvp() to properly handle program pathname with spaces on
Win32.
2004-04-21 Emmanuel Briot <briot@act-europe.fr>
* g-debpoo.adb (Print_Info): Avoid extra work if Display_Slots is False.
(Allocate, Deallocate, Free_Physically): Make sure the tasks are
unlocked in case of exceptions.
2004-04-21 Joel Brobecker <brobecker@gnat.com>
* gigi.h (get_target_no_dollar_in_label): Remove extern declaration.
This function does not exist anymore.
2004-04-21 Thomas Quinot <quinot@act-europe.fr>
* gnatbind.adb, gnatlink.adb: Update name of imported C symbol.
* link.c: Move variables to the __gnat name space.
* Makefile.in: list link.o explicitly when needed.
* mlib.adb: Remove pragma Linker_Option for "link.o" from mlib.
2004-04-21 Javier Miranda <miranda@gnat.com>
* einfo.adb (Original_Access_Type): New subprogram
(Set_Original_Access_Type): New subprogram
(Write_Field21_Name): Write the name of the new field
* einfo.ads (Original_Access_Type): New field present in access to
subprogram types.
Addition of two new entities: E_Anonymous_Access_Subprogram_Type, and
E_Anonymous_Access_Protected_Subprogram_Type.
* lib-xref.adb (Output_One_Ref): Give support to anonymous access to
subprogram types.
* lib-xref.ads (Xref_Entity_Letters): Initialize values corresponding
to anonymous access to subprogram types.
* sem_attr.adb (Resolve_Attribute): Give support to anonymous access
to subprogram types.
* sem_ch3.adb (Access_Definition): Complete decoration of entities
corresponding to anonymous access to subprogram types.
(Analyze_Component_Declaration): Add new actual to the call to
subprogram replace_anonymous_access_to_protected_subprogram.
(Array_Type_Declaration): Add new actual to the call to subprogram
replace_anonymous_access_to_protected_subprogram.
(Process_Discriminants): Add new actual to the call to subprogram
replace_anonymous_access_to_protected_subprogram.
(Replace_Anonymous_Access_To_Protected_Subprogram): New formal.
* sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New
formal.
* sem_ch6.adb, sem_type.adb, sem_res.adb: Give support to anonymous
access to subprogram types.
* sem_util.adb (Has_Declarations): Addition of package_specification
nodes.
2004-04-21 Ed Schonberg <schonberg@gnat.com>
* sem_prag.adb (Make_Inline): If subprogram is a renaming, propagate
inlined flags to renamed entity only if in current unit.
2004-04-21 Thomas Quinot <quinot@act-europe.fr>
* s-parint.ads: Add DSA implementation marker.
* rtsfind.ads, rtsfind.adb, snames.ads, snames.adb, s-rpc.adb: Use the
value of System.Partition_Interface.DSA_Implementation to determine
what version of the distributed systems annex is available (no
implementation, GLADE, or PolyORB).
2004-04-21 Joel Brobecker <brobecker@gnat.com>
* targtyps.c (get_target_no_dollar_in_label): Remove, no longer used.
2004-04-21 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils.c (convert, case CONSTRUCTOR, COMPONENT_REF): Do not make node
with new type if alias sets differ.
Fixes ACATS c41103b.
2004-04-21 Vincent Celier <celier@gnat.com>
* prj.ads: Remove FORTRAN as an accepted language: not tested yet.
Add array Lang_Args for the language specific compiling argument
switches.
* gnat_ugn.texi: Explain in more details when a library is rebuilt.
2004-04-21 Sergey Rybin <rybin@act-europe.fr>
* gnat_rm.texi: Update the descripton of the Eliminate pragma
according to the recent changes in the format of the parameters of the
pragma (replacing Homonym_Number with Source_Location).
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 27769 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* Committed: Ada updates
@ 2004-04-19 15:23 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-19 15:23 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 14160 bytes --]
Tested on x86-linux
--
2004-04-19 Arnaud Charlet <charlet@act-europe.fr>
* 5isystem.ads: Removed, unused.
* gnat_rm.texi: Redo 1.13 change.
2004-04-19 Robert Dewar <dewar@gnat.com>
* s-stoele.ads: Clean up definition of Storage_Offset (the new
definition is cleaner, avoids the kludge of explicit Standard operator
references, and also is consistent with a visible System.Address with
no visible operations.
* s-geveop.adb: Add declarations to avoid assumption of visible
operations on type System.Address (since these might not be available
if Address is a non-private type for which the operations
are made abstract).
* sem_eval.adb: Minor reformatting
* s-carsi8.ads, s-carun8.ads, s-casi16.ads, s-casi32.ads,
s-casi64.ads, s-caun16.ads, s-caun32.ads, s-caun64.ads: Minor
reformatting (new function spec format).
* s-auxdec.adb, s-carsi8.adb, s-carun8.adb, s-casi16.adb,
s-casi32.adb, s-casi64.adb, s-caun16.adb, s-caun32.adb,
s-caun64.adb: Add declarations to avoid assumption of visible
operations on type System.Address (since these might not be available
if Address is a non-private type for which the operations are made
abstract).
* lib.ads, lib.adb (Synchronize_Serial_Number): New procedure.
* exp_intr.adb: Minor comment update
* exp_aggr.adb, exp_attr.adb, exp_ch13.adb: Minor reformatting.
* 5omastop.adb: Add declarations to avoid assumption of visible
operations on type System.Address (since these might not be available
if Address is a non-private type for which the operations
are made abstract).
2004-04-19 Vincent Celier <celier@gnat.com>
* switch-m.adb: (Scan_Make_Switches): Process new switch -eL
* prj-pars.ads (Parse): New Boolean parameter Process_Languages,
defaulted to Ada.
* prj-proc.adb (Process): New Boolean parameter Process_Languages,
defaulted to Ada.
Call Check with Process_Languages.
(Check): New Boolean parameter Process_Languages. Call Recursive_Check
with Process_Languages.
(Recursive_Check): New Boolean parameter Process_Languages. Call
Nmsc.Ada_Check or Nmsc.Other_Languages_Check according to
Process_Languages.
* prj-proc.ads (Process): New Boolean parameter Process_Languages,
* prj-util.ads, prj-util.adb (Executable_Of): New Boolean
parameter Ada_Main, defaulted to True.
Check for Ada specific characteristics only when Ada_Main is True.
* opt.ads: (Follow_Links): New Boolean flag for gnatmake
* prj.adb: (Project_Empty): Add new Project_Data components.
* prj.ads: New types and tables for non Ada languages.
(Project_Data): New components Languages, Impl_Suffixes,
First_Other_Source, Last_Other_Source, Imported_Directories_Switches,
Include_Path, Include_Data_Set.
* prj-env.ads, prj-env.adb: Minor reformatting
* prj-nmsc.ads, prj-nmsc.adb: (Other_Languages_Check): New procedure
Put subprograms in alphabetical order
* prj-pars.adb (Parse): New Boolean parameter Process_Languages,
defaulted to Ada; Call Prj.Proc.Process with Process_Languages and
Opt.Follow_Links.
* mlib-prj.adb: Back out modification in last version, as they are
incorrect.
(Build_Library.Check_Libs): Remove useless pragma Warnings (Off)
* make.adb: (Mains): Moved to package Makeutl
(Linker_Opts): Moved to package Makeutl
(Is_External_Assignment): Moved to package Makeutl
(Test_If_Relative_Path): Moved to package Makeutl
(Gnatmake): Move sorting of linker options to function
Makeutl.Linker_Options_Switches.
* Makefile.in: Add makeutl.o to the object files for gnatmake
* makeusg.adb: Add line for new switch -eL.
* gnatls.adb (Image): New function.
(Output_Unit): If in verbose mode, output the list of restrictions
specified by pragmas Restrictions.
* 5bml-tgt.adb, 5vml-tgt.adb (Build_Dynamic_Library): Do not use
Text_IO.
* a-calend.adb (Split): Shift the date by multiple of 56 years, if
needed, to put it in the range 1970 (included) - 2026 (excluded).
(Time_Of): Do not shift Unix_Min_Year (1970).
Shift the date by multiple of 56 years, if needed, to put it in the
range 1970 (included) - 2026 (excluded).
* adaint.h, adaint.c (__gnat_set_executable): New function.
2004-04-19 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform, case N_Subprogram_Body): Temporarily push
and pop GC context.
(tree_transform, case N_Procedure_Call): Fix typo in setting TREE_TYPE.
(tree_transform, case N_Label): Don't set LABEL_STMT_FIRST_IN_EH.
(tree_transform, case N_Procedure_Call_Statement): Build a tree.
(tree_transform, case N_Code_Statement): Likewise.
(gnat_expand_stmt, case LABEL_STMT): Don't look at
LABEL_STMT_FIRST_IN_EH.
(gnat_expand_stmt, case ASM_STMT): New case.
* utils2.c (build_unary_op): Properly set TREE_READONLY of
UNCONSTRAINED_ARRAY_REF.
* utils.c (poplevel): Temporarily push/pop GC context around inline
function expansion.
* decl.c (maybe_variable): Properly set TREE_READONLY of
UNCONSTRAINED_ARRAY_REF.
(make_packable_type): Only reference TYPE_IS_PADDING_P for RECORD_TYPE.
* ada-tree.def: (ASM_STMT): New.
* ada-tree.h: (LABEL_STMT_FIRST_IN_EH): Deleted.
(ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT, ASM_STMT_ORIG_OUT,
ASM_STMT_INPUT): New.
(ASM_STMT_CLOBBER): Likewise.
2004-04-19 Thomas Quinot <quinot@act-europe.fr>
* a-except.adb, s-parint.ads, s-parint.adb, types.ads, types.h: Use
general rcheck mechanism to raise Program_Error for E.4(18), instead
of a custom raiser in System.Partition_Interface.
Part of general cleanup work before PolyORB integration.
* snames.ads, snames.adb: Add new runtime library entities and names
for PolyORB DSA.
* sem_dist.ads, sem_dist.adb (Get_Subprogram_Id): Move from sem_dist to
exp_dist.
(Build_Subprogram_Id): New subprogram provided by exp_dist
Code reorganisation in preparation for PolyORB integration.
* exp_dist.ads, exp_dist.adb (Get_Subprogram_Id): Move from sem_dist to
exp_dist.
(Build_Subprogram_Id): New subprogram provided by exp_dist
* sem_ch4.adb (Analyze_One_Call): Fix error message for mismatch in
actual parameter types for call to dereference of an
access-to-subprogram type.
* rtsfind.ads: Add new runtime library entities and names for PolyORB
DSA.
* gnatlink.adb (Value): Remove. Use Interfaces.C.Strings.Value
instead, which has the same behaviour here since we never pass it a
NULL pointer.
* link.c (run_path_option, Solaris case): Use -Wl, as for other
platforms.
* Makefile.in: adjust object file lists for gnatlink and gnatmake
to account for new dependency upon Interfaces.C.Strings + link.o
For x86 FreeBSD, use 86numaux.
* make.adb, gnatcmd.adb: Linker_Library_Path_Option has been moved up
from Mlib.Tgt to Mlib.
* mlib.ads, mlib.adb (Linker_Library_Path_Option): New subprogram, now
target-independent.
* mlib-tgt.ads, mlib-tgt.adb (Linker_Library_Path_Option): Remove
target-specific versions of this subprogram, now implemented as a
target-independent function in Mlib.
* 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb, 5lml-tgt.adb,
5sml-tgt.adb, 5vml-tgt.adb, 5zml-tgt.adb, 5wml-tgt.adb
(Linker_Library_Path_Option): Remove target-specific versions of this
subprogram, now implemented as a target-independent function in Mlib.
* atree.adb: (Allocate_Initialize_Node): New subprogram.
Factors out node table slots allocation.
(Fix_Parents): New subprogram.
Encapsulate the pattern of fixing up parent pointers for syntactic
children of a rewritten node.
(New_Copy_Tree): Use New_Copy to copy non-entity nodes.
(Rewrite): Use New_Copy when creating saved copy of original node.
(Replace): Use Copy_Node to copy nodes.
2004-04-19 Javier Miranda <miranda@gnat.com>
* sprint.adb (Sprint_Node_Actual): Give support to the new
Access_To_Subprogram node available in Access_Definition nodes. In
addition, give support to the AI-231 node fields: null-exclusion,
all-present, constant-present.
* sem_util.ads, sem_util.adb: (Has_Declarations): New subprogram
* sinfo.ads, sinfo.adb:
New field Access_To_Subprogram_Definition in Access_Definition nodes
* sem_ch6.adb (Process_Formals): Move here the code that creates and
decorates internal subtype declaration corresponding to the
null-excluding formal. This code was previously in Set_Actual_Subtypes.
In addition, carry out some code cleanup on this code. In case of
access to protected subprogram call
Replace_Anonymous_Access_To_Protected_Subprogram.
(Set_Actual_Subtypes): Code cleanup.
* sem_ch8.adb (Analyze_Object_Renaming): Remove un-necessary call to
Find_Type in case of anonymous access renamings. Add warning in case of
null-excluding attribute used in anonymous access renaming.
* sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New
subprogram
* sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): New
subprogram.
(Access_Definition): In case of anonymous access to subprograms call
the corresponding semantic routine to decorate the node.
(Access_Subprogram_Declaration): Addition of some comments indicating
some code that probably should be added here. Detected by comparison
with the access_definition subprogram.
(Analyze_Component_Declaration): In case of access to protected
subprogram call Replace_Anonymous_Access_To_Protected.
(Array_Type_Declaration): In case of access to protected subprogram call
Replace_Anonymous_Access_To_Protected_Subprogram.
(Process_Discriminants): In case of access to protected subprogram call
Replace_Anonymous_Access_To_Protected_Subprogram.
* par.adb (P_Access_Definition): New formal that indicates if the
null-exclusion part was present.
(P_Access_Type_Definition): New formal that indicates if the caller has
already parsed the null-excluding part.
* par-ch3.adb (P_Subtype_Declaration): Code cleanup.
(P_Identifier_Declarations): Code cleanup and give support to renamings
of anonymous access to subprogram types.
(P_Derived_Type_Def_Or_Private_Ext_Decl): Code cleanup.
(P_Array_Type_Definition): Give support to AI-254.
(P_Component_Items): Give support to AI-254.
(P_Access_Definition): New formal that indicates if the header was
already parsed by the caller.
(P_Access_Type_Definition): New formal that indicates if the caller has
already parsed the null-excluding part.
* par-ch6.adb (P_Formal_Part): Add the null-excluding parameter to the
call to P_Access_Definition.
2004-04-19 Geert Bosch <bosch@gnat.com>
* checks.adb (Apply_Float_Conversion_Check): New procedure to implement
the delicate semantics of floating-point to integer conversion.
(Apply_Type_Conversion_Checks): Use Apply_Float_Conversion_Check.
* eval_fat.adb (Machine_Mantissa): Moved to spec.
(Machine_Radix): New function.
* eval_fat.ads (Machine_Mantissa): Moved from body for use in
conversion checks.
(Machine_Radix): New function also for use in conversion checks.
2004-04-19 Ed Schonberg <schonberg@gnat.com>
* par-prag.adb (Source_File_Name_Project): Fix typo in error message.
* exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Call analyze
to decorate the access-to-protected subprogram and the equivalent type.
* checks.adb (Null_Exclusion_Static_Checks): Code cleanup. Give support
to anonymous access to subprogram types.
* exp_ch4.adb (Expand_N_In): Preserve Static flag before
constant-folding, for legality checks in contexts that require an RM
static expression.
* exp_ch6.adb (Expand_N_Function_Call): If call may generate large
temporary but stack checking is not enabled, increment serial number
to so that symbol generation is consistent with and without stack
checking.
* exp_util.ads, exp_util.adb (May_Generate_Large_Temp): Predicate is
independent on whether stack checking is enabled, caller must check
the corresponding flag.
* sem_ch3.adb (Constrain_Index): Index bounds given by attributes need
range checks.
(Build_Derived_Concurrent_Type): Inherit Is_Constrained flag from
parent if it has discriminants.
(Build_Derived_Private_Type): Constructed full view does
not come from source.
(Process_Discriminants): Default discriminants on a tagged type are
legal if this is the internal completion of a private untagged
derivation.
* sem_ch6.adb (Set_Actual_Subtypes): The generated declaration needs
no constraint checks, because it corresponds to an existing object.
* sem_prag.adb (Process_Convention): Pragma applies
only to subprograms in the same declarative part, i.e. the same unit,
not the same scope.
* sem_res.adb (Valid_Conversion): In an instance or inlined body,
ignore type mismatch on a numeric conversion if expression comes from
expansion.
2004-04-19 Sergey Rybin <rybin@act-europe.fr>
* sem_elim.adb (Process_Eliminate_Pragma): Remove the processing for
Homonym_Number parameter, add processing for Source_Location parameter
corresponding.
(Check_Eliminated): Remove the check for homonym numbers, add the check
for source location traces.
* sem_elim.ads (Process_Eliminate_Pragma): Replace Arg_Homonym_Number
with Arg_Source_Location corresponding to the changes in the format of
the pragma.
* sem_prag.adb: (Analyze_Pragma): Changes in the processing of
Eliminate pragma corresponding to the changes in the format of the
pragma: Homonym_Number is replaced with Source_Location, two ways of
distinguishing homonyms are mutially-exclusive.
2004-04-19 Joel Brobecker <brobecker@gnat.com>
* get_targ.ads (Get_No_Dollar_In_Label): Remove.
* exp_dbug.adb (Output_Homonym_Numbers_Suffix): Remove use of
No_Dollar_In_Label, no longer necessary, as it is always True.
(Strip_Suffixes): Likewise.
2004-04-19 Gary Dismukes <dismukes@gnat.com>
* s-stalib.ads (type Exception_Code): Use Integer'Size for exponent of
modulus for compatibility with size clause on targets with 16-bit
Integer.
* layout.adb (Discrimify): In the case of private types, set Vtyp to
full type to fix type mismatches on calls to size functions for
discriminant-dependent array components.
2004-04-19 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (gnatlib-zcx): New target, for building a ZCX run-time
lib.
2004-04-19 Pascal Obry <obry@gnat.com>
* mdll-utl.adb (Locate): New version is idempotent.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 101633 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 13:59 ` Diego Novillo
2004-04-08 15:03 ` Arnaud Charlet
@ 2004-04-09 20:06 ` Diego Novillo
1 sibling, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
On Thu, 2004-04-08 at 09:34, Arnaud Charlet wrote:
> BTW, we're now close to this goal, and will appreciate help from the tree-ssa
> folks to convert Ada to tree-ssa (that should more or less corresponds
> to the merge of tree-ssa in the mainline).
>
What type of help are you looking for? I could help with specific
questions about GIMPLE and interfaces to the tree-ssa code. But
converting a front end to emit GIMPLE requires fairly thorough
understanding of the input language. I know nothing about Ada,
unfortunately.
Are you really 2-3 weeks away from having the Ada FE emit GIMPLE?
That's great news.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:47 Richard Kenner
2004-04-08 15:53 ` Diego Novillo
@ 2004-04-09 20:06 ` Richard Kenner
1 sibling, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
The trick is to make sure that you remove all the semantics from the
input language so that the GIMPLE optimizers don't munge things up.
Since I don't know anything about Ada it is very difficult for me to
estimate. I'm just guessing.
That's certainly what's happening. Look at the code I pointed you to.
The tree nodes currently being used are defined in language-independent
terms. They are implemented by calling the standard expand_* routines.
Note that the majority of Ada semantics have already been removed by the
part of the front end written in Ada before even calling the C code at all.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:53 ` Diego Novillo
@ 2004-04-09 20:06 ` Diego Novillo
0 siblings, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:47, Richard Kenner wrote:
> The trick is to make sure that you remove all the semantics from the
> input language so that the GIMPLE optimizers don't munge things up.
> Since I don't know anything about Ada it is very difficult for me to
> estimate. I'm just guessing.
>
> That's certainly what's happening. Look at the code I pointed you to.
> The tree nodes currently being used are defined in language-independent
> terms. They are implemented by calling the standard expand_* routines.
>
Yeah, I was just browsing through that. OK, so then it should only be a
matter of not calling expand_* and generate the equivalent GENERIC nodes
instead. Longer term, the Ada parser could generate GENERIC nodes
directly, but native parse trees may have other uses, so I wouldn't
recommend that.
> Note that the majority of Ada semantics have already been removed by the
> part of the front end written in Ada before even calling the C code at all.
>
OK. That's good. In principle, it doesn't seem that it will be too
hard. We'll see.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:28 Richard Kenner
@ 2004-04-09 20:06 ` Richard Kenner
0 siblings, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
We will need to emit GENERIC first. That's the part that removes the
semantics of the input language. Once we are emitting GENERIC trees out
of the Ada FE, it should all "just work".
Right. My question, then, is how close are the nodes that I cited to those
that are in GENERIC. Is it just a matter of namings of nodes and fields
or something more substantive?
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:08 Richard Kenner
2004-04-08 18:13 ` Diego Novillo
@ 2004-04-09 20:06 ` Richard Kenner
1 sibling, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Note that we don't actually expand GIMPLE. We run a final pass that
combines GIMPLE trees into the big fat trees that GCC has
traditionally expanded.
Right, I knew that (and think it's important to retain it). But that
doesn't introduce GENERIC or language-specific nodes back, right? That's
why I don't understand the hook to generate RTL for specific nodes in the
tree-ssa context.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 16:05 Richard Kenner
@ 2004-04-09 20:06 ` Richard Kenner
0 siblings, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Yeah, I was just browsing through that. OK, so then it should only be a
matter of not calling expand_* and generate the equivalent GENERIC nodes
instead. Longer term, the Ada parser could generate GENERIC nodes
directly, but native parse trees may have other uses, so I wouldn't
recommend that.
No, it certainly should generate GENERIC nodes directly. I view those
nodes as temporary, to be replaced by the corresponding GENERIC nodes.
Hopefully, the gnat_expand_stmt code function will go away: it's
meants as a steppping stone on the way.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:00 ` Diego Novillo
@ 2004-04-09 20:06 ` Diego Novillo
0 siblings, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 13:40, Richard Kenner wrote:
> Once the optimizers are done, RTL is generated via
> lang_hook.rtl_expand.stmt().
>
> I'm confused. I thought RTL is generated from GIMPLE, which is too simple
> to have language-specific hooks.
>
Probably remnants from traditional RTL expansion. They all ultimately
map to expand_expr_stmt_value().
Note that we don't actually expand GIMPLE. We run a final pass that
combines GIMPLE trees into the big fat trees that GCC has traditionally
expanded. Longer term, we will go directly from SSA into RTL.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:06 Richard Kenner
2004-04-08 18:17 ` Laurent GUERBY
@ 2004-04-09 20:06 ` Richard Kenner
1 sibling, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: rth; +Cc: gcc-patches
DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0)
No idea what this does. Cruft?
Note that I was talking about the _STMT nodes ... the others have been
around for a while.
This one will actually go away as part of function-at-a-time. The idea
was to be able to defer elaboration of a piece of Ada tree and do it
during RTL generation. The single operand is a node number in the Ada tree.
DEFTREECODE (NULL_EXPR, "null_expr", 'e', 1)
I expect this doesn't need to exist, but I can't
quite tell what it's used for.
It's an expression that returns an object of a certain type but with
undefined result. It's used as a result for error cases.
DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
Why?
It's for pragma Inspection_Point, which at the source level tells the
compiler to make sure that the stated identifiers are visible at that
point to some external tool since as an ICE or debugger.
DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
These all have direct GENERIC replacements.
That was my main question.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:42 ` Diego Novillo
@ 2004-04-09 20:06 ` Diego Novillo
0 siblings, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:25, Richard Kenner wrote:
> f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
> while. With any luck it shouldn't take more than a couple of months.
>
> A couple of *months*? Is the interface really that complex? We're talking
> about converting a total of around 20K lines of code, the vast majority of
> which is Ada-specific and not related to the front-end interface.
>
The C front end took 3-4 months, but that was the first one, and we were
defining/evolving GENERIC and GIMPLE. The C++ FE took a lot less (jason
will probably remember). The Java FE didn't take more than 4-6 weeks, I
think (jsturm and/or aph will know). I am not sure how long it took
gfortran to emit GENERIC.
The trick is to make sure that you remove all the semantics from the
input language so that the GIMPLE optimizers don't munge things up.
Since I don't know anything about Ada it is very difficult for me to
estimate. I'm just guessing.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:15 Richard Kenner
2004-04-08 15:24 ` Diego Novillo
2004-04-08 17:54 ` Richard Henderson
@ 2004-04-09 20:06 ` Richard Kenner
2 siblings, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
What type of help are you looking for? I could help with specific
questions about GIMPLE and interfaces to the tree-ssa code. But
converting a front end to emit GIMPLE requires fairly thorough
understanding of the input language. I know nothing about Ada,
unfortunately.
I think Arno may have jumped the gun a little bit because there is still
a significant amount of work to do to completely convert Ada to "old-style"
function-at-a-time. The only "statements" left are call, loop, and switch,
which I'll do today, but there's still the issue of EH and decls, which
I think are more substantive and less mechanical and could easily take
another week.
If I've done my documentation job right, knowlege of Ada shouldn't be
needed to do the job of converting it to tree-ssa. To get some idea
of what's involved, look at the *_STMT nodes in ada/ada-tree.def and the
function gnat_expand_stmt in ada/trans.c.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-04-01 10:06 Arnaud Charlet
2004-04-06 14:21 ` Arnaud Charlet
@ 2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-09 20:06 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3086 bytes --]
Tested on x86-linux
--
2004-04-01 Robert Dewar <dewar@gnat.com>
* checks.adb: Minor reformatting throughout
Note that prev checkin added RM reference to alignment warning
2004-04-01 Ed Schonberg <schonberg@gnat.com>
* exp_aggr.adb (Get_Component_Val): Treat a string literal as
non-static when building aggregate for bit-packed array.
* exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a
function call that is itself the actual in a procedure call, build
temporary for it.
* exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is
a string literal, create a temporary for it, constant folding only
handles scalars here.
2004-04-01 Vincent Celier <celier@gnat.com>
* ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC,
Error_Msg_SP): New empty procedures to instantiate the Scanner.
(Style, Scanner): Instantiations of Styleg and Scng to be able to scan
tokens.
(Accumulate_Checksum, Initialize_Checksum): Remove procedures.
(Get_File_Checksum): Use the instantiated scanner to scan all the tokens
and get the checksum.
* make.adb (Gnatmake): Do not insert into Q the Main_Source if it is
already in the Q.
Increase the Marking_Label at the end of the Multiple_Main_Loop,
instead of at the beginning.
* osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~'
directly.
(Osint package elaboration): Change Multi_Unit_Index_Character to '$' if
on VMS.
* osint.ads (Multi_Unit_Index_Character): New Character global variable
* osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character,
not '~' directly.
* par.adb: Remove test on file name to detect language defined units.
Add test on unit name, after parsing, to detect language defined units
that are not compiled with -gnatg (except System.RPC and its children)
* par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the
following units without style checking.
* switch-c.adb: Change -gnatC to -gnateI
* usage.adb: Document new switch -gnateInnn
* scng.adb (Accumulate_Token_Checksum): New procedure
(Scan): Call Accumulate_Token_Checksum after each identifier, reserved
word or literal number.
(Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral
numbers.
2004-04-01 Thomas Quinot <quinot@act-europe.fr>
* a-tasatt.adb,
g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb,
switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb,
5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb,
5vtpopde.adb: Add missing 'constant' keywords.
2004-04-01 Javier Miranda <miranda@gnat.com>
* par-ch4.adb: (P_Allocator): Code cleanup
* sem_ch3.adb (Access_Definition): Properly set the null-excluding
attribute.
* sinfo.ads: Complete documentation of previous change
2004-04-01 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2004-04-01 Pascal Obry <obry@gnat.com>
* gnatlink.adb (Process_Binder_File): Remove duplicate linker options
only on VMS. This special handling was done because an old GNU/ld bug
on Windows which has been fixed.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 15309 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 17:54 ` Richard Henderson
@ 2004-04-09 20:06 ` Richard Henderson
0 siblings, 0 replies; 178+ messages in thread
From: Richard Henderson @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: dnovillo, gcc-patches
On Thu, Apr 08, 2004 at 11:15:12AM -0400, Richard Kenner wrote:
> If I've done my documentation job right, knowlege of Ada shouldn't be
> needed to do the job of converting it to tree-ssa. To get some idea
> of what's involved, look at the *_STMT nodes in ada/ada-tree.def and the
> function gnat_expand_stmt in ada/trans.c.
DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0)
No idea what this does. Cruft?
DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", '2', 2)
We use __builtin_stack_alloc in the C front end for
dynamic allocations. It doesn't take an alignment
argument at this time, but that could be changed.
DEFTREECODE (NULL_EXPR, "null_expr", 'e', 1)
I expect this doesn't need to exist, but I can't
quite tell what it's used for.
DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
Why?
DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
These all have direct GENERIC replacements.
r~
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 16:39 ` Diego Novillo
@ 2004-04-09 20:06 ` Diego Novillo
0 siblings, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 12:09, Richard Kenner wrote:
> Unless I'm misunderstanding things (and *please* correct me if I am), the
> semantic level of the GENERIC nodes is identical to that of the temporary
> nodes I'm currently emitting, so it should just be a matter of relatively
> minor changes.
>
That seems to be the case, yes.
Once the optimizers are done, RTL is generated via
lang_hook.rtl_expand.stmt(). All the FE needs to do is build the
GENERIC tree and feed it to tree_rest_of_compilation.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:17 ` Arnaud Charlet
@ 2004-04-09 20:06 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-09 20:06 UTC (permalink / raw)
To: Diego Novillo; +Cc: Arnaud Charlet, gcc-patches
> f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
> while. With any luck it shouldn't take more than a couple of months.
OK, thanks for the info.
So clearly, the GENERIC/GIMPLE step is where we would need some help.
We're a bit in a catch 22 situation where Ada knowledgeable people don't
know much about GENERIC/GIMPLE, and GENERIC/GIMPLE knowledgeable people
don't know much about Ada, but I'm sure we can find a way to work together
to make progress.
Clearly, we (Ada maintainers) would like to move forward here, and would
like to see Ada in GCC 3.5 if possible (although if we can't as Robert said
in the past, that would not be the end of the world of course).
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 17:40 Richard Kenner
2004-04-08 18:00 ` Diego Novillo
@ 2004-04-09 20:06 ` Richard Kenner
1 sibling, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Once the optimizers are done, RTL is generated via
lang_hook.rtl_expand.stmt().
I'm confused. I thought RTL is generated from GIMPLE, which is too simple
to have language-specific hooks.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-04-06 14:21 Arnaud Charlet
@ 2004-04-09 20:06 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-09 20:06 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-04-06 Pascal Obry <obry@gnat.com>
* adaint.c (DIR_SEPARATOR): Properly set DIR_SEPARATOR on Win32.
* osint.adb (Program_Name): Do not look past a directory separator.
2004-04-06 Thomas Quinot <quinot@act-europe.fr>
* atree.adb: Update comment (Rewrite_Substitute_Node no longer exists).
* exp_ch6.adb (Rewrite_Function_Call): Clarify documentation of
requirement for preserving a copy of the original assignment node.
* sinfo.ads: Update comment (Original_Tree -> Original_Node).
2004-04-06 Olivier Hainque <hainque@act-europe.fr>
(__gnat_initialize [Vxworks]): Enable references to the crtstuff bits
when supported.
2004-04-06 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Extend previous changes to
operator calls in functional notation, and apply
Universal_Interpretation to operands, not to their type.
2004-04-06 Robert Dewar <dewar@gnat.com>
* 5wdirval.adb: Minor reformatting
2004-04-06 Ed Falis <falis@gnat.com>
* gnat_rm.texi: Improve a reference to the GCC manual
--
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.29
diff -u -p -r1.29 adaint.c
--- adaint.c 5 Apr 2004 14:57:32 -0000 1.29
+++ adaint.c 6 Apr 2004 13:36:09 -0000
@@ -147,6 +147,8 @@ struct vstring
#if defined (_WIN32)
#include <dir.h>
#include <windows.h>
+#undef DIR_SEPARATOR
+#define DIR_SEPARATOR '\\'
#endif
#include "adaint.h"
@@ -2525,4 +2527,3 @@ get_gcc_version (void)
{
return 3;
}
-
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.12
diff -u -p -r1.12 atree.adb
--- atree.adb 12 Feb 2004 13:28:09 -0000 1.12
+++ atree.adb 6 Apr 2004 13:36:10 -0000
@@ -2114,8 +2114,7 @@ package body Atree is
-- Since we are doing a replace, we assume that the original node
-- is intended to become the new replaced node. The call would be
- -- to Rewrite_Substitute_Node if there were an intention to save
- -- the original node.
+ -- to Rewrite if there were an intention to save the original node.
Orig_Nodes.Table (Old_Node) := Old_Node;
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.24
diff -u -p -r1.24 exp_ch6.adb
--- exp_ch6.adb 5 Apr 2004 14:57:34 -0000 1.24
+++ exp_ch6.adb 6 Apr 2004 13:36:10 -0000
@@ -2466,6 +2466,9 @@ package body Exp_Ch6 is
-- complete assignment subtree consistent enough for
-- Analyze_Assignment to proceed. We do not use the
-- saved value, the point was just to do the relocation.
+ -- We cannot rely on Original_Node to go back from the
+ -- block node to the assignment node, because the
+ -- assignment might already be a rewrite substitution.
begin
Rewrite (Original_Assignment, Blk);
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.29
diff -u -p -r1.29 init.c
--- init.c 5 Apr 2004 14:57:35 -0000 1.29
+++ init.c 6 Apr 2004 13:36:11 -0000
@@ -1797,13 +1797,16 @@ __gnat_initialize (void)
call the appropriate function here. We'll never unload that, so there is
no de-registration to worry about.
- We can differentiate between the two cases by looking at the
- __module_has_ctors value provided by each class of crt objects. As of
- today, selecting the crt set intended for applications to be statically
- linked with the kernel is triggered by adding "-static" to the gcc *link*
- command line options. */
+ We can differentiate by looking at the __module_has_ctors value provided
+ by each class of crt objects. As of today, selecting the crt set intended
+ for applications to be statically linked with the kernel is triggered by
+ adding "-static" to the gcc *link* command line options.
-#if 0
+ This is a first approach, tightly synchronized with a number of GCC
+ configuration and crtstuff changes. We need to ensure that those changes
+ are there to activate this circuitry. */
+
+#if DWARF2_UNWIND_INFO && defined (_ARCH_PPC)
{
extern const int __module_has_ctors;
extern void __do_global_ctors ();
Index: osint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.adb,v
retrieving revision 1.19
diff -u -p -r1.19 osint.adb
--- osint.adb 1 Apr 2004 10:04:38 -0000 1.19
+++ osint.adb 6 Apr 2004 13:36:11 -0000
@@ -1794,7 +1794,17 @@ package body Osint is
-- "alpha-dec-vxworks-"
while Name_Len > 0 loop
+
+ -- All done if we find the last hyphen
+
if Name_Buffer (Name_Len) = '-' then
+ exit;
+
+ -- If directory separator found, we don't want to look further
+ -- since in this case, no prefix has been found.
+
+ elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
+ Name_Len := 0;
exit;
end if;
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_ch4.adb
--- sem_ch4.adb 5 Apr 2004 14:57:40 -0000 1.16
+++ sem_ch4.adb 6 Apr 2004 13:36:11 -0000
@@ -4359,20 +4359,18 @@ package body Sem_Ch4 is
-- always added to the overload set, unless it is a universal
-- operation.
- if Nkind (N) in N_Op
- and then Has_Abstract_Op
- then
+ if not Has_Abstract_Op then
+ return;
+
+ elsif Nkind (N) in N_Op then
if Nkind (N) in N_Unary_Op
- and then
- Present (Universal_Interpretation (Etype (Right_Opnd (N))))
+ and then Present (Universal_Interpretation (Right_Opnd (N)))
then
return;
elsif Nkind (N) in N_Binary_Op
- and then
- Present (Universal_Interpretation (Etype (Right_Opnd (N))))
- and then
- Present (Universal_Interpretation (Etype (Left_Opnd (N))))
+ and then Present (Universal_Interpretation (Right_Opnd (N)))
+ and then Present (Universal_Interpretation (Left_Opnd (N)))
then
return;
@@ -4386,6 +4384,38 @@ package body Sem_Ch4 is
Get_Next_Interp (I, It);
end loop;
end if;
+
+ elsif Nkind (N) = N_Function_Call
+ and then
+ (Nkind (Name (N)) = N_Operator_Symbol
+ or else
+ (Nkind (Name (N)) = N_Expanded_Name
+ and then
+ Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
+ then
+ declare
+ Arg1 : constant Node_Id := First (Parameter_Associations (N));
+
+ begin
+ if Present (Universal_Interpretation (Arg1))
+ or else
+ (Present (Next (Arg1))
+ and then
+ Present (Universal_Interpretation (Next (Arg1))))
+ then
+ return;
+
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Nam) loop
+ if Scope (It.Nam) = Standard_Standard then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end;
end if;
end if;
end Remove_Abstract_Operations;
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.25
diff -u -p -r1.25 sinfo.ads
--- sinfo.ads 5 Apr 2004 14:57:41 -0000 1.25
+++ sinfo.ads 6 Apr 2004 13:36:11 -0000
@@ -1519,7 +1519,7 @@ package Sinfo is
-- stub. During the analysis procedure, stubs in some situations
-- get rewritten by the corresponding bodies, and we set this flag
-- to remember that this happened. Note that it is not good enough
- -- to rely on the use of Original_Tree here because of the case of
+ -- to rely on the use of Original_Node here because of the case of
-- nested instantiations where the substituted node can be copied.
-- Zero_Cost_Handling (Flag5-Sem)
Index: 5wdirval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wdirval.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5wdirval.adb
--- 5wdirval.adb 5 Apr 2004 14:57:42 -0000 1.1
+++ 5wdirval.adb 6 Apr 2004 13:36:12 -0000
@@ -52,6 +52,7 @@ package body Ada.Directories.Validity is
function Is_Valid_Path_Name (Name : String) return Boolean is
Start : Positive := Name'First;
Last : Natural;
+
begin
-- A path name cannot be empty, cannot contain more than 256 characters,
-- cannot contain invalid characters and each directory/file name need
@@ -114,7 +115,8 @@ package body Ada.Directories.Validity is
--------------------------
function Is_Valid_Simple_Name (Name : String) return Boolean is
- Only_Spaces : Boolean := True;
+ Only_Spaces : Boolean;
+
begin
-- A file name cannot be empty, cannot contain more than 256 characters,
-- and cannot contain invalid characters, including '\'
@@ -122,20 +124,22 @@ package body Ada.Directories.Validity is
if Name'Length = 0 or else Name'Length > 256 then
return False;
+ -- Name length is OK
+
else
+ Only_Spaces := True;
for J in Name'Range loop
if Invalid_Character (Name (J)) or else Name (J) = '\' then
return False;
-
elsif Name (J) /= ' ' then
Only_Spaces := False;
end if;
end loop;
- end if;
- -- If Name follows the rules, it is valid
+ -- If no invalid chars, and not all spaces, file name is valid.
- return not Only_Spaces;
+ return not Only_Spaces;
+ end if;
end Is_Valid_Simple_Name;
end Ada.Directories.Validity;
Index: gnat_rm.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat_rm.texi,v
retrieving revision 1.15
diff -u -p -r1.15 gnat_rm.texi
--- gnat_rm.texi 2 Apr 2004 08:52:48 -0000 1.15
+++ gnat_rm.texi 6 Apr 2004 13:36:23 -0000
@@ -62,7 +62,7 @@ GNAT Reference Manual
@noindent
GNAT, The GNU Ada 95 Compiler@*
-Version for GCC @value{version-GCC}@*
+GCC version @value{version-GCC}@*
@noindent
Ada Core Technologies, Inc.
@@ -12688,15 +12688,17 @@ including machine instructions in a subp
@end itemize
@noindent
-The two features are similar, and both closely related to the mechanism
+The two features are similar, and both are closely related to the mechanism
provided by the asm instruction in the GNU C compiler. Full understanding
and use of the facilities in this package requires understanding the asm
-instruction as described in
-@cite{Using and Porting the GNU Compiler Collection (GCC)} by Richard
-Stallman. Calls to the function @code{Asm} and the procedure @code{Asm}
-have identical semantic restrictions and effects as described below.
-Both are provided so that the procedure call can be used as a statement,
-and the function call can be used to form a code_statement.
+instruction as described in @cite{Using the GNU Compiler Collection (GCC)}
+by Richard Stallman. The relevant section is titled ``Extensions to the C
+Language Family'' -> ``Assembler Instructions with C Expression Operands''.
+
+Calls to the function @code{Asm} and the procedure @code{Asm} have identical
+semantic restrictions and effects as described below. Both are provided so
+that the procedure call can be used as a statement, and the function call
+can be used to form a code_statement.
The first example given in the GCC documentation is the C @code{asm}
instruction:
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-04-05 14:58 Arnaud Charlet
2004-04-06 14:21 ` Arnaud Charlet
@ 2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-09 20:06 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4132 bytes --]
Tested on x86-linux
--
2004-04-05 Vincent Celier <celier@gnat.com>
* adaint.h, adaint.c: Add function __gnat_named_file_length
* impunit.adb: Add Ada.Directories to the list
* Makefile.in: Add VMS and Windows versions of
Ada.Directories.Validity package body.
* Makefile.rtl: Add a-direct and a-dirval
* mlib-tgt.ads: Minor comment update.
* a-dirval.ads, a-dirval.adb, 5vdirval.adb, 5wdirval.adb,
a-direct.ads, a-direct.adb: New files.
2004-04-05 Vincent Celier <celier@gnat.com>
PR ada/13620
* make.adb (Scan_Make_Arg): Pass any -fxxx switches to gnatlink, not
just to the compiler.
2004-04-05 Robert Dewar <dewar@gnat.com>
* a-except.adb (Exception_Name_Simple): Make sure lower bound of
returned string is 1.
* ali-util.adb: Use proper specific form for Warnings (Off, entity)
* eval_fat.ads: Minor reformatting
* g-curexc.ads: Document that lower bound of returned string values
is always one.
* gnatlink.adb: Add ??? comment for previous change
(need to document why this is VMS specific)
* s-stoele.ads: Minor reformatting
* tbuild.ads: Minor reformatting throughout (new function specs)
* par-ch10.adb (P_Context_Clause): Handle comma instead of semicolon
after WITH.
* scng.adb: Minor reformatting
2004-04-05 Geert Bosch <bosch@gnat.com>
* eval_fat.adb (Machine): Remove unnecessary suppression of warning.
(Leading_Part): Still perform truncation to machine number if the
specified radix_digits is greater or equal to machine_mantissa.
2004-04-05 Javier Miranda <miranda@gnat.com>
* par-ch3.adb: Complete documentation of previous change
Correct wrong syntax documentation of the OBJECT_DECLARATION rule
(aliased must appear before constant).
* par-ch4.adb: Complete documentation of previous change.
* par-ch6.adb: Complete documentation of previous change.
* sinfo.ads: Fix typo in commment.
2004-04-05 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Inherit_Components): If derived type is private and has
stored discriminants, use its discriminants to constrain parent type,
as is done for non-private derived record types.
* sem_ch4.adb (Remove_Abstract_Operations): New subprogram to implement
Ada 2005 AI-310: an abstract non-dispatching operation is not a
candidate interpretation in an overloaded call.
* tbuild.adb (Unchecked_Convert_To): Preserve conversion node if
expression is Null and target type is not an access type (e.g. a
non-private address type).
2004-04-05 Thomas Quinot <quinot@act-europe.fr>
* exp_ch6.adb (Rewrite_Function_Call): When rewriting an assignment
statement whose right-hand side is an inlined call, save a copy of the
original assignment subtree to preserve enough consistency for
Analyze_Assignment to proceed.
* sem_ch5.adb (Analyze_Assignment): Remove a costly copy of the
complete assignment subtree which is now unnecessary, as the expansion
of inlined call has been improved to preserve a consistent assignment
tree. Note_Possible_Modification must be called only
after checks have been applied, or else unnecessary checks will
be generated.
* sem_util.adb (Note_Possible_Modification): Reorganise the handling
of explicit dereferences that do not Come_From_Source:
- be selective on cases where we must go back to the dereferenced
pointer (an assignment to an implicit dereference must not be
recorded as modifying the pointer);
- do not rely on Original_Node being present (Analyze_Assignment
calls Note_Possible_Modification on a copied tree).
* sem_warn.adb (Check_References): When an unset reference to a pointer
that is never assigned is encountered, prefer '<pointer> may be null'
warning over '<pointer> is never assigned a value'.
2004-04-05 Ramon Fernandez <fernandez@gnat.com>
* tracebak.c: Change STOP_FRAME in ppc vxworks to be compliant with
the ABI.
2004-04-05 Olivier Hainque <hainque@act-europe.fr>
* 5gmastop.adb (Pop_Frame): Comment out the pragma Linker_Option for
libexc. We currently don't reference anything in this library and
linking it in triggers linker warnings we don't want to see.
* init.c: Update comments.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 15602 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:13 ` Diego Novillo
2004-04-08 15:17 ` Arnaud Charlet
@ 2004-04-09 20:06 ` Diego Novillo
1 sibling, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:03, Arnaud Charlet wrote:
> I have no idea what the relation between function-at-a-time and
> GIMPLE is, so I don't know if this is the case or not.
>
f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
while. With any luck it shouldn't take more than a couple of months.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-04-08 13:34 Arnaud Charlet
2004-04-08 13:59 ` Diego Novillo
@ 2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-09 20:06 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
Richard's changes in particular, is another big step forward function-at-a-time
for Ada.
BTW, we're now close to this goal, and will appreciate help from the tree-ssa
folks to convert Ada to tree-ssa (that should more or less corresponds
to the merge of tree-ssa in the mainline).
--
2004-04-08 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform): Shortcut returning error_mark_node for
statements in annotate_only_mode.
(tree_transform, case N_Label, case N_Return_Statement,
N_Goto_Statement): Make statement tree instead of generating code.
(tree_transform, case N_Assignment_Statement): No longer check
type_annotate_only.
(gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case
RETURN_STMT): New.
(first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl):
New fcns.
(gnat_to_gnu): Collect any RTL generated and deal with it.
(tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR.
(tree_transform case N_If_Statement): Rewrite to make IF_STMT.
(gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases.
* ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes.
* ada-tree.def (EXPR_STMT): Fix typo in name.
(BLOCK_STMT, IF_STMT): New nodes.
* ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL,
LABEL_STMT_FIRST_IN_EH): New macros.
(RETURN_STMT_EXPR): Likewise.
* ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE,
IF_STMT_ELSEIF, IF_STMT_ELSE): New macros.
2004-04-08 Thomas Quinot <quinot@act-europe.fr>
* atree.ads: Correct documentation on extended nodes.
* link.c: Set run_path_option for FreeBSD.
2004-04-08 Vincent Celier <celier@gnat.com>
* mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is
one of the ALI file, do not link with DEC lib.
* par.adb Remove the last two characters ("%s" or "%b") when checking
if a language defined unit may be recompiled.
2004-04-08 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Improve error message when
removal of abstract operation leaves no possible interpretation for
expression.
* sem_eval.adb (Eval_Qualified_Expression): Use
Set_Raises_Constraint_Error on node when needed, so that it does not
get optimized away by subsequent optimizations.
* sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of
operands even when they are not wrapped in a type conversion.
2004-04-08 Olivier Hainque <hainque@act-europe.fr>
* sem_prag.adb (Set_Exported): Warn about making static as result of
export only when the export is coming from source. This may be not
be true e.g. on VMS where we expand export pragmas for exception codes
together with imported or exported exceptions, and we don't want the
user to be warned about something he didn't write.
2004-04-08 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb (Note_Possible_Modification): Reorganize to remove code
duplication between normal entities and those declared as renamings.
No functional change.
* s-fileio.ads (Form): Remove pragma Inline, as we cannot currently
inline functions returning an unconstrained result.
2004-04-08 Eric Botcazou <ebotcazou@act-europe.fr>
* utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to
conform to what other front-ends do.
2004-04-08 Doug Rupp <rupp@gnat.com>
* 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared
libraries.
--
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.5
diff -u -p -r1.5 5vml-tgt.adb
--- 5vml-tgt.adb 18 Feb 2004 11:52:54 -0000 1.5
+++ 5vml-tgt.adb 8 Apr 2004 12:20:13 -0000
@@ -50,15 +50,10 @@ package body MLib.Tgt is
-- Used to add the generated auto-init object files for auto-initializing
-- stand-alone libraries.
- Macro_Name : constant String := "macro";
+ Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
-- The name of the command to invoke the macro-assembler
- -- Options to use when invoking gcc to build the dynamic library
-
- No_Start_Files : aliased String := "-nostartfiles";
-
- VMS_Options : Argument_List :=
- (No_Start_Files'Access, null);
+ VMS_Options : Argument_List := (1 .. 1 => null);
Gnatsym_Name : constant String := "gnatsym";
@@ -272,7 +267,7 @@ package body MLib.Tgt is
new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
end if;
- VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
+ VMS_Options (VMS_Options'First) := For_Linker_Opt;
for J in Inter'Range loop
To_Lower (Inter (J).all);
@@ -293,7 +288,7 @@ package body MLib.Tgt is
if Auto_Init then
declare
- Macro_File_Name : constant String := Lib_Filename & "$init.mar";
+ Macro_File_Name : constant String := Lib_Filename & "$init.asm";
Macro_File : Ada.Text_IO.File_Type;
Init_Proc : String := Lib_Filename & "INIT";
Popen_Result : System.Address;
@@ -319,13 +314,12 @@ package body MLib.Tgt is
begin
Create (Macro_File, Out_File, Macro_File_Name);
- Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE");
- Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc);
Put_Line
(Macro_File,
- ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG");
- Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc);
- Put_Line (Macro_File, ASCII.HT & ".END");
+ ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT");
+ Put_Line
+ (Macro_File,
+ ASCII.HT & ".long " & Init_Proc);
Close (Macro_File);
Index: ada-tree.def
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.def,v
retrieving revision 1.8
diff -u -p -r1.8 ada-tree.def
--- ada-tree.def 18 Nov 2003 10:00:42 -0000 1.8
+++ ada-tree.def 8 Apr 2004 12:20:13 -0000
@@ -84,4 +84,26 @@ DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id
We start with an expression statement, whose only operand is an
expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of
the expression (such as a MODIFY_EXPR) and discarding its result. */
-DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1)
+DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
+
+/* This represents a list of statements. BLOCK_STMT_LIST is a list
+ statement tree, chained via TREE_CHAIN. */
+DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
+
+/* This is an IF statement. IF_STMT_COND is the condition being tested,
+ IF_STMT_TRUE is the statement to be executed if the condition is
+ true; IF_STMT_ELSEIF, if non-null, is a list of more IF_STMT nodes (where
+ we only look at IF_STMT_COND and IF_STMT_TRUE) that correspond to
+ any "else if" parts; and IF_STMT_ELSE is the statement to be executed if
+ all conditions are. */
+DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
+
+/* A goto just points to the label: GOTO_STMT_LABEL. */
+DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
+
+/* A label: LABEL_STMT_LABEL is the label and LABEL_STMT_FIRST_IN_EH is set
+ if this is the first label of an exception handler. */
+DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
+
+/* A "return". RETURN_STMT_EXPR is the value to return if non-null. */
+DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.13
diff -u -p -r1.13 ada-tree.h
--- ada-tree.h 19 Mar 2004 15:08:45 -0000 1.13
+++ ada-tree.h 8 Apr 2004 12:20:13 -0000
@@ -294,5 +294,15 @@ struct lang_type GTY(())
/* We store the Sloc in statement nodes. */
#define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE))
-/* There is just one field in an EXPR_STMT: the expression. */
#define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
+#define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0)
+#define IF_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 0)
+#define IF_STMT_TRUE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 1)
+#define IF_STMT_ELSEIF(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 2)
+#define IF_STMT_ELSE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 3)
+#define GOTO_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, GOTO_STMT, 0)
+#define LABEL_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LABEL_STMT, 0)
+#define LABEL_STMT_FIRST_IN_EH(NODE) \
+ (LABEL_STMT_CHECK (NODE)->common.unsigned_flag)
+#define RETURN_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, RETURN_STMT, 0)
+
Index: atree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.ads,v
retrieving revision 1.8
diff -u -p -r1.8 atree.ads
--- atree.ads 12 Feb 2004 13:28:09 -0000 1.8
+++ atree.ads 8 Apr 2004 12:20:14 -0000
@@ -495,7 +495,7 @@ package Atree is
function Extend_Node (Node : Node_Id) return Entity_Id;
-- This function returns a copy of its input node with an extension
-- added. The fields of the extension are set to Empty. Due to the way
- -- extensions are handled (as two consecutive array elements), it may
+ -- extensions are handled (as four consecutive array elements), it may
-- be necessary to reallocate the node, so that the returned value is
-- not the same as the input value, but where possible the returned
-- value will be the same as the input value (i.e. the extension will
Index: link.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/link.c,v
retrieving revision 1.9
diff -u -p -r1.9 link.c
--- link.c 12 Jan 2004 11:45:24 -0000 1.9
+++ link.c 8 Apr 2004 12:20:14 -0000
@@ -156,7 +156,7 @@ const char *object_library_extension = "
#elif defined (__FreeBSD__)
char *object_file_option = "";
-char *run_path_option = "";
+char *run_path_option = "-Wl,-rpath,";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.11
diff -u -p -r1.11 mlib-prj.adb
--- mlib-prj.adb 15 Mar 2004 14:50:59 -0000 1.11
+++ mlib-prj.adb 8 Apr 2004 12:20:14 -0000
@@ -308,6 +308,9 @@ package body MLib.Prj is
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
+ Check_Libdecgnat : Boolean := Hostparm.OpenVMS;
+ -- Set to False if package Dec is part of the library sources.
+
Data : Project_Data := Projects.Table (For_Project);
Object_Directory_Path : constant String :=
@@ -372,7 +375,8 @@ package body MLib.Prj is
-- to link with -lgnarl (this is the case when there is a dependency
-- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
-- indicates that there is a need to link with -ldecgnat (this is the
- -- case when there is a dependency on dec.ads).
+ -- case when there is a dependency on dec.ads, except when it is the
+ -- DEC library, the one that contains package DEC).
procedure Process (The_ALI : File_Name_Type);
-- Check if the closure of a library unit which is or should be in the
@@ -504,12 +508,17 @@ package body MLib.Prj is
Text : Text_Buffer_Ptr;
Id : ALI.ALI_Id;
- pragma Warnings (Off, Id);
- -- Comment needed ???
-
begin
+ -- On OpenVMS, if we have package DEC, it means this is the DEC lib:
+ -- no need to link with itself.
+
+ if Check_Libdecgnat and then ALI_File = "dec.ali" then
+ Check_Libdecgnat := False;
+ Libdecgnat_Needed := False;
+ end if;
+
if not Libgnarl_Needed or
- (Hostparm.OpenVMS and then (not Libdecgnat_Needed))
+ (Check_Libdecgnat and then (not Libdecgnat_Needed))
then
-- Scan the ALI file
@@ -526,7 +535,7 @@ package body MLib.Prj is
Read_Lines => "D");
Free (Text);
- -- Look for s-osinte.ads in the dependencies
+ -- Look for s-osinte.ads and dec.ads in the dependencies
for Index in ALI.ALIs.Table (Id).First_Sdep ..
ALI.ALIs.Table (Id).Last_Sdep
@@ -534,7 +543,7 @@ package body MLib.Prj is
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := True;
- elsif Hostparm.OpenVMS and then
+ elsif Check_Libdecgnat and then
ALI.Sdep.Table (Index).Sfile = S_Dec_Ads
then
Libdecgnat_Needed := True;
@@ -1941,7 +1950,10 @@ package body MLib.Prj is
end if;
Status := fclose (Fd);
- -- Is it really right to ignore any close error ???
+
+ -- It is safe to ignore any error when closing, because the file was
+ -- only opened for reading.
+
end Process_Binder_File;
------------------
Index: par.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par.adb,v
retrieving revision 1.11
diff -u -p -r1.11 par.adb
--- par.adb 1 Apr 2004 10:04:38 -0000 1.11
+++ par.adb 8 Apr 2004 12:20:14 -0000
@@ -1310,16 +1310,24 @@ begin
and then not GNAT_Mode
then
declare
- Name : constant String :=
- Get_Name_String
- (Unit_Name (Current_Source_Unit));
+ Uname : constant String :=
+ Get_Name_String
+ (Unit_Name (Current_Source_Unit));
+ Name : String (1 .. Uname'Length - 2);
+
begin
- if (Name = "ada" or else
- Name = "calendar" or else
- Name = "interfaces" or else
- Name = "system" or else
- Name = "machine_code" or else
- Name = "unchecked_conversion" or else
+ -- Because Unit_Name includes "%s" or "%b", we need to
+ -- strip the last two characters to get the real unit
+ -- name.
+
+ Name := Uname (Uname'First .. Uname'Last - 2);
+
+ if (Name = "ada" or else
+ Name = "calendar" or else
+ Name = "interfaces" or else
+ Name = "system" or else
+ Name = "machine_code" or else
+ Name = "unchecked_conversion" or else
Name = "unchecked_deallocation"
or else (Name'Length > 4
and then
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_ch4.adb
--- sem_ch4.adb 6 Apr 2004 14:21:14 -0000 1.17
+++ sem_ch4.adb 8 Apr 2004 12:20:14 -0000
@@ -4332,7 +4332,7 @@ package body Sem_Ch4 is
procedure Remove_Abstract_Operations (N : Node_Id) is
I : Interp_Index;
It : Interp;
- Has_Abstract_Op : Boolean := False;
+ Abstract_Op : Entity_Id := Empty;
-- AI-310: If overloaded, remove abstract non-dispatching
-- operations.
@@ -4347,7 +4347,7 @@ package body Sem_Ch4 is
and then Is_Abstract (It.Nam)
and then not Is_Dispatching_Operation (It.Nam)
then
- Has_Abstract_Op := True;
+ Abstract_Op := It.Nam;
Remove_Interp (I);
exit;
end if;
@@ -4359,7 +4359,7 @@ package body Sem_Ch4 is
-- always added to the overload set, unless it is a universal
-- operation.
- if not Has_Abstract_Op then
+ if No (Abstract_Op) then
return;
elsif Nkind (N) in N_Op then
@@ -4398,10 +4398,9 @@ package body Sem_Ch4 is
begin
if Present (Universal_Interpretation (Arg1))
- or else
- (Present (Next (Arg1))
- and then
- Present (Universal_Interpretation (Next (Arg1))))
+ and then
+ (No (Next (Arg1))
+ or else Present (Universal_Interpretation (Next (Arg1))))
then
return;
@@ -4416,6 +4415,23 @@ package body Sem_Ch4 is
end loop;
end if;
end;
+ end if;
+
+ -- If the removal has left no valid interpretations, emit
+ -- error message now an label node as illegal.
+
+ if Present (Abstract_Op) then
+ Get_First_Interp (N, I, It);
+
+ if No (It.Nam) then
+
+ -- Removal of abstract operation left no viable candidate.
+
+ Set_Etype (N, Any_Type);
+ Error_Msg_Sloc := Sloc (Abstract_Op);
+ Error_Msg_NE
+ ("cannot call abstract operation& declared#", N, Abstract_Op);
+ end if;
end if;
end if;
end Remove_Abstract_Operations;
Index: sem_eval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_eval.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sem_eval.adb
--- sem_eval.adb 19 Jan 2004 10:37:59 -0000 1.12
+++ sem_eval.adb 8 Apr 2004 12:20:15 -0000
@@ -1947,6 +1947,13 @@ package body Sem_Eval is
or else Nkind (Parent (N)) = N_Allocator
then
Check_Non_Static_Context (Operand);
+
+ -- If operand is known to raise constraint_error, set the
+ -- flag on the expression so it does not get optimized away.
+
+ if Nkind (Operand) = N_Raise_Constraint_Error then
+ Set_Raises_Constraint_Error (N);
+ end if;
return;
end if;
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.24
diff -u -p -r1.24 sem_prag.adb
--- sem_prag.adb 29 Mar 2004 12:03:21 -0000 1.24
+++ sem_prag.adb 8 Apr 2004 12:20:15 -0000
@@ -3555,7 +3555,15 @@ package body Sem_Prag is
Set_Is_Public (E);
Set_Is_Statically_Allocated (E);
- if Warn_On_Export_Import then
+ -- Warn if the corresponding W flag is set and the pragma
+ -- comes from source. The latter may be not be true e.g. on
+ -- VMS where we expand export pragmas for exception codes
+ -- associated with imported or exported exceptions. We don't
+ -- want the user to be warned about something he didn't write.
+
+ if Warn_On_Export_Import
+ and then Comes_From_Source (Arg)
+ then
Error_Msg_NE
("?& has been made static as a result of Export", Arg, E);
Error_Msg_N
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.23
diff -u -p -r1.23 sem_res.adb
--- sem_res.adb 29 Mar 2004 12:03:21 -0000 1.23
+++ sem_res.adb 8 Apr 2004 12:20:15 -0000
@@ -4965,6 +4965,7 @@ package body Sem_Res is
end loop;
Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
-- If the operand type is private, rewrite with suitable
-- conversions on the operands and the result, to expose
@@ -4993,17 +4994,21 @@ package body Sem_Res is
or else Typ /= Etype (Right_Opnd (N))
then
-- Add explicit conversion where needed, and save interpretations
- -- if operands are overloaded.
+ -- in case operands are overloaded.
- Arg1 := Convert_To (Typ, Left_Opnd (N));
+ Arg1 := Convert_To (Typ, Left_Opnd (N));
Arg2 := Convert_To (Typ, Right_Opnd (N));
if Nkind (Arg1) = N_Type_Conversion then
Save_Interps (Left_Opnd (N), Expression (Arg1));
+ else
+ Save_Interps (Left_Opnd (N), Arg1);
end if;
if Nkind (Arg2) = N_Type_Conversion then
Save_Interps (Right_Opnd (N), Expression (Arg2));
+ else
+ Save_Interps (Right_Opnd (N), Arg1);
end if;
Rewrite (Left_Opnd (N), Arg1);
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.25
diff -u -p -r1.25 sem_util.adb
--- sem_util.adb 5 Apr 2004 14:57:40 -0000 1.25
+++ sem_util.adb 8 Apr 2004 12:20:15 -0000
@@ -4985,41 +4985,12 @@ package body Sem_Util is
Ent : Entity_Id;
Exp : Node_Id;
- procedure Set_Ref (E : Entity_Id; N : Node_Id);
- -- Internal routine to note modification on entity E by node N
- -- Has no effect if entity E does not represent an object.
-
- -------------
- -- Set_Ref --
- -------------
-
- procedure Set_Ref (E : Entity_Id; N : Node_Id) is
- begin
- if Is_Object (E) then
- if Comes_From_Source (N)
- or else Modification_Comes_From_Source
- then
- Set_Never_Set_In_Source (E, False);
- end if;
-
- Set_Is_True_Constant (E, False);
- Set_Current_Value (E, Empty);
- Generate_Reference (E, N, 'm');
- Kill_Checks (E);
-
- if not Can_Never_Be_Null (E) then
- Set_Is_Known_Non_Null (E, False);
- end if;
- end if;
- end Set_Ref;
-
- -- Start of processing for Note_Possible_Modification
-
begin
-- Loop to find referenced entity, if there is one
Exp := N;
loop
+ <<Continue>>
Ent := Empty;
if Is_Entity_Name (Exp) then
@@ -5074,10 +5045,14 @@ package body Sem_Util is
-- Now look for entity being referenced
if Present (Ent) then
- if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
- and then Present (Renamed_Object (Ent))
- then
- Set_Never_Set_In_Source (Ent, False);
+
+ if Is_Object (Ent) then
+ if Comes_From_Source (Exp)
+ or else Modification_Comes_From_Source
+ then
+ Set_Never_Set_In_Source (Ent, False);
+ end if;
+
Set_Is_True_Constant (Ent, False);
Set_Current_Value (Ent, Empty);
@@ -5085,13 +5060,18 @@ package body Sem_Util is
Set_Is_Known_Non_Null (Ent, False);
end if;
- Exp := Renamed_Object (Ent);
+ if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
+ and then Present (Renamed_Object (Ent))
+ then
+ Exp := Renamed_Object (Ent);
+ goto Continue;
+ end if;
- else
- Set_Ref (Ent, Exp);
- Kill_Checks (Ent);
- return;
+ Generate_Reference (Ent, Exp, 'm');
end if;
+
+ Kill_Checks (Ent);
+ return;
end if;
end loop;
end Note_Possible_Modification;
Index: s-fileio.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-fileio.ads,v
retrieving revision 1.5
diff -u -p -r1.5 s-fileio.ads
--- s-fileio.ads 21 Oct 2003 13:42:14 -0000 1.5
+++ s-fileio.ads 8 Apr 2004 12:20:15 -0000
@@ -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- --
@@ -250,7 +250,6 @@ package System.File_IO is
private
pragma Inline (Check_Read_Status);
pragma Inline (Check_Write_Status);
- pragma Inline (Form);
pragma Inline (Mode);
end System.File_IO;
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.50
diff -u -p -r1.50 trans.c
--- trans.c 1 Apr 2004 03:50:43 -0000 1.50
+++ trans.c 8 Apr 2004 12:20:16 -0000
@@ -104,6 +104,9 @@ Node_Id error_gnat_node;
static GTY(()) tree gnu_return_label_stack;
static tree tree_transform (Node_Id);
+static rtx first_nondeleted_insn (rtx);
+static tree build_block_stmt (List_Id);
+static tree make_expr_stmt_from_rtl (rtx, Node_Id);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
static void process_inlined_subprograms (Node_Id);
@@ -255,15 +258,60 @@ tree
gnat_to_gnu (Node_Id gnat_node)
{
tree gnu_root;
+ bool made_sequence = false;
+
+ /* We support the use of this on statements now as a transition
+ to full function-at-a-time processing. So we need to see if anything
+ we do generates RTL and returns error_mark_node. */
+ if (!global_bindings_p ())
+ {
+ start_sequence ();
+ emit_note (NOTE_INSN_DELETED);
+ made_sequence = true;
+ }
/* Save node number in case error */
error_gnat_node = gnat_node;
gnu_root = tree_transform (gnat_node);
- /* If we got no code as a result, something is wrong. */
- if (gnu_root == error_mark_node && ! type_annotate_only)
- gigi_abort (303);
+ if (gnu_root == error_mark_node)
+ {
+ if (!made_sequence)
+ {
+ if (type_annotate_only)
+ return gnu_root;
+ else
+ gigi_abort (303);
+ }
+
+ gnu_root = make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()),
+ gnat_node);
+ end_sequence ();
+ }
+ else if (made_sequence)
+ {
+ rtx insns = first_nondeleted_insn (get_insns ());
+
+ end_sequence ();
+
+ if (insns)
+ {
+ /* If we have a statement, we need to first evaluate any RTL we
+ made in the process of building it and then the statement. */
+ if (IS_STMT (gnu_root))
+ {
+ tree gnu_expr_stmt = make_expr_stmt_from_rtl (insns, gnat_node);
+
+ TREE_CHAIN (gnu_expr_stmt) = gnu_root;
+ gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt);
+ TREE_TYPE (gnu_root) = void_type_node;
+ TREE_SLOC (gnu_root) = Sloc (gnat_node);
+ }
+ else
+ emit_insn (insns);
+ }
+ }
return gnu_root;
}
@@ -290,6 +338,10 @@ tree_transform (Node_Id gnat_node)
/* Set input_file_name and lineno from the Sloc in the GNAT tree. */
set_lineno (gnat_node, 0);
+ if (IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
+ && type_annotate_only)
+ return error_mark_node;
+
/* If this is a Statement and we are at top level, we add the statement
as an elaboration for a null tree. That will cause it to be placed
in the elaboration procedure. */
@@ -1795,7 +1847,7 @@ tree_transform (Node_Id gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
+ if (first_nondeleted_insn (RTL_EXPR_SEQUENCE (gnu_rhs_side)))
gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
gnu_rhs);
@@ -2020,31 +2072,17 @@ tree_transform (Node_Id gnat_node)
/***************************/
case N_Label:
- if (! type_annotate_only)
- {
- tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
- Node_Id gnat_parent = Parent (gnat_node);
-
- expand_label (gnu_label);
-
- /* If this is the first label of an exception handler, we must
- mark that any CALL_INSN can jump to it. */
- if (Present (gnat_parent)
- && Nkind (gnat_parent) == N_Exception_Handler
- && First (Statements (gnat_parent)) == gnat_node)
- nonlocal_goto_handler_labels
- = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
- nonlocal_goto_handler_labels);
- }
+ gnu_result = build_nt (LABEL_STMT, gnat_to_gnu (Identifier (gnat_node)));
+ LABEL_STMT_FIRST_IN_EH (gnu_result)
+ = (Present (Parent (gnat_node))
+ && Nkind (Parent (gnat_node)) == N_Exception_Handler
+ && First (Statements (Parent (gnat_node))) == gnat_node);
break;
case N_Null_Statement:
break;
case N_Assignment_Statement:
- if (type_annotate_only)
- break;
-
/* Get the LHS and RHS of the statement and convert any reference to an
unconstrained array into a reference to the underlying array. */
gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
@@ -2071,53 +2109,28 @@ tree_transform (Node_Id gnat_node)
break;
case N_If_Statement:
- /* Start an IF statement giving the condition. */
- gnu_expr = gnat_to_gnu (Condition (gnat_node));
- set_lineno (gnat_node, 1);
- expand_start_cond (gnu_expr, 0);
-
- /* Generate code for the statements to be executed if the condition
- is true. */
+ gnu_result = NULL_TREE;
- for (gnat_temp = First (Then_Statements (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- gnat_to_code (gnat_temp);
-
- /* Generate each of the "else if" parts. */
+ /* Make an IF_STMT for each of the "else if" parts. */
if (Present (Elsif_Parts (gnat_node)))
- {
- for (gnat_temp = First (Elsif_Parts (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_statement;
-
- expand_start_else ();
-
- /* Set up the line numbers for each condition we test. */
- set_lineno (Condition (gnat_temp), 1);
- expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
-
- for (gnat_statement = First (Then_Statements (gnat_temp));
- Present (gnat_statement);
- gnat_statement = Next (gnat_statement))
- gnat_to_code (gnat_statement);
- }
- }
-
- /* Finally, handle any statements in the "else" part. */
- if (Present (Else_Statements (gnat_node)))
- {
- expand_start_else ();
-
- for (gnat_temp = First (Else_Statements (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- gnat_to_code (gnat_temp);
- }
+ for (gnat_temp = First (Elsif_Parts (gnat_node));
+ Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ {
+ tree gnu_elseif
+ = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_temp)),
+ build_block_stmt (Then_Statements (gnat_temp)),
+ NULL_TREE, NULL_TREE);
+
+ TREE_SLOC (gnu_elseif) = Sloc (Condition (gnat_temp));
+ TREE_CHAIN (gnu_elseif) = gnu_result;
+ TREE_TYPE (gnu_elseif) = void_type_node;
+ gnu_result = gnu_elseif;
+ }
- expand_end_cond ();
+ gnu_result = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_node)),
+ build_block_stmt (Then_Statements (gnat_node)),
+ nreverse (gnu_result),
+ build_block_stmt (Else_Statements (gnat_node)));
break;
case N_Case_Statement:
@@ -2456,9 +2469,6 @@ tree_transform (Node_Id gnat_node)
break;
case N_Return_Statement:
- if (type_annotate_only)
- break;
-
{
/* The gnu function type of the subprogram currently processed. */
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
@@ -2478,7 +2488,11 @@ tree_transform (Node_Id gnat_node)
a branch to that label. */
if (TREE_VALUE (gnu_return_label_stack) != 0)
- expand_goto (TREE_VALUE (gnu_return_label_stack));
+ {
+ gnu_result = build_nt (GOTO_STMT,
+ TREE_VALUE (gnu_return_label_stack));
+ break;
+ }
else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
{
@@ -2538,25 +2552,12 @@ tree_transform (Node_Id gnat_node)
}
}
- set_lineno (gnat_node, 1);
- if (gnu_ret_val)
- expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
- DECL_RESULT (current_function_decl),
- gnu_ret_val));
- else
- expand_null_return ();
-
+ gnu_result = build_nt (RETURN_STMT, gnu_ret_val);
}
break;
case N_Goto_Statement:
- if (type_annotate_only)
- break;
-
- gnu_expr = gnat_to_gnu (Name (gnat_node));
- TREE_USED (gnu_expr) = 1;
- set_lineno (gnat_node, 1);
- expand_goto (gnu_expr);
+ gnu_result = build_nt (GOTO_STMT, gnat_to_gnu (Name (gnat_node)));
break;
/****************************/
@@ -4174,17 +4175,128 @@ tree_transform (Node_Id gnat_node)
return gnu_result;
}
\f
+/* INSN is a list of insns. Return the first rtl in the list that isn't
+ an INSN_NOTE_DELETED. */
+
+static rtx
+first_nondeleted_insn (rtx insns)
+{
+ for (; insns && GET_CODE (insns) == NOTE
+ && NOTE_LINE_NUMBER (insns) == NOTE_INSN_DELETED;
+ insns = NEXT_INSN (insns))
+ ;
+
+ return insns;
+}
+\f
+/* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
+
+static tree
+build_block_stmt (List_Id gnat_list)
+{
+ tree gnu_result = NULL_TREE;
+ Node_Id gnat_node;
+
+ if (No (gnat_list) || Is_Empty_List (gnat_list))
+ return NULL_TREE;
+
+ for (gnat_node = First (gnat_list);
+ Present (gnat_node);
+ gnat_node = Next (gnat_node))
+ gnu_result = chainon (gnat_to_gnu (gnat_node), gnu_result);
+
+ gnu_result = build_nt (BLOCK_STMT, nreverse (gnu_result));
+ TREE_SLOC (gnu_result) = TREE_SLOC (BLOCK_STMT_LIST (gnu_result));
+ TREE_TYPE (gnu_result) = void_type_node;
+ return gnu_result;
+}
+
+/* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */
+
+static tree
+make_expr_stmt_from_rtl (rtx insns, Node_Id gnat_node)
+{
+ tree gnu_result = make_node (RTL_EXPR);
+
+ TREE_TYPE (gnu_result) = void_type_node;
+ RTL_EXPR_RTL (gnu_result) = RTL_EXPR_ALT_RTL (gnu_result) = const0_rtx;
+ RTL_EXPR_SEQUENCE (gnu_result) = insns;
+ rtl_expr_chain = tree_cons (NULL_TREE, gnu_result, rtl_expr_chain);
+
+ gnu_result = build_nt (EXPR_STMT, gnu_result);
+ TREE_SLOC (gnu_result) = Sloc (gnat_node);
+ TREE_TYPE (gnu_result) = void_type_node;
+
+ return gnu_result;
+}
+\f
/* GNU_STMT is a statement. We generate code for that statement. */
void
gnat_expand_stmt (tree gnu_stmt)
{
- set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
+ tree gnu_elmt;
+
+ if (TREE_SLOC (gnu_stmt))
+ set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
switch (TREE_CODE (gnu_stmt))
{
case EXPR_STMT:
expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
+ break;
+
+ case BLOCK_STMT:
+ for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt;
+ gnu_elmt = TREE_CHAIN (gnu_elmt))
+ expand_expr_stmt (gnu_elmt);
+ break;
+
+ case IF_STMT:
+ expand_start_cond (IF_STMT_COND (gnu_stmt), 0);
+
+ if (IF_STMT_TRUE (gnu_stmt))
+ expand_expr_stmt (IF_STMT_TRUE (gnu_stmt));
+
+ for (gnu_elmt = IF_STMT_ELSEIF (gnu_stmt); gnu_elmt;
+ gnu_elmt = TREE_CHAIN (gnu_elmt))
+ {
+ expand_start_else ();
+ set_lineno_from_sloc (TREE_SLOC (gnu_elmt), 1);
+ expand_elseif (IF_STMT_COND (gnu_elmt));
+ expand_expr_stmt (IF_STMT_TRUE (gnu_elmt));
+ }
+
+ if (IF_STMT_ELSE (gnu_stmt))
+ {
+ expand_start_else ();
+ expand_expr_stmt (IF_STMT_ELSE (gnu_stmt));
+ }
+
+ expand_end_cond ();
+ break;
+
+ case GOTO_STMT:
+ TREE_USED (GOTO_STMT_LABEL (gnu_stmt)) = 1;
+ expand_goto (GOTO_STMT_LABEL (gnu_stmt));
+ break;
+
+ case LABEL_STMT:
+ expand_label (LABEL_STMT_LABEL (gnu_stmt));
+ if (LABEL_STMT_FIRST_IN_EH (gnu_stmt))
+ nonlocal_goto_handler_labels
+ = gen_rtx_EXPR_LIST (VOIDmode,
+ label_rtx (LABEL_STMT_LABEL (gnu_stmt)),
+ nonlocal_goto_handler_labels);
+ break;
+
+ case RETURN_STMT:
+ if (RETURN_STMT_EXPR (gnu_stmt))
+ expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ RETURN_STMT_EXPR (gnu_stmt)));
+ else
+ expand_null_return ();
break;
default:
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.50
diff -u -p -r1.50 utils.c
--- utils.c 5 Apr 2004 12:25:24 -0000 1.50
+++ utils.c 8 Apr 2004 12:20:16 -0000
@@ -2069,7 +2069,11 @@ float_type_for_precision (int precision,
tree
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
{
- if (GET_MODE_CLASS (mode) == MODE_FLOAT)
+ if (mode == BLKmode)
+ return NULL_TREE;
+ else if (mode == VOIDmode)
+ return void_type_node;
+ else if (GET_MODE_CLASS (mode) == MODE_FLOAT)
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:25 Richard Kenner
2004-04-08 15:42 ` Diego Novillo
@ 2004-04-09 20:06 ` Richard Kenner
1 sibling, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
while. With any luck it shouldn't take more than a couple of months.
A couple of *months*? Is the interface really that complex? We're talking
about converting a total of around 20K lines of code, the vast majority of
which is Ada-specific and not related to the front-end interface.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:13 ` Diego Novillo
@ 2004-04-09 20:06 ` Diego Novillo
0 siblings, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 14:08, Richard Kenner wrote:
> Note that we don't actually expand GIMPLE. We run a final pass that
> combines GIMPLE trees into the big fat trees that GCC has
> traditionally expanded.
>
> Right, I knew that (and think it's important to retain it). But that
> doesn't introduce GENERIC or language-specific nodes back, right?
>
Nope.
> That's why I don't understand the hook to generate RTL for specific
> nodes in the tree-ssa context.
>
The hook could probably disappear now.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:17 ` Laurent GUERBY
2004-04-08 18:57 ` Richard Henderson
@ 2004-04-09 20:06 ` Laurent GUERBY
1 sibling, 0 replies; 178+ messages in thread
From: Laurent GUERBY @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: rth, gcc-patches
On Thu, 2004-04-08 at 20:06, Richard Kenner wrote:
> DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
> It's for pragma Inspection_Point, which at the source level tells the
> compiler to make sure that the stated identifiers are visible at that
> point to some external tool since as an ICE or debugger.
I believe it's a bit more than that, see below, I've always wondered if
GCC does the full thing here.
Laurent
<<
Implementation Requirements
7 Reaching an inspection point is an external interaction with respect to
the values of the inspectable objects at that point (see 1.1.3).
7.a Ramification: The compiler is inhibited from moving an assignment to
an inspectable variable past an inspection point for that variable.
On the other hand, the evaluation of an expression that might raise
an exception may be moved past an inspection point (see 11.6).
>>
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:24 ` Diego Novillo
@ 2004-04-09 20:06 ` Diego Novillo
0 siblings, 0 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-09 20:06 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:15, Richard Kenner wrote:
> If I've done my documentation job right, knowlege of Ada shouldn't be
> needed to do the job of converting it to tree-ssa. To get some idea
> of what's involved, look at the *_STMT nodes in ada/ada-tree.def and the
> function gnat_expand_stmt in ada/trans.c.
>
We will need to emit GENERIC first. That's the part that removes the
semantics of the input language. Once we are emitting GENERIC trees out
of the Ada FE, it should all "just work".
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:25 committed: " Richard Kenner
@ 2004-04-09 20:06 ` Richard Kenner
0 siblings, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: laurent; +Cc: gcc-patches
7.a Ramification: The compiler is inhibited from moving an assignment to
an inspectable variable past an inspection point for that variable.
On the other hand, the evaluation of an expression that might raise
an exception may be moved past an inspection point (see 11.6).
I never noticed that.
Perhaps the proper implementation is indeed to put an assigment of the variable
to itself at that point and make the variable volatile.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:57 ` Richard Henderson
@ 2004-04-09 20:06 ` Richard Henderson
0 siblings, 0 replies; 178+ messages in thread
From: Richard Henderson @ 2004-04-09 20:06 UTC (permalink / raw)
To: Laurent GUERBY; +Cc: Richard Kenner, gcc-patches
On Thu, Apr 08, 2004 at 08:17:31PM +0200, Laurent GUERBY wrote:
> I believe it's a bit more than that, see below, I've always wondered if
> GCC does the full thing here.
>
> Laurent
>
> <<
> Implementation Requirements
>
> 7 Reaching an inspection point is an external interaction with respect to
> the values of the inspectable objects at that point (see 1.1.3).
>
> 7.a Ramification: The compiler is inhibited from moving an assignment to
> an inspectable variable past an inspection point for that variable.
> On the other hand, the evaluation of an expression that might raise
> an exception may be moved past an inspection point (see 11.6).
> >>
About the only thing we currently support that might be equivalent is
asm volatile ("" : : "X" (foo));
Nothing else GIMPLE or RTL gives the semantics that you're looking for.
r~
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 16:09 Richard Kenner
2004-04-08 16:39 ` Diego Novillo
@ 2004-04-09 20:06 ` Richard Kenner
1 sibling, 0 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-09 20:06 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Yeah, I was just browsing through that. OK, so then it should only be a
matter of not calling expand_* and generate the equivalent GENERIC nodes
instead. Longer term, the Ada parser could generate GENERIC nodes
directly, but native parse trees may have other uses, so I wouldn't
recommend that.
Let me rephrase what I just said: the substantive part of the Ada
front end generating tree nodes is structural and those are the areas I
intend to work on next using these nodes as a testbed. Those problems will
be the same for function-at-a-time and tree-ssa.
Once they are resolved, the remaining work is reworking the code from
generating the current temporary nodes into the proper GENERIC nodes.
Unless I'm misunderstanding things (and *please* correct me if I am), the
semantic level of the GENERIC nodes is identical to that of the temporary
nodes I'm currently emitting, so it should just be a matter of relatively
minor changes.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:03 ` Arnaud Charlet
2004-04-08 15:13 ` Diego Novillo
@ 2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-09 20:06 UTC (permalink / raw)
To: Diego Novillo; +Cc: Arnaud Charlet, gcc-patches
> What type of help are you looking for? I could help with specific
> questions about GIMPLE and interfaces to the tree-ssa code. But
> converting a front end to emit GIMPLE requires fairly thorough
> understanding of the input language. I know nothing about Ada,
> unfortunately.
I'll let Richard answer here, he has some ideas about this as far as I
know.
> Are you really 2-3 weeks away from having the Ada FE emit GIMPLE?
> That's great news.
We are 203 weeks away from having the Ada FE be function-at-a-time.
I have no idea what the relation between function-at-a-time and
GIMPLE is, so I don't know if this is the case or not.
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:17 ` Laurent GUERBY
@ 2004-04-08 18:57 ` Richard Henderson
2004-04-09 20:06 ` Richard Henderson
2004-04-09 20:06 ` Laurent GUERBY
1 sibling, 1 reply; 178+ messages in thread
From: Richard Henderson @ 2004-04-08 18:57 UTC (permalink / raw)
To: Laurent GUERBY; +Cc: Richard Kenner, gcc-patches
On Thu, Apr 08, 2004 at 08:17:31PM +0200, Laurent GUERBY wrote:
> I believe it's a bit more than that, see below, I've always wondered if
> GCC does the full thing here.
>
> Laurent
>
> <<
> Implementation Requirements
>
> 7 Reaching an inspection point is an external interaction with respect to
> the values of the inspectable objects at that point (see 1.1.3).
>
> 7.a Ramification: The compiler is inhibited from moving an assignment to
> an inspectable variable past an inspection point for that variable.
> On the other hand, the evaluation of an expression that might raise
> an exception may be moved past an inspection point (see 11.6).
> >>
About the only thing we currently support that might be equivalent is
asm volatile ("" : : "X" (foo));
Nothing else GIMPLE or RTL gives the semantics that you're looking for.
r~
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 18:25 Richard Kenner
2004-04-09 20:06 ` Richard Kenner
0 siblings, 1 reply; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 18:25 UTC (permalink / raw)
To: laurent; +Cc: gcc-patches
7.a Ramification: The compiler is inhibited from moving an assignment to
an inspectable variable past an inspection point for that variable.
On the other hand, the evaluation of an expression that might raise
an exception may be moved past an inspection point (see 11.6).
I never noticed that.
Perhaps the proper implementation is indeed to put an assigment of the variable
to itself at that point and make the variable volatile.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:06 Richard Kenner
@ 2004-04-08 18:17 ` Laurent GUERBY
2004-04-08 18:57 ` Richard Henderson
2004-04-09 20:06 ` Laurent GUERBY
2004-04-09 20:06 ` Richard Kenner
1 sibling, 2 replies; 178+ messages in thread
From: Laurent GUERBY @ 2004-04-08 18:17 UTC (permalink / raw)
To: Richard Kenner; +Cc: rth, gcc-patches
On Thu, 2004-04-08 at 20:06, Richard Kenner wrote:
> DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
> It's for pragma Inspection_Point, which at the source level tells the
> compiler to make sure that the stated identifiers are visible at that
> point to some external tool since as an ICE or debugger.
I believe it's a bit more than that, see below, I've always wondered if
GCC does the full thing here.
Laurent
<<
Implementation Requirements
7 Reaching an inspection point is an external interaction with respect to
the values of the inspectable objects at that point (see 1.1.3).
7.a Ramification: The compiler is inhibited from moving an assignment to
an inspectable variable past an inspection point for that variable.
On the other hand, the evaluation of an expression that might raise
an exception may be moved past an inspection point (see 11.6).
>>
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 18:08 Richard Kenner
@ 2004-04-08 18:13 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
1 sibling, 1 reply; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 18:13 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 14:08, Richard Kenner wrote:
> Note that we don't actually expand GIMPLE. We run a final pass that
> combines GIMPLE trees into the big fat trees that GCC has
> traditionally expanded.
>
> Right, I knew that (and think it's important to retain it). But that
> doesn't introduce GENERIC or language-specific nodes back, right?
>
Nope.
> That's why I don't understand the hook to generate RTL for specific
> nodes in the tree-ssa context.
>
The hook could probably disappear now.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 18:08 Richard Kenner
2004-04-08 18:13 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
0 siblings, 2 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 18:08 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Note that we don't actually expand GIMPLE. We run a final pass that
combines GIMPLE trees into the big fat trees that GCC has
traditionally expanded.
Right, I knew that (and think it's important to retain it). But that
doesn't introduce GENERIC or language-specific nodes back, right? That's
why I don't understand the hook to generate RTL for specific nodes in the
tree-ssa context.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 18:06 Richard Kenner
2004-04-08 18:17 ` Laurent GUERBY
2004-04-09 20:06 ` Richard Kenner
0 siblings, 2 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 18:06 UTC (permalink / raw)
To: rth; +Cc: gcc-patches
DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0)
No idea what this does. Cruft?
Note that I was talking about the _STMT nodes ... the others have been
around for a while.
This one will actually go away as part of function-at-a-time. The idea
was to be able to defer elaboration of a piece of Ada tree and do it
during RTL generation. The single operand is a node number in the Ada tree.
DEFTREECODE (NULL_EXPR, "null_expr", 'e', 1)
I expect this doesn't need to exist, but I can't
quite tell what it's used for.
It's an expression that returns an object of a certain type but with
undefined result. It's used as a result for error cases.
DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
Why?
It's for pragma Inspection_Point, which at the source level tells the
compiler to make sure that the stated identifiers are visible at that
point to some external tool since as an ICE or debugger.
DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
These all have direct GENERIC replacements.
That was my main question.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 17:40 Richard Kenner
@ 2004-04-08 18:00 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
1 sibling, 1 reply; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 18:00 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 13:40, Richard Kenner wrote:
> Once the optimizers are done, RTL is generated via
> lang_hook.rtl_expand.stmt().
>
> I'm confused. I thought RTL is generated from GIMPLE, which is too simple
> to have language-specific hooks.
>
Probably remnants from traditional RTL expansion. They all ultimately
map to expand_expr_stmt_value().
Note that we don't actually expand GIMPLE. We run a final pass that
combines GIMPLE trees into the big fat trees that GCC has traditionally
expanded. Longer term, we will go directly from SSA into RTL.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:15 Richard Kenner
2004-04-08 15:24 ` Diego Novillo
@ 2004-04-08 17:54 ` Richard Henderson
2004-04-09 20:06 ` Richard Henderson
2004-04-09 20:06 ` Richard Kenner
2 siblings, 1 reply; 178+ messages in thread
From: Richard Henderson @ 2004-04-08 17:54 UTC (permalink / raw)
To: Richard Kenner; +Cc: dnovillo, gcc-patches
On Thu, Apr 08, 2004 at 11:15:12AM -0400, Richard Kenner wrote:
> If I've done my documentation job right, knowlege of Ada shouldn't be
> needed to do the job of converting it to tree-ssa. To get some idea
> of what's involved, look at the *_STMT nodes in ada/ada-tree.def and the
> function gnat_expand_stmt in ada/trans.c.
DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0)
No idea what this does. Cruft?
DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", '2', 2)
We use __builtin_stack_alloc in the C front end for
dynamic allocations. It doesn't take an alignment
argument at this time, but that could be changed.
DEFTREECODE (NULL_EXPR, "null_expr", 'e', 1)
I expect this doesn't need to exist, but I can't
quite tell what it's used for.
DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
Why?
DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
These all have direct GENERIC replacements.
r~
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 17:40 Richard Kenner
2004-04-08 18:00 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
0 siblings, 2 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 17:40 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Once the optimizers are done, RTL is generated via
lang_hook.rtl_expand.stmt().
I'm confused. I thought RTL is generated from GIMPLE, which is too simple
to have language-specific hooks.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 16:09 Richard Kenner
@ 2004-04-08 16:39 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
1 sibling, 1 reply; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 16:39 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 12:09, Richard Kenner wrote:
> Unless I'm misunderstanding things (and *please* correct me if I am), the
> semantic level of the GENERIC nodes is identical to that of the temporary
> nodes I'm currently emitting, so it should just be a matter of relatively
> minor changes.
>
That seems to be the case, yes.
Once the optimizers are done, RTL is generated via
lang_hook.rtl_expand.stmt(). All the FE needs to do is build the
GENERIC tree and feed it to tree_rest_of_compilation.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 16:09 Richard Kenner
2004-04-08 16:39 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
0 siblings, 2 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 16:09 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Yeah, I was just browsing through that. OK, so then it should only be a
matter of not calling expand_* and generate the equivalent GENERIC nodes
instead. Longer term, the Ada parser could generate GENERIC nodes
directly, but native parse trees may have other uses, so I wouldn't
recommend that.
Let me rephrase what I just said: the substantive part of the Ada
front end generating tree nodes is structural and those are the areas I
intend to work on next using these nodes as a testbed. Those problems will
be the same for function-at-a-time and tree-ssa.
Once they are resolved, the remaining work is reworking the code from
generating the current temporary nodes into the proper GENERIC nodes.
Unless I'm misunderstanding things (and *please* correct me if I am), the
semantic level of the GENERIC nodes is identical to that of the temporary
nodes I'm currently emitting, so it should just be a matter of relatively
minor changes.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 16:05 Richard Kenner
2004-04-09 20:06 ` Richard Kenner
0 siblings, 1 reply; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 16:05 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
Yeah, I was just browsing through that. OK, so then it should only be a
matter of not calling expand_* and generate the equivalent GENERIC nodes
instead. Longer term, the Ada parser could generate GENERIC nodes
directly, but native parse trees may have other uses, so I wouldn't
recommend that.
No, it certainly should generate GENERIC nodes directly. I view those
nodes as temporary, to be replaced by the corresponding GENERIC nodes.
Hopefully, the gnat_expand_stmt code function will go away: it's
meants as a steppping stone on the way.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:47 Richard Kenner
@ 2004-04-08 15:53 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
1 sibling, 1 reply; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 15:53 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:47, Richard Kenner wrote:
> The trick is to make sure that you remove all the semantics from the
> input language so that the GIMPLE optimizers don't munge things up.
> Since I don't know anything about Ada it is very difficult for me to
> estimate. I'm just guessing.
>
> That's certainly what's happening. Look at the code I pointed you to.
> The tree nodes currently being used are defined in language-independent
> terms. They are implemented by calling the standard expand_* routines.
>
Yeah, I was just browsing through that. OK, so then it should only be a
matter of not calling expand_* and generate the equivalent GENERIC nodes
instead. Longer term, the Ada parser could generate GENERIC nodes
directly, but native parse trees may have other uses, so I wouldn't
recommend that.
> Note that the majority of Ada semantics have already been removed by the
> part of the front end written in Ada before even calling the C code at all.
>
OK. That's good. In principle, it doesn't seem that it will be too
hard. We'll see.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 15:47 Richard Kenner
2004-04-08 15:53 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
0 siblings, 2 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 15:47 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
The trick is to make sure that you remove all the semantics from the
input language so that the GIMPLE optimizers don't munge things up.
Since I don't know anything about Ada it is very difficult for me to
estimate. I'm just guessing.
That's certainly what's happening. Look at the code I pointed you to.
The tree nodes currently being used are defined in language-independent
terms. They are implemented by calling the standard expand_* routines.
Note that the majority of Ada semantics have already been removed by the
part of the front end written in Ada before even calling the C code at all.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:25 Richard Kenner
@ 2004-04-08 15:42 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
1 sibling, 1 reply; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 15:42 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:25, Richard Kenner wrote:
> f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
> while. With any luck it shouldn't take more than a couple of months.
>
> A couple of *months*? Is the interface really that complex? We're talking
> about converting a total of around 20K lines of code, the vast majority of
> which is Ada-specific and not related to the front-end interface.
>
The C front end took 3-4 months, but that was the first one, and we were
defining/evolving GENERIC and GIMPLE. The C++ FE took a lot less (jason
will probably remember). The Java FE didn't take more than 4-6 weeks, I
think (jsturm and/or aph will know). I am not sure how long it took
gfortran to emit GENERIC.
The trick is to make sure that you remove all the semantics from the
input language so that the GIMPLE optimizers don't munge things up.
Since I don't know anything about Ada it is very difficult for me to
estimate. I'm just guessing.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 15:28 Richard Kenner
2004-04-09 20:06 ` Richard Kenner
0 siblings, 1 reply; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 15:28 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
We will need to emit GENERIC first. That's the part that removes the
semantics of the input language. Once we are emitting GENERIC trees out
of the Ada FE, it should all "just work".
Right. My question, then, is how close are the nodes that I cited to those
that are in GENERIC. Is it just a matter of namings of nodes and fields
or something more substantive?
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 15:25 Richard Kenner
2004-04-08 15:42 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
0 siblings, 2 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 15:25 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
while. With any luck it shouldn't take more than a couple of months.
A couple of *months*? Is the interface really that complex? We're talking
about converting a total of around 20K lines of code, the vast majority of
which is Ada-specific and not related to the front-end interface.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:15 Richard Kenner
@ 2004-04-08 15:24 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-08 17:54 ` Richard Henderson
2004-04-09 20:06 ` Richard Kenner
2 siblings, 1 reply; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 15:24 UTC (permalink / raw)
To: Richard Kenner; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:15, Richard Kenner wrote:
> If I've done my documentation job right, knowlege of Ada shouldn't be
> needed to do the job of converting it to tree-ssa. To get some idea
> of what's involved, look at the *_STMT nodes in ada/ada-tree.def and the
> function gnat_expand_stmt in ada/trans.c.
>
We will need to emit GENERIC first. That's the part that removes the
semantics of the input language. Once we are emitting GENERIC trees out
of the Ada FE, it should all "just work".
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:13 ` Diego Novillo
@ 2004-04-08 15:17 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
2004-04-09 20:06 ` Diego Novillo
1 sibling, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-08 15:17 UTC (permalink / raw)
To: Diego Novillo; +Cc: Arnaud Charlet, gcc-patches
> f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
> while. With any luck it shouldn't take more than a couple of months.
OK, thanks for the info.
So clearly, the GENERIC/GIMPLE step is where we would need some help.
We're a bit in a catch 22 situation where Ada knowledgeable people don't
know much about GENERIC/GIMPLE, and GENERIC/GIMPLE knowledgeable people
don't know much about Ada, but I'm sure we can find a way to work together
to make progress.
Clearly, we (Ada maintainers) would like to move forward here, and would
like to see Ada in GCC 3.5 if possible (although if we can't as Robert said
in the past, that would not be the end of the world of course).
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
@ 2004-04-08 15:15 Richard Kenner
2004-04-08 15:24 ` Diego Novillo
` (2 more replies)
0 siblings, 3 replies; 178+ messages in thread
From: Richard Kenner @ 2004-04-08 15:15 UTC (permalink / raw)
To: dnovillo; +Cc: gcc-patches
What type of help are you looking for? I could help with specific
questions about GIMPLE and interfaces to the tree-ssa code. But
converting a front end to emit GIMPLE requires fairly thorough
understanding of the input language. I know nothing about Ada,
unfortunately.
I think Arno may have jumped the gun a little bit because there is still
a significant amount of work to do to completely convert Ada to "old-style"
function-at-a-time. The only "statements" left are call, loop, and switch,
which I'll do today, but there's still the issue of EH and decls, which
I think are more substantive and less mechanical and could easily take
another week.
If I've done my documentation job right, knowlege of Ada shouldn't be
needed to do the job of converting it to tree-ssa. To get some idea
of what's involved, look at the *_STMT nodes in ada/ada-tree.def and the
function gnat_expand_stmt in ada/trans.c.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 15:03 ` Arnaud Charlet
@ 2004-04-08 15:13 ` Diego Novillo
2004-04-08 15:17 ` Arnaud Charlet
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 2 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 15:13 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
On Thu, 2004-04-08 at 11:03, Arnaud Charlet wrote:
> I have no idea what the relation between function-at-a-time and
> GIMPLE is, so I don't know if this is the case or not.
>
f-a-t is a pre-condition for GENERIC/GIMPLE. The next step can take a
while. With any luck it shouldn't take more than a couple of months.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 13:59 ` Diego Novillo
@ 2004-04-08 15:03 ` Arnaud Charlet
2004-04-08 15:13 ` Diego Novillo
2004-04-09 20:06 ` Arnaud Charlet
2004-04-09 20:06 ` Diego Novillo
1 sibling, 2 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-08 15:03 UTC (permalink / raw)
To: Diego Novillo; +Cc: Arnaud Charlet, gcc-patches
> What type of help are you looking for? I could help with specific
> questions about GIMPLE and interfaces to the tree-ssa code. But
> converting a front end to emit GIMPLE requires fairly thorough
> understanding of the input language. I know nothing about Ada,
> unfortunately.
I'll let Richard answer here, he has some ideas about this as far as I
know.
> Are you really 2-3 weeks away from having the Ada FE emit GIMPLE?
> That's great news.
We are 203 weeks away from having the Ada FE be function-at-a-time.
I have no idea what the relation between function-at-a-time and
GIMPLE is, so I don't know if this is the case or not.
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-04-08 13:34 Arnaud Charlet
@ 2004-04-08 13:59 ` Diego Novillo
2004-04-08 15:03 ` Arnaud Charlet
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 2 replies; 178+ messages in thread
From: Diego Novillo @ 2004-04-08 13:59 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
On Thu, 2004-04-08 at 09:34, Arnaud Charlet wrote:
> BTW, we're now close to this goal, and will appreciate help from the tree-ssa
> folks to convert Ada to tree-ssa (that should more or less corresponds
> to the merge of tree-ssa in the mainline).
>
What type of help are you looking for? I could help with specific
questions about GIMPLE and interfaces to the tree-ssa code. But
converting a front end to emit GIMPLE requires fairly thorough
understanding of the input language. I know nothing about Ada,
unfortunately.
Are you really 2-3 weeks away from having the Ada FE emit GIMPLE?
That's great news.
Diego.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-08 13:34 Arnaud Charlet
2004-04-08 13:59 ` Diego Novillo
2004-04-09 20:06 ` Arnaud Charlet
0 siblings, 2 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-08 13:34 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
Richard's changes in particular, is another big step forward function-at-a-time
for Ada.
BTW, we're now close to this goal, and will appreciate help from the tree-ssa
folks to convert Ada to tree-ssa (that should more or less corresponds
to the merge of tree-ssa in the mainline).
--
2004-04-08 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform): Shortcut returning error_mark_node for
statements in annotate_only_mode.
(tree_transform, case N_Label, case N_Return_Statement,
N_Goto_Statement): Make statement tree instead of generating code.
(tree_transform, case N_Assignment_Statement): No longer check
type_annotate_only.
(gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case
RETURN_STMT): New.
(first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl):
New fcns.
(gnat_to_gnu): Collect any RTL generated and deal with it.
(tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR.
(tree_transform case N_If_Statement): Rewrite to make IF_STMT.
(gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases.
* ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes.
* ada-tree.def (EXPR_STMT): Fix typo in name.
(BLOCK_STMT, IF_STMT): New nodes.
* ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL,
LABEL_STMT_FIRST_IN_EH): New macros.
(RETURN_STMT_EXPR): Likewise.
* ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE,
IF_STMT_ELSEIF, IF_STMT_ELSE): New macros.
2004-04-08 Thomas Quinot <quinot@act-europe.fr>
* atree.ads: Correct documentation on extended nodes.
* link.c: Set run_path_option for FreeBSD.
2004-04-08 Vincent Celier <celier@gnat.com>
* mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is
one of the ALI file, do not link with DEC lib.
* par.adb Remove the last two characters ("%s" or "%b") when checking
if a language defined unit may be recompiled.
2004-04-08 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Improve error message when
removal of abstract operation leaves no possible interpretation for
expression.
* sem_eval.adb (Eval_Qualified_Expression): Use
Set_Raises_Constraint_Error on node when needed, so that it does not
get optimized away by subsequent optimizations.
* sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of
operands even when they are not wrapped in a type conversion.
2004-04-08 Olivier Hainque <hainque@act-europe.fr>
* sem_prag.adb (Set_Exported): Warn about making static as result of
export only when the export is coming from source. This may be not
be true e.g. on VMS where we expand export pragmas for exception codes
together with imported or exported exceptions, and we don't want the
user to be warned about something he didn't write.
2004-04-08 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb (Note_Possible_Modification): Reorganize to remove code
duplication between normal entities and those declared as renamings.
No functional change.
* s-fileio.ads (Form): Remove pragma Inline, as we cannot currently
inline functions returning an unconstrained result.
2004-04-08 Eric Botcazou <ebotcazou@act-europe.fr>
* utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to
conform to what other front-ends do.
2004-04-08 Doug Rupp <rupp@gnat.com>
* 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared
libraries.
--
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.5
diff -u -p -r1.5 5vml-tgt.adb
--- 5vml-tgt.adb 18 Feb 2004 11:52:54 -0000 1.5
+++ 5vml-tgt.adb 8 Apr 2004 12:20:13 -0000
@@ -50,15 +50,10 @@ package body MLib.Tgt is
-- Used to add the generated auto-init object files for auto-initializing
-- stand-alone libraries.
- Macro_Name : constant String := "macro";
+ Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
-- The name of the command to invoke the macro-assembler
- -- Options to use when invoking gcc to build the dynamic library
-
- No_Start_Files : aliased String := "-nostartfiles";
-
- VMS_Options : Argument_List :=
- (No_Start_Files'Access, null);
+ VMS_Options : Argument_List := (1 .. 1 => null);
Gnatsym_Name : constant String := "gnatsym";
@@ -272,7 +267,7 @@ package body MLib.Tgt is
new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
end if;
- VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
+ VMS_Options (VMS_Options'First) := For_Linker_Opt;
for J in Inter'Range loop
To_Lower (Inter (J).all);
@@ -293,7 +288,7 @@ package body MLib.Tgt is
if Auto_Init then
declare
- Macro_File_Name : constant String := Lib_Filename & "$init.mar";
+ Macro_File_Name : constant String := Lib_Filename & "$init.asm";
Macro_File : Ada.Text_IO.File_Type;
Init_Proc : String := Lib_Filename & "INIT";
Popen_Result : System.Address;
@@ -319,13 +314,12 @@ package body MLib.Tgt is
begin
Create (Macro_File, Out_File, Macro_File_Name);
- Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE");
- Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc);
Put_Line
(Macro_File,
- ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG");
- Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc);
- Put_Line (Macro_File, ASCII.HT & ".END");
+ ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT");
+ Put_Line
+ (Macro_File,
+ ASCII.HT & ".long " & Init_Proc);
Close (Macro_File);
Index: ada-tree.def
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.def,v
retrieving revision 1.8
diff -u -p -r1.8 ada-tree.def
--- ada-tree.def 18 Nov 2003 10:00:42 -0000 1.8
+++ ada-tree.def 8 Apr 2004 12:20:13 -0000
@@ -84,4 +84,26 @@ DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id
We start with an expression statement, whose only operand is an
expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of
the expression (such as a MODIFY_EXPR) and discarding its result. */
-DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1)
+DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
+
+/* This represents a list of statements. BLOCK_STMT_LIST is a list
+ statement tree, chained via TREE_CHAIN. */
+DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
+
+/* This is an IF statement. IF_STMT_COND is the condition being tested,
+ IF_STMT_TRUE is the statement to be executed if the condition is
+ true; IF_STMT_ELSEIF, if non-null, is a list of more IF_STMT nodes (where
+ we only look at IF_STMT_COND and IF_STMT_TRUE) that correspond to
+ any "else if" parts; and IF_STMT_ELSE is the statement to be executed if
+ all conditions are. */
+DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
+
+/* A goto just points to the label: GOTO_STMT_LABEL. */
+DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
+
+/* A label: LABEL_STMT_LABEL is the label and LABEL_STMT_FIRST_IN_EH is set
+ if this is the first label of an exception handler. */
+DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
+
+/* A "return". RETURN_STMT_EXPR is the value to return if non-null. */
+DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.13
diff -u -p -r1.13 ada-tree.h
--- ada-tree.h 19 Mar 2004 15:08:45 -0000 1.13
+++ ada-tree.h 8 Apr 2004 12:20:13 -0000
@@ -294,5 +294,15 @@ struct lang_type GTY(())
/* We store the Sloc in statement nodes. */
#define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE))
-/* There is just one field in an EXPR_STMT: the expression. */
#define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
+#define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0)
+#define IF_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 0)
+#define IF_STMT_TRUE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 1)
+#define IF_STMT_ELSEIF(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 2)
+#define IF_STMT_ELSE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 3)
+#define GOTO_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, GOTO_STMT, 0)
+#define LABEL_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LABEL_STMT, 0)
+#define LABEL_STMT_FIRST_IN_EH(NODE) \
+ (LABEL_STMT_CHECK (NODE)->common.unsigned_flag)
+#define RETURN_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, RETURN_STMT, 0)
+
Index: atree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.ads,v
retrieving revision 1.8
diff -u -p -r1.8 atree.ads
--- atree.ads 12 Feb 2004 13:28:09 -0000 1.8
+++ atree.ads 8 Apr 2004 12:20:14 -0000
@@ -495,7 +495,7 @@ package Atree is
function Extend_Node (Node : Node_Id) return Entity_Id;
-- This function returns a copy of its input node with an extension
-- added. The fields of the extension are set to Empty. Due to the way
- -- extensions are handled (as two consecutive array elements), it may
+ -- extensions are handled (as four consecutive array elements), it may
-- be necessary to reallocate the node, so that the returned value is
-- not the same as the input value, but where possible the returned
-- value will be the same as the input value (i.e. the extension will
Index: link.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/link.c,v
retrieving revision 1.9
diff -u -p -r1.9 link.c
--- link.c 12 Jan 2004 11:45:24 -0000 1.9
+++ link.c 8 Apr 2004 12:20:14 -0000
@@ -156,7 +156,7 @@ const char *object_library_extension = "
#elif defined (__FreeBSD__)
char *object_file_option = "";
-char *run_path_option = "";
+char *run_path_option = "-Wl,-rpath,";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.11
diff -u -p -r1.11 mlib-prj.adb
--- mlib-prj.adb 15 Mar 2004 14:50:59 -0000 1.11
+++ mlib-prj.adb 8 Apr 2004 12:20:14 -0000
@@ -308,6 +308,9 @@ package body MLib.Prj is
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
+ Check_Libdecgnat : Boolean := Hostparm.OpenVMS;
+ -- Set to False if package Dec is part of the library sources.
+
Data : Project_Data := Projects.Table (For_Project);
Object_Directory_Path : constant String :=
@@ -372,7 +375,8 @@ package body MLib.Prj is
-- to link with -lgnarl (this is the case when there is a dependency
-- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
-- indicates that there is a need to link with -ldecgnat (this is the
- -- case when there is a dependency on dec.ads).
+ -- case when there is a dependency on dec.ads, except when it is the
+ -- DEC library, the one that contains package DEC).
procedure Process (The_ALI : File_Name_Type);
-- Check if the closure of a library unit which is or should be in the
@@ -504,12 +508,17 @@ package body MLib.Prj is
Text : Text_Buffer_Ptr;
Id : ALI.ALI_Id;
- pragma Warnings (Off, Id);
- -- Comment needed ???
-
begin
+ -- On OpenVMS, if we have package DEC, it means this is the DEC lib:
+ -- no need to link with itself.
+
+ if Check_Libdecgnat and then ALI_File = "dec.ali" then
+ Check_Libdecgnat := False;
+ Libdecgnat_Needed := False;
+ end if;
+
if not Libgnarl_Needed or
- (Hostparm.OpenVMS and then (not Libdecgnat_Needed))
+ (Check_Libdecgnat and then (not Libdecgnat_Needed))
then
-- Scan the ALI file
@@ -526,7 +535,7 @@ package body MLib.Prj is
Read_Lines => "D");
Free (Text);
- -- Look for s-osinte.ads in the dependencies
+ -- Look for s-osinte.ads and dec.ads in the dependencies
for Index in ALI.ALIs.Table (Id).First_Sdep ..
ALI.ALIs.Table (Id).Last_Sdep
@@ -534,7 +543,7 @@ package body MLib.Prj is
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := True;
- elsif Hostparm.OpenVMS and then
+ elsif Check_Libdecgnat and then
ALI.Sdep.Table (Index).Sfile = S_Dec_Ads
then
Libdecgnat_Needed := True;
@@ -1941,7 +1950,10 @@ package body MLib.Prj is
end if;
Status := fclose (Fd);
- -- Is it really right to ignore any close error ???
+
+ -- It is safe to ignore any error when closing, because the file was
+ -- only opened for reading.
+
end Process_Binder_File;
------------------
Index: par.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par.adb,v
retrieving revision 1.11
diff -u -p -r1.11 par.adb
--- par.adb 1 Apr 2004 10:04:38 -0000 1.11
+++ par.adb 8 Apr 2004 12:20:14 -0000
@@ -1310,16 +1310,24 @@ begin
and then not GNAT_Mode
then
declare
- Name : constant String :=
- Get_Name_String
- (Unit_Name (Current_Source_Unit));
+ Uname : constant String :=
+ Get_Name_String
+ (Unit_Name (Current_Source_Unit));
+ Name : String (1 .. Uname'Length - 2);
+
begin
- if (Name = "ada" or else
- Name = "calendar" or else
- Name = "interfaces" or else
- Name = "system" or else
- Name = "machine_code" or else
- Name = "unchecked_conversion" or else
+ -- Because Unit_Name includes "%s" or "%b", we need to
+ -- strip the last two characters to get the real unit
+ -- name.
+
+ Name := Uname (Uname'First .. Uname'Last - 2);
+
+ if (Name = "ada" or else
+ Name = "calendar" or else
+ Name = "interfaces" or else
+ Name = "system" or else
+ Name = "machine_code" or else
+ Name = "unchecked_conversion" or else
Name = "unchecked_deallocation"
or else (Name'Length > 4
and then
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_ch4.adb
--- sem_ch4.adb 6 Apr 2004 14:21:14 -0000 1.17
+++ sem_ch4.adb 8 Apr 2004 12:20:14 -0000
@@ -4332,7 +4332,7 @@ package body Sem_Ch4 is
procedure Remove_Abstract_Operations (N : Node_Id) is
I : Interp_Index;
It : Interp;
- Has_Abstract_Op : Boolean := False;
+ Abstract_Op : Entity_Id := Empty;
-- AI-310: If overloaded, remove abstract non-dispatching
-- operations.
@@ -4347,7 +4347,7 @@ package body Sem_Ch4 is
and then Is_Abstract (It.Nam)
and then not Is_Dispatching_Operation (It.Nam)
then
- Has_Abstract_Op := True;
+ Abstract_Op := It.Nam;
Remove_Interp (I);
exit;
end if;
@@ -4359,7 +4359,7 @@ package body Sem_Ch4 is
-- always added to the overload set, unless it is a universal
-- operation.
- if not Has_Abstract_Op then
+ if No (Abstract_Op) then
return;
elsif Nkind (N) in N_Op then
@@ -4398,10 +4398,9 @@ package body Sem_Ch4 is
begin
if Present (Universal_Interpretation (Arg1))
- or else
- (Present (Next (Arg1))
- and then
- Present (Universal_Interpretation (Next (Arg1))))
+ and then
+ (No (Next (Arg1))
+ or else Present (Universal_Interpretation (Next (Arg1))))
then
return;
@@ -4416,6 +4415,23 @@ package body Sem_Ch4 is
end loop;
end if;
end;
+ end if;
+
+ -- If the removal has left no valid interpretations, emit
+ -- error message now an label node as illegal.
+
+ if Present (Abstract_Op) then
+ Get_First_Interp (N, I, It);
+
+ if No (It.Nam) then
+
+ -- Removal of abstract operation left no viable candidate.
+
+ Set_Etype (N, Any_Type);
+ Error_Msg_Sloc := Sloc (Abstract_Op);
+ Error_Msg_NE
+ ("cannot call abstract operation& declared#", N, Abstract_Op);
+ end if;
end if;
end if;
end Remove_Abstract_Operations;
Index: sem_eval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_eval.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sem_eval.adb
--- sem_eval.adb 19 Jan 2004 10:37:59 -0000 1.12
+++ sem_eval.adb 8 Apr 2004 12:20:15 -0000
@@ -1947,6 +1947,13 @@ package body Sem_Eval is
or else Nkind (Parent (N)) = N_Allocator
then
Check_Non_Static_Context (Operand);
+
+ -- If operand is known to raise constraint_error, set the
+ -- flag on the expression so it does not get optimized away.
+
+ if Nkind (Operand) = N_Raise_Constraint_Error then
+ Set_Raises_Constraint_Error (N);
+ end if;
return;
end if;
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.24
diff -u -p -r1.24 sem_prag.adb
--- sem_prag.adb 29 Mar 2004 12:03:21 -0000 1.24
+++ sem_prag.adb 8 Apr 2004 12:20:15 -0000
@@ -3555,7 +3555,15 @@ package body Sem_Prag is
Set_Is_Public (E);
Set_Is_Statically_Allocated (E);
- if Warn_On_Export_Import then
+ -- Warn if the corresponding W flag is set and the pragma
+ -- comes from source. The latter may be not be true e.g. on
+ -- VMS where we expand export pragmas for exception codes
+ -- associated with imported or exported exceptions. We don't
+ -- want the user to be warned about something he didn't write.
+
+ if Warn_On_Export_Import
+ and then Comes_From_Source (Arg)
+ then
Error_Msg_NE
("?& has been made static as a result of Export", Arg, E);
Error_Msg_N
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.23
diff -u -p -r1.23 sem_res.adb
--- sem_res.adb 29 Mar 2004 12:03:21 -0000 1.23
+++ sem_res.adb 8 Apr 2004 12:20:15 -0000
@@ -4965,6 +4965,7 @@ package body Sem_Res is
end loop;
Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
-- If the operand type is private, rewrite with suitable
-- conversions on the operands and the result, to expose
@@ -4993,17 +4994,21 @@ package body Sem_Res is
or else Typ /= Etype (Right_Opnd (N))
then
-- Add explicit conversion where needed, and save interpretations
- -- if operands are overloaded.
+ -- in case operands are overloaded.
- Arg1 := Convert_To (Typ, Left_Opnd (N));
+ Arg1 := Convert_To (Typ, Left_Opnd (N));
Arg2 := Convert_To (Typ, Right_Opnd (N));
if Nkind (Arg1) = N_Type_Conversion then
Save_Interps (Left_Opnd (N), Expression (Arg1));
+ else
+ Save_Interps (Left_Opnd (N), Arg1);
end if;
if Nkind (Arg2) = N_Type_Conversion then
Save_Interps (Right_Opnd (N), Expression (Arg2));
+ else
+ Save_Interps (Right_Opnd (N), Arg1);
end if;
Rewrite (Left_Opnd (N), Arg1);
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.25
diff -u -p -r1.25 sem_util.adb
--- sem_util.adb 5 Apr 2004 14:57:40 -0000 1.25
+++ sem_util.adb 8 Apr 2004 12:20:15 -0000
@@ -4985,41 +4985,12 @@ package body Sem_Util is
Ent : Entity_Id;
Exp : Node_Id;
- procedure Set_Ref (E : Entity_Id; N : Node_Id);
- -- Internal routine to note modification on entity E by node N
- -- Has no effect if entity E does not represent an object.
-
- -------------
- -- Set_Ref --
- -------------
-
- procedure Set_Ref (E : Entity_Id; N : Node_Id) is
- begin
- if Is_Object (E) then
- if Comes_From_Source (N)
- or else Modification_Comes_From_Source
- then
- Set_Never_Set_In_Source (E, False);
- end if;
-
- Set_Is_True_Constant (E, False);
- Set_Current_Value (E, Empty);
- Generate_Reference (E, N, 'm');
- Kill_Checks (E);
-
- if not Can_Never_Be_Null (E) then
- Set_Is_Known_Non_Null (E, False);
- end if;
- end if;
- end Set_Ref;
-
- -- Start of processing for Note_Possible_Modification
-
begin
-- Loop to find referenced entity, if there is one
Exp := N;
loop
+ <<Continue>>
Ent := Empty;
if Is_Entity_Name (Exp) then
@@ -5074,10 +5045,14 @@ package body Sem_Util is
-- Now look for entity being referenced
if Present (Ent) then
- if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
- and then Present (Renamed_Object (Ent))
- then
- Set_Never_Set_In_Source (Ent, False);
+
+ if Is_Object (Ent) then
+ if Comes_From_Source (Exp)
+ or else Modification_Comes_From_Source
+ then
+ Set_Never_Set_In_Source (Ent, False);
+ end if;
+
Set_Is_True_Constant (Ent, False);
Set_Current_Value (Ent, Empty);
@@ -5085,13 +5060,18 @@ package body Sem_Util is
Set_Is_Known_Non_Null (Ent, False);
end if;
- Exp := Renamed_Object (Ent);
+ if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
+ and then Present (Renamed_Object (Ent))
+ then
+ Exp := Renamed_Object (Ent);
+ goto Continue;
+ end if;
- else
- Set_Ref (Ent, Exp);
- Kill_Checks (Ent);
- return;
+ Generate_Reference (Ent, Exp, 'm');
end if;
+
+ Kill_Checks (Ent);
+ return;
end if;
end loop;
end Note_Possible_Modification;
Index: s-fileio.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-fileio.ads,v
retrieving revision 1.5
diff -u -p -r1.5 s-fileio.ads
--- s-fileio.ads 21 Oct 2003 13:42:14 -0000 1.5
+++ s-fileio.ads 8 Apr 2004 12:20:15 -0000
@@ -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- --
@@ -250,7 +250,6 @@ package System.File_IO is
private
pragma Inline (Check_Read_Status);
pragma Inline (Check_Write_Status);
- pragma Inline (Form);
pragma Inline (Mode);
end System.File_IO;
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.50
diff -u -p -r1.50 trans.c
--- trans.c 1 Apr 2004 03:50:43 -0000 1.50
+++ trans.c 8 Apr 2004 12:20:16 -0000
@@ -104,6 +104,9 @@ Node_Id error_gnat_node;
static GTY(()) tree gnu_return_label_stack;
static tree tree_transform (Node_Id);
+static rtx first_nondeleted_insn (rtx);
+static tree build_block_stmt (List_Id);
+static tree make_expr_stmt_from_rtl (rtx, Node_Id);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
static void process_inlined_subprograms (Node_Id);
@@ -255,15 +258,60 @@ tree
gnat_to_gnu (Node_Id gnat_node)
{
tree gnu_root;
+ bool made_sequence = false;
+
+ /* We support the use of this on statements now as a transition
+ to full function-at-a-time processing. So we need to see if anything
+ we do generates RTL and returns error_mark_node. */
+ if (!global_bindings_p ())
+ {
+ start_sequence ();
+ emit_note (NOTE_INSN_DELETED);
+ made_sequence = true;
+ }
/* Save node number in case error */
error_gnat_node = gnat_node;
gnu_root = tree_transform (gnat_node);
- /* If we got no code as a result, something is wrong. */
- if (gnu_root == error_mark_node && ! type_annotate_only)
- gigi_abort (303);
+ if (gnu_root == error_mark_node)
+ {
+ if (!made_sequence)
+ {
+ if (type_annotate_only)
+ return gnu_root;
+ else
+ gigi_abort (303);
+ }
+
+ gnu_root = make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()),
+ gnat_node);
+ end_sequence ();
+ }
+ else if (made_sequence)
+ {
+ rtx insns = first_nondeleted_insn (get_insns ());
+
+ end_sequence ();
+
+ if (insns)
+ {
+ /* If we have a statement, we need to first evaluate any RTL we
+ made in the process of building it and then the statement. */
+ if (IS_STMT (gnu_root))
+ {
+ tree gnu_expr_stmt = make_expr_stmt_from_rtl (insns, gnat_node);
+
+ TREE_CHAIN (gnu_expr_stmt) = gnu_root;
+ gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt);
+ TREE_TYPE (gnu_root) = void_type_node;
+ TREE_SLOC (gnu_root) = Sloc (gnat_node);
+ }
+ else
+ emit_insn (insns);
+ }
+ }
return gnu_root;
}
@@ -290,6 +338,10 @@ tree_transform (Node_Id gnat_node)
/* Set input_file_name and lineno from the Sloc in the GNAT tree. */
set_lineno (gnat_node, 0);
+ if (IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
+ && type_annotate_only)
+ return error_mark_node;
+
/* If this is a Statement and we are at top level, we add the statement
as an elaboration for a null tree. That will cause it to be placed
in the elaboration procedure. */
@@ -1795,7 +1847,7 @@ tree_transform (Node_Id gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
+ if (first_nondeleted_insn (RTL_EXPR_SEQUENCE (gnu_rhs_side)))
gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
gnu_rhs);
@@ -2020,31 +2072,17 @@ tree_transform (Node_Id gnat_node)
/***************************/
case N_Label:
- if (! type_annotate_only)
- {
- tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
- Node_Id gnat_parent = Parent (gnat_node);
-
- expand_label (gnu_label);
-
- /* If this is the first label of an exception handler, we must
- mark that any CALL_INSN can jump to it. */
- if (Present (gnat_parent)
- && Nkind (gnat_parent) == N_Exception_Handler
- && First (Statements (gnat_parent)) == gnat_node)
- nonlocal_goto_handler_labels
- = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
- nonlocal_goto_handler_labels);
- }
+ gnu_result = build_nt (LABEL_STMT, gnat_to_gnu (Identifier (gnat_node)));
+ LABEL_STMT_FIRST_IN_EH (gnu_result)
+ = (Present (Parent (gnat_node))
+ && Nkind (Parent (gnat_node)) == N_Exception_Handler
+ && First (Statements (Parent (gnat_node))) == gnat_node);
break;
case N_Null_Statement:
break;
case N_Assignment_Statement:
- if (type_annotate_only)
- break;
-
/* Get the LHS and RHS of the statement and convert any reference to an
unconstrained array into a reference to the underlying array. */
gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
@@ -2071,53 +2109,28 @@ tree_transform (Node_Id gnat_node)
break;
case N_If_Statement:
- /* Start an IF statement giving the condition. */
- gnu_expr = gnat_to_gnu (Condition (gnat_node));
- set_lineno (gnat_node, 1);
- expand_start_cond (gnu_expr, 0);
-
- /* Generate code for the statements to be executed if the condition
- is true. */
+ gnu_result = NULL_TREE;
- for (gnat_temp = First (Then_Statements (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- gnat_to_code (gnat_temp);
-
- /* Generate each of the "else if" parts. */
+ /* Make an IF_STMT for each of the "else if" parts. */
if (Present (Elsif_Parts (gnat_node)))
- {
- for (gnat_temp = First (Elsif_Parts (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_statement;
-
- expand_start_else ();
-
- /* Set up the line numbers for each condition we test. */
- set_lineno (Condition (gnat_temp), 1);
- expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
-
- for (gnat_statement = First (Then_Statements (gnat_temp));
- Present (gnat_statement);
- gnat_statement = Next (gnat_statement))
- gnat_to_code (gnat_statement);
- }
- }
-
- /* Finally, handle any statements in the "else" part. */
- if (Present (Else_Statements (gnat_node)))
- {
- expand_start_else ();
-
- for (gnat_temp = First (Else_Statements (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- gnat_to_code (gnat_temp);
- }
+ for (gnat_temp = First (Elsif_Parts (gnat_node));
+ Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ {
+ tree gnu_elseif
+ = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_temp)),
+ build_block_stmt (Then_Statements (gnat_temp)),
+ NULL_TREE, NULL_TREE);
+
+ TREE_SLOC (gnu_elseif) = Sloc (Condition (gnat_temp));
+ TREE_CHAIN (gnu_elseif) = gnu_result;
+ TREE_TYPE (gnu_elseif) = void_type_node;
+ gnu_result = gnu_elseif;
+ }
- expand_end_cond ();
+ gnu_result = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_node)),
+ build_block_stmt (Then_Statements (gnat_node)),
+ nreverse (gnu_result),
+ build_block_stmt (Else_Statements (gnat_node)));
break;
case N_Case_Statement:
@@ -2456,9 +2469,6 @@ tree_transform (Node_Id gnat_node)
break;
case N_Return_Statement:
- if (type_annotate_only)
- break;
-
{
/* The gnu function type of the subprogram currently processed. */
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
@@ -2478,7 +2488,11 @@ tree_transform (Node_Id gnat_node)
a branch to that label. */
if (TREE_VALUE (gnu_return_label_stack) != 0)
- expand_goto (TREE_VALUE (gnu_return_label_stack));
+ {
+ gnu_result = build_nt (GOTO_STMT,
+ TREE_VALUE (gnu_return_label_stack));
+ break;
+ }
else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
{
@@ -2538,25 +2552,12 @@ tree_transform (Node_Id gnat_node)
}
}
- set_lineno (gnat_node, 1);
- if (gnu_ret_val)
- expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
- DECL_RESULT (current_function_decl),
- gnu_ret_val));
- else
- expand_null_return ();
-
+ gnu_result = build_nt (RETURN_STMT, gnu_ret_val);
}
break;
case N_Goto_Statement:
- if (type_annotate_only)
- break;
-
- gnu_expr = gnat_to_gnu (Name (gnat_node));
- TREE_USED (gnu_expr) = 1;
- set_lineno (gnat_node, 1);
- expand_goto (gnu_expr);
+ gnu_result = build_nt (GOTO_STMT, gnat_to_gnu (Name (gnat_node)));
break;
/****************************/
@@ -4174,17 +4175,128 @@ tree_transform (Node_Id gnat_node)
return gnu_result;
}
\f
+/* INSN is a list of insns. Return the first rtl in the list that isn't
+ an INSN_NOTE_DELETED. */
+
+static rtx
+first_nondeleted_insn (rtx insns)
+{
+ for (; insns && GET_CODE (insns) == NOTE
+ && NOTE_LINE_NUMBER (insns) == NOTE_INSN_DELETED;
+ insns = NEXT_INSN (insns))
+ ;
+
+ return insns;
+}
+\f
+/* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
+
+static tree
+build_block_stmt (List_Id gnat_list)
+{
+ tree gnu_result = NULL_TREE;
+ Node_Id gnat_node;
+
+ if (No (gnat_list) || Is_Empty_List (gnat_list))
+ return NULL_TREE;
+
+ for (gnat_node = First (gnat_list);
+ Present (gnat_node);
+ gnat_node = Next (gnat_node))
+ gnu_result = chainon (gnat_to_gnu (gnat_node), gnu_result);
+
+ gnu_result = build_nt (BLOCK_STMT, nreverse (gnu_result));
+ TREE_SLOC (gnu_result) = TREE_SLOC (BLOCK_STMT_LIST (gnu_result));
+ TREE_TYPE (gnu_result) = void_type_node;
+ return gnu_result;
+}
+
+/* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */
+
+static tree
+make_expr_stmt_from_rtl (rtx insns, Node_Id gnat_node)
+{
+ tree gnu_result = make_node (RTL_EXPR);
+
+ TREE_TYPE (gnu_result) = void_type_node;
+ RTL_EXPR_RTL (gnu_result) = RTL_EXPR_ALT_RTL (gnu_result) = const0_rtx;
+ RTL_EXPR_SEQUENCE (gnu_result) = insns;
+ rtl_expr_chain = tree_cons (NULL_TREE, gnu_result, rtl_expr_chain);
+
+ gnu_result = build_nt (EXPR_STMT, gnu_result);
+ TREE_SLOC (gnu_result) = Sloc (gnat_node);
+ TREE_TYPE (gnu_result) = void_type_node;
+
+ return gnu_result;
+}
+\f
/* GNU_STMT is a statement. We generate code for that statement. */
void
gnat_expand_stmt (tree gnu_stmt)
{
- set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
+ tree gnu_elmt;
+
+ if (TREE_SLOC (gnu_stmt))
+ set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
switch (TREE_CODE (gnu_stmt))
{
case EXPR_STMT:
expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
+ break;
+
+ case BLOCK_STMT:
+ for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt;
+ gnu_elmt = TREE_CHAIN (gnu_elmt))
+ expand_expr_stmt (gnu_elmt);
+ break;
+
+ case IF_STMT:
+ expand_start_cond (IF_STMT_COND (gnu_stmt), 0);
+
+ if (IF_STMT_TRUE (gnu_stmt))
+ expand_expr_stmt (IF_STMT_TRUE (gnu_stmt));
+
+ for (gnu_elmt = IF_STMT_ELSEIF (gnu_stmt); gnu_elmt;
+ gnu_elmt = TREE_CHAIN (gnu_elmt))
+ {
+ expand_start_else ();
+ set_lineno_from_sloc (TREE_SLOC (gnu_elmt), 1);
+ expand_elseif (IF_STMT_COND (gnu_elmt));
+ expand_expr_stmt (IF_STMT_TRUE (gnu_elmt));
+ }
+
+ if (IF_STMT_ELSE (gnu_stmt))
+ {
+ expand_start_else ();
+ expand_expr_stmt (IF_STMT_ELSE (gnu_stmt));
+ }
+
+ expand_end_cond ();
+ break;
+
+ case GOTO_STMT:
+ TREE_USED (GOTO_STMT_LABEL (gnu_stmt)) = 1;
+ expand_goto (GOTO_STMT_LABEL (gnu_stmt));
+ break;
+
+ case LABEL_STMT:
+ expand_label (LABEL_STMT_LABEL (gnu_stmt));
+ if (LABEL_STMT_FIRST_IN_EH (gnu_stmt))
+ nonlocal_goto_handler_labels
+ = gen_rtx_EXPR_LIST (VOIDmode,
+ label_rtx (LABEL_STMT_LABEL (gnu_stmt)),
+ nonlocal_goto_handler_labels);
+ break;
+
+ case RETURN_STMT:
+ if (RETURN_STMT_EXPR (gnu_stmt))
+ expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ RETURN_STMT_EXPR (gnu_stmt)));
+ else
+ expand_null_return ();
break;
default:
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.50
diff -u -p -r1.50 utils.c
--- utils.c 5 Apr 2004 12:25:24 -0000 1.50
+++ utils.c 8 Apr 2004 12:20:16 -0000
@@ -2069,7 +2069,11 @@ float_type_for_precision (int precision,
tree
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
{
- if (GET_MODE_CLASS (mode) == MODE_FLOAT)
+ if (mode == BLKmode)
+ return NULL_TREE;
+ else if (mode == VOIDmode)
+ return void_type_node;
+ else if (GET_MODE_CLASS (mode) == MODE_FLOAT)
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-06 14:21 Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-06 14:21 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-04-06 Pascal Obry <obry@gnat.com>
* adaint.c (DIR_SEPARATOR): Properly set DIR_SEPARATOR on Win32.
* osint.adb (Program_Name): Do not look past a directory separator.
2004-04-06 Thomas Quinot <quinot@act-europe.fr>
* atree.adb: Update comment (Rewrite_Substitute_Node no longer exists).
* exp_ch6.adb (Rewrite_Function_Call): Clarify documentation of
requirement for preserving a copy of the original assignment node.
* sinfo.ads: Update comment (Original_Tree -> Original_Node).
2004-04-06 Olivier Hainque <hainque@act-europe.fr>
(__gnat_initialize [Vxworks]): Enable references to the crtstuff bits
when supported.
2004-04-06 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Extend previous changes to
operator calls in functional notation, and apply
Universal_Interpretation to operands, not to their type.
2004-04-06 Robert Dewar <dewar@gnat.com>
* 5wdirval.adb: Minor reformatting
2004-04-06 Ed Falis <falis@gnat.com>
* gnat_rm.texi: Improve a reference to the GCC manual
--
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.29
diff -u -p -r1.29 adaint.c
--- adaint.c 5 Apr 2004 14:57:32 -0000 1.29
+++ adaint.c 6 Apr 2004 13:36:09 -0000
@@ -147,6 +147,8 @@ struct vstring
#if defined (_WIN32)
#include <dir.h>
#include <windows.h>
+#undef DIR_SEPARATOR
+#define DIR_SEPARATOR '\\'
#endif
#include "adaint.h"
@@ -2525,4 +2527,3 @@ get_gcc_version (void)
{
return 3;
}
-
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.12
diff -u -p -r1.12 atree.adb
--- atree.adb 12 Feb 2004 13:28:09 -0000 1.12
+++ atree.adb 6 Apr 2004 13:36:10 -0000
@@ -2114,8 +2114,7 @@ package body Atree is
-- Since we are doing a replace, we assume that the original node
-- is intended to become the new replaced node. The call would be
- -- to Rewrite_Substitute_Node if there were an intention to save
- -- the original node.
+ -- to Rewrite if there were an intention to save the original node.
Orig_Nodes.Table (Old_Node) := Old_Node;
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.24
diff -u -p -r1.24 exp_ch6.adb
--- exp_ch6.adb 5 Apr 2004 14:57:34 -0000 1.24
+++ exp_ch6.adb 6 Apr 2004 13:36:10 -0000
@@ -2466,6 +2466,9 @@ package body Exp_Ch6 is
-- complete assignment subtree consistent enough for
-- Analyze_Assignment to proceed. We do not use the
-- saved value, the point was just to do the relocation.
+ -- We cannot rely on Original_Node to go back from the
+ -- block node to the assignment node, because the
+ -- assignment might already be a rewrite substitution.
begin
Rewrite (Original_Assignment, Blk);
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.29
diff -u -p -r1.29 init.c
--- init.c 5 Apr 2004 14:57:35 -0000 1.29
+++ init.c 6 Apr 2004 13:36:11 -0000
@@ -1797,13 +1797,16 @@ __gnat_initialize (void)
call the appropriate function here. We'll never unload that, so there is
no de-registration to worry about.
- We can differentiate between the two cases by looking at the
- __module_has_ctors value provided by each class of crt objects. As of
- today, selecting the crt set intended for applications to be statically
- linked with the kernel is triggered by adding "-static" to the gcc *link*
- command line options. */
+ We can differentiate by looking at the __module_has_ctors value provided
+ by each class of crt objects. As of today, selecting the crt set intended
+ for applications to be statically linked with the kernel is triggered by
+ adding "-static" to the gcc *link* command line options.
-#if 0
+ This is a first approach, tightly synchronized with a number of GCC
+ configuration and crtstuff changes. We need to ensure that those changes
+ are there to activate this circuitry. */
+
+#if DWARF2_UNWIND_INFO && defined (_ARCH_PPC)
{
extern const int __module_has_ctors;
extern void __do_global_ctors ();
Index: osint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.adb,v
retrieving revision 1.19
diff -u -p -r1.19 osint.adb
--- osint.adb 1 Apr 2004 10:04:38 -0000 1.19
+++ osint.adb 6 Apr 2004 13:36:11 -0000
@@ -1794,7 +1794,17 @@ package body Osint is
-- "alpha-dec-vxworks-"
while Name_Len > 0 loop
+
+ -- All done if we find the last hyphen
+
if Name_Buffer (Name_Len) = '-' then
+ exit;
+
+ -- If directory separator found, we don't want to look further
+ -- since in this case, no prefix has been found.
+
+ elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
+ Name_Len := 0;
exit;
end if;
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_ch4.adb
--- sem_ch4.adb 5 Apr 2004 14:57:40 -0000 1.16
+++ sem_ch4.adb 6 Apr 2004 13:36:11 -0000
@@ -4359,20 +4359,18 @@ package body Sem_Ch4 is
-- always added to the overload set, unless it is a universal
-- operation.
- if Nkind (N) in N_Op
- and then Has_Abstract_Op
- then
+ if not Has_Abstract_Op then
+ return;
+
+ elsif Nkind (N) in N_Op then
if Nkind (N) in N_Unary_Op
- and then
- Present (Universal_Interpretation (Etype (Right_Opnd (N))))
+ and then Present (Universal_Interpretation (Right_Opnd (N)))
then
return;
elsif Nkind (N) in N_Binary_Op
- and then
- Present (Universal_Interpretation (Etype (Right_Opnd (N))))
- and then
- Present (Universal_Interpretation (Etype (Left_Opnd (N))))
+ and then Present (Universal_Interpretation (Right_Opnd (N)))
+ and then Present (Universal_Interpretation (Left_Opnd (N)))
then
return;
@@ -4386,6 +4384,38 @@ package body Sem_Ch4 is
Get_Next_Interp (I, It);
end loop;
end if;
+
+ elsif Nkind (N) = N_Function_Call
+ and then
+ (Nkind (Name (N)) = N_Operator_Symbol
+ or else
+ (Nkind (Name (N)) = N_Expanded_Name
+ and then
+ Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
+ then
+ declare
+ Arg1 : constant Node_Id := First (Parameter_Associations (N));
+
+ begin
+ if Present (Universal_Interpretation (Arg1))
+ or else
+ (Present (Next (Arg1))
+ and then
+ Present (Universal_Interpretation (Next (Arg1))))
+ then
+ return;
+
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Nam) loop
+ if Scope (It.Nam) = Standard_Standard then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end;
end if;
end if;
end Remove_Abstract_Operations;
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.25
diff -u -p -r1.25 sinfo.ads
--- sinfo.ads 5 Apr 2004 14:57:41 -0000 1.25
+++ sinfo.ads 6 Apr 2004 13:36:11 -0000
@@ -1519,7 +1519,7 @@ package Sinfo is
-- stub. During the analysis procedure, stubs in some situations
-- get rewritten by the corresponding bodies, and we set this flag
-- to remember that this happened. Note that it is not good enough
- -- to rely on the use of Original_Tree here because of the case of
+ -- to rely on the use of Original_Node here because of the case of
-- nested instantiations where the substituted node can be copied.
-- Zero_Cost_Handling (Flag5-Sem)
Index: 5wdirval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wdirval.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5wdirval.adb
--- 5wdirval.adb 5 Apr 2004 14:57:42 -0000 1.1
+++ 5wdirval.adb 6 Apr 2004 13:36:12 -0000
@@ -52,6 +52,7 @@ package body Ada.Directories.Validity is
function Is_Valid_Path_Name (Name : String) return Boolean is
Start : Positive := Name'First;
Last : Natural;
+
begin
-- A path name cannot be empty, cannot contain more than 256 characters,
-- cannot contain invalid characters and each directory/file name need
@@ -114,7 +115,8 @@ package body Ada.Directories.Validity is
--------------------------
function Is_Valid_Simple_Name (Name : String) return Boolean is
- Only_Spaces : Boolean := True;
+ Only_Spaces : Boolean;
+
begin
-- A file name cannot be empty, cannot contain more than 256 characters,
-- and cannot contain invalid characters, including '\'
@@ -122,20 +124,22 @@ package body Ada.Directories.Validity is
if Name'Length = 0 or else Name'Length > 256 then
return False;
+ -- Name length is OK
+
else
+ Only_Spaces := True;
for J in Name'Range loop
if Invalid_Character (Name (J)) or else Name (J) = '\' then
return False;
-
elsif Name (J) /= ' ' then
Only_Spaces := False;
end if;
end loop;
- end if;
- -- If Name follows the rules, it is valid
+ -- If no invalid chars, and not all spaces, file name is valid.
- return not Only_Spaces;
+ return not Only_Spaces;
+ end if;
end Is_Valid_Simple_Name;
end Ada.Directories.Validity;
Index: gnat_rm.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat_rm.texi,v
retrieving revision 1.15
diff -u -p -r1.15 gnat_rm.texi
--- gnat_rm.texi 2 Apr 2004 08:52:48 -0000 1.15
+++ gnat_rm.texi 6 Apr 2004 13:36:23 -0000
@@ -62,7 +62,7 @@ GNAT Reference Manual
@noindent
GNAT, The GNU Ada 95 Compiler@*
-Version for GCC @value{version-GCC}@*
+GCC version @value{version-GCC}@*
@noindent
Ada Core Technologies, Inc.
@@ -12688,15 +12688,17 @@ including machine instructions in a subp
@end itemize
@noindent
-The two features are similar, and both closely related to the mechanism
+The two features are similar, and both are closely related to the mechanism
provided by the asm instruction in the GNU C compiler. Full understanding
and use of the facilities in this package requires understanding the asm
-instruction as described in
-@cite{Using and Porting the GNU Compiler Collection (GCC)} by Richard
-Stallman. Calls to the function @code{Asm} and the procedure @code{Asm}
-have identical semantic restrictions and effects as described below.
-Both are provided so that the procedure call can be used as a statement,
-and the function call can be used to form a code_statement.
+instruction as described in @cite{Using the GNU Compiler Collection (GCC)}
+by Richard Stallman. The relevant section is titled ``Extensions to the C
+Language Family'' -> ``Assembler Instructions with C Expression Operands''.
+
+Calls to the function @code{Asm} and the procedure @code{Asm} have identical
+semantic restrictions and effects as described below. Both are provided so
+that the procedure call can be used as a statement, and the function call
+can be used to form a code_statement.
The first example given in the GCC documentation is the C @code{asm}
instruction:
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-04-05 14:58 Arnaud Charlet
@ 2004-04-06 14:21 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-06 14:21 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4132 bytes --]
Tested on x86-linux
--
2004-04-05 Vincent Celier <celier@gnat.com>
* adaint.h, adaint.c: Add function __gnat_named_file_length
* impunit.adb: Add Ada.Directories to the list
* Makefile.in: Add VMS and Windows versions of
Ada.Directories.Validity package body.
* Makefile.rtl: Add a-direct and a-dirval
* mlib-tgt.ads: Minor comment update.
* a-dirval.ads, a-dirval.adb, 5vdirval.adb, 5wdirval.adb,
a-direct.ads, a-direct.adb: New files.
2004-04-05 Vincent Celier <celier@gnat.com>
PR ada/13620
* make.adb (Scan_Make_Arg): Pass any -fxxx switches to gnatlink, not
just to the compiler.
2004-04-05 Robert Dewar <dewar@gnat.com>
* a-except.adb (Exception_Name_Simple): Make sure lower bound of
returned string is 1.
* ali-util.adb: Use proper specific form for Warnings (Off, entity)
* eval_fat.ads: Minor reformatting
* g-curexc.ads: Document that lower bound of returned string values
is always one.
* gnatlink.adb: Add ??? comment for previous change
(need to document why this is VMS specific)
* s-stoele.ads: Minor reformatting
* tbuild.ads: Minor reformatting throughout (new function specs)
* par-ch10.adb (P_Context_Clause): Handle comma instead of semicolon
after WITH.
* scng.adb: Minor reformatting
2004-04-05 Geert Bosch <bosch@gnat.com>
* eval_fat.adb (Machine): Remove unnecessary suppression of warning.
(Leading_Part): Still perform truncation to machine number if the
specified radix_digits is greater or equal to machine_mantissa.
2004-04-05 Javier Miranda <miranda@gnat.com>
* par-ch3.adb: Complete documentation of previous change
Correct wrong syntax documentation of the OBJECT_DECLARATION rule
(aliased must appear before constant).
* par-ch4.adb: Complete documentation of previous change.
* par-ch6.adb: Complete documentation of previous change.
* sinfo.ads: Fix typo in commment.
2004-04-05 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Inherit_Components): If derived type is private and has
stored discriminants, use its discriminants to constrain parent type,
as is done for non-private derived record types.
* sem_ch4.adb (Remove_Abstract_Operations): New subprogram to implement
Ada 2005 AI-310: an abstract non-dispatching operation is not a
candidate interpretation in an overloaded call.
* tbuild.adb (Unchecked_Convert_To): Preserve conversion node if
expression is Null and target type is not an access type (e.g. a
non-private address type).
2004-04-05 Thomas Quinot <quinot@act-europe.fr>
* exp_ch6.adb (Rewrite_Function_Call): When rewriting an assignment
statement whose right-hand side is an inlined call, save a copy of the
original assignment subtree to preserve enough consistency for
Analyze_Assignment to proceed.
* sem_ch5.adb (Analyze_Assignment): Remove a costly copy of the
complete assignment subtree which is now unnecessary, as the expansion
of inlined call has been improved to preserve a consistent assignment
tree. Note_Possible_Modification must be called only
after checks have been applied, or else unnecessary checks will
be generated.
* sem_util.adb (Note_Possible_Modification): Reorganise the handling
of explicit dereferences that do not Come_From_Source:
- be selective on cases where we must go back to the dereferenced
pointer (an assignment to an implicit dereference must not be
recorded as modifying the pointer);
- do not rely on Original_Node being present (Analyze_Assignment
calls Note_Possible_Modification on a copied tree).
* sem_warn.adb (Check_References): When an unset reference to a pointer
that is never assigned is encountered, prefer '<pointer> may be null'
warning over '<pointer> is never assigned a value'.
2004-04-05 Ramon Fernandez <fernandez@gnat.com>
* tracebak.c: Change STOP_FRAME in ppc vxworks to be compliant with
the ABI.
2004-04-05 Olivier Hainque <hainque@act-europe.fr>
* 5gmastop.adb (Pop_Frame): Comment out the pragma Linker_Option for
libexc. We currently don't reference anything in this library and
linking it in triggers linker warnings we don't want to see.
* init.c: Update comments.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 15602 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-04-01 10:06 Arnaud Charlet
@ 2004-04-06 14:21 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-06 14:21 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3086 bytes --]
Tested on x86-linux
--
2004-04-01 Robert Dewar <dewar@gnat.com>
* checks.adb: Minor reformatting throughout
Note that prev checkin added RM reference to alignment warning
2004-04-01 Ed Schonberg <schonberg@gnat.com>
* exp_aggr.adb (Get_Component_Val): Treat a string literal as
non-static when building aggregate for bit-packed array.
* exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a
function call that is itself the actual in a procedure call, build
temporary for it.
* exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is
a string literal, create a temporary for it, constant folding only
handles scalars here.
2004-04-01 Vincent Celier <celier@gnat.com>
* ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC,
Error_Msg_SP): New empty procedures to instantiate the Scanner.
(Style, Scanner): Instantiations of Styleg and Scng to be able to scan
tokens.
(Accumulate_Checksum, Initialize_Checksum): Remove procedures.
(Get_File_Checksum): Use the instantiated scanner to scan all the tokens
and get the checksum.
* make.adb (Gnatmake): Do not insert into Q the Main_Source if it is
already in the Q.
Increase the Marking_Label at the end of the Multiple_Main_Loop,
instead of at the beginning.
* osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~'
directly.
(Osint package elaboration): Change Multi_Unit_Index_Character to '$' if
on VMS.
* osint.ads (Multi_Unit_Index_Character): New Character global variable
* osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character,
not '~' directly.
* par.adb: Remove test on file name to detect language defined units.
Add test on unit name, after parsing, to detect language defined units
that are not compiled with -gnatg (except System.RPC and its children)
* par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the
following units without style checking.
* switch-c.adb: Change -gnatC to -gnateI
* usage.adb: Document new switch -gnateInnn
* scng.adb (Accumulate_Token_Checksum): New procedure
(Scan): Call Accumulate_Token_Checksum after each identifier, reserved
word or literal number.
(Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral
numbers.
2004-04-01 Thomas Quinot <quinot@act-europe.fr>
* a-tasatt.adb,
g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb,
switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb,
5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb,
5vtpopde.adb: Add missing 'constant' keywords.
2004-04-01 Javier Miranda <miranda@gnat.com>
* par-ch4.adb: (P_Allocator): Code cleanup
* sem_ch3.adb (Access_Definition): Properly set the null-excluding
attribute.
* sinfo.ads: Complete documentation of previous change
2004-04-01 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2004-04-01 Pascal Obry <obry@gnat.com>
* gnatlink.adb (Process_Binder_File): Remove duplicate linker options
only on VMS. This special handling was done because an old GNU/ld bug
on Windows which has been fixed.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 15309 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-05 14:58 Arnaud Charlet
2004-04-06 14:21 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
0 siblings, 2 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-05 14:58 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4132 bytes --]
Tested on x86-linux
--
2004-04-05 Vincent Celier <celier@gnat.com>
* adaint.h, adaint.c: Add function __gnat_named_file_length
* impunit.adb: Add Ada.Directories to the list
* Makefile.in: Add VMS and Windows versions of
Ada.Directories.Validity package body.
* Makefile.rtl: Add a-direct and a-dirval
* mlib-tgt.ads: Minor comment update.
* a-dirval.ads, a-dirval.adb, 5vdirval.adb, 5wdirval.adb,
a-direct.ads, a-direct.adb: New files.
2004-04-05 Vincent Celier <celier@gnat.com>
PR ada/13620
* make.adb (Scan_Make_Arg): Pass any -fxxx switches to gnatlink, not
just to the compiler.
2004-04-05 Robert Dewar <dewar@gnat.com>
* a-except.adb (Exception_Name_Simple): Make sure lower bound of
returned string is 1.
* ali-util.adb: Use proper specific form for Warnings (Off, entity)
* eval_fat.ads: Minor reformatting
* g-curexc.ads: Document that lower bound of returned string values
is always one.
* gnatlink.adb: Add ??? comment for previous change
(need to document why this is VMS specific)
* s-stoele.ads: Minor reformatting
* tbuild.ads: Minor reformatting throughout (new function specs)
* par-ch10.adb (P_Context_Clause): Handle comma instead of semicolon
after WITH.
* scng.adb: Minor reformatting
2004-04-05 Geert Bosch <bosch@gnat.com>
* eval_fat.adb (Machine): Remove unnecessary suppression of warning.
(Leading_Part): Still perform truncation to machine number if the
specified radix_digits is greater or equal to machine_mantissa.
2004-04-05 Javier Miranda <miranda@gnat.com>
* par-ch3.adb: Complete documentation of previous change
Correct wrong syntax documentation of the OBJECT_DECLARATION rule
(aliased must appear before constant).
* par-ch4.adb: Complete documentation of previous change.
* par-ch6.adb: Complete documentation of previous change.
* sinfo.ads: Fix typo in commment.
2004-04-05 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Inherit_Components): If derived type is private and has
stored discriminants, use its discriminants to constrain parent type,
as is done for non-private derived record types.
* sem_ch4.adb (Remove_Abstract_Operations): New subprogram to implement
Ada 2005 AI-310: an abstract non-dispatching operation is not a
candidate interpretation in an overloaded call.
* tbuild.adb (Unchecked_Convert_To): Preserve conversion node if
expression is Null and target type is not an access type (e.g. a
non-private address type).
2004-04-05 Thomas Quinot <quinot@act-europe.fr>
* exp_ch6.adb (Rewrite_Function_Call): When rewriting an assignment
statement whose right-hand side is an inlined call, save a copy of the
original assignment subtree to preserve enough consistency for
Analyze_Assignment to proceed.
* sem_ch5.adb (Analyze_Assignment): Remove a costly copy of the
complete assignment subtree which is now unnecessary, as the expansion
of inlined call has been improved to preserve a consistent assignment
tree. Note_Possible_Modification must be called only
after checks have been applied, or else unnecessary checks will
be generated.
* sem_util.adb (Note_Possible_Modification): Reorganise the handling
of explicit dereferences that do not Come_From_Source:
- be selective on cases where we must go back to the dereferenced
pointer (an assignment to an implicit dereference must not be
recorded as modifying the pointer);
- do not rely on Original_Node being present (Analyze_Assignment
calls Note_Possible_Modification on a copied tree).
* sem_warn.adb (Check_References): When an unset reference to a pointer
that is never assigned is encountered, prefer '<pointer> may be null'
warning over '<pointer> is never assigned a value'.
2004-04-05 Ramon Fernandez <fernandez@gnat.com>
* tracebak.c: Change STOP_FRAME in ppc vxworks to be compliant with
the ABI.
2004-04-05 Olivier Hainque <hainque@act-europe.fr>
* 5gmastop.adb (Pop_Frame): Comment out the pragma Linker_Option for
libexc. We currently don't reference anything in this library and
linking it in triggers linker warnings we don't want to see.
* init.c: Update comments.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 15602 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-04-01 10:06 Arnaud Charlet
2004-04-06 14:21 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
0 siblings, 2 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-04-01 10:06 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3086 bytes --]
Tested on x86-linux
--
2004-04-01 Robert Dewar <dewar@gnat.com>
* checks.adb: Minor reformatting throughout
Note that prev checkin added RM reference to alignment warning
2004-04-01 Ed Schonberg <schonberg@gnat.com>
* exp_aggr.adb (Get_Component_Val): Treat a string literal as
non-static when building aggregate for bit-packed array.
* exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a
function call that is itself the actual in a procedure call, build
temporary for it.
* exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is
a string literal, create a temporary for it, constant folding only
handles scalars here.
2004-04-01 Vincent Celier <celier@gnat.com>
* ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC,
Error_Msg_SP): New empty procedures to instantiate the Scanner.
(Style, Scanner): Instantiations of Styleg and Scng to be able to scan
tokens.
(Accumulate_Checksum, Initialize_Checksum): Remove procedures.
(Get_File_Checksum): Use the instantiated scanner to scan all the tokens
and get the checksum.
* make.adb (Gnatmake): Do not insert into Q the Main_Source if it is
already in the Q.
Increase the Marking_Label at the end of the Multiple_Main_Loop,
instead of at the beginning.
* osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~'
directly.
(Osint package elaboration): Change Multi_Unit_Index_Character to '$' if
on VMS.
* osint.ads (Multi_Unit_Index_Character): New Character global variable
* osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character,
not '~' directly.
* par.adb: Remove test on file name to detect language defined units.
Add test on unit name, after parsing, to detect language defined units
that are not compiled with -gnatg (except System.RPC and its children)
* par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the
following units without style checking.
* switch-c.adb: Change -gnatC to -gnateI
* usage.adb: Document new switch -gnateInnn
* scng.adb (Accumulate_Token_Checksum): New procedure
(Scan): Call Accumulate_Token_Checksum after each identifier, reserved
word or literal number.
(Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral
numbers.
2004-04-01 Thomas Quinot <quinot@act-europe.fr>
* a-tasatt.adb,
g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb,
switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb,
5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb,
5vtpopde.adb: Add missing 'constant' keywords.
2004-04-01 Javier Miranda <miranda@gnat.com>
* par-ch4.adb: (P_Allocator): Code cleanup
* sem_ch3.adb (Access_Definition): Properly set the null-excluding
attribute.
* sinfo.ads: Complete documentation of previous change
2004-04-01 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2004-04-01 Pascal Obry <obry@gnat.com>
* gnatlink.adb (Process_Binder_File): Remove duplicate linker options
only on VMS. This special handling was done because an old GNU/ld bug
on Windows which has been fixed.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 15309 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-29 12:03 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-29 12:03 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5697 bytes --]
Tested on x86-linux
--
2004-03-29 Javier Miranda <miranda@gnat.com>
* checks.adb (Null_Exclusion_Static_Checks): New subprogram
(Install_Null_Excluding_Check): Local subprogram that determines whether
an access node requires a runtime access check and if so inserts the
appropriate run-time check.
(Apply_Access_Check): Call Install_Null_Excluding check if required
(Apply_Constraint_Check): Call Install_Null_Excluding check if required
* checks.ads: (Null_Exclusion_Static_Checks): New subprogram
* einfo.ads: Fix typo in comment
* exp_ch3.adb (Build_Assignment): Generate conversion to the
null-excluding type to force the corresponding run-time check.
(Expand_N_Object_Declaration): Generate conversion to the null-excluding
type to force the corresponding run-time check.
* exp_ch5.adb (Expand_N_Assignment_Statement): Generate conversion to
the null-excluding type to force the corresponding run-time check.
* exp_ch6.adb (Expand_Call): Do not generate the run-time check in
case of access types unless they have the null-excluding attribute.
* sprint.adb (Sprint_Node_Actual): Give support to the null-exclusing
part.
* exp_util.ads: Fix typo in comment
* par.adb (P_Null_Exclusion): New subprogram
(P_Subtype_Indication): New formal that indicates if the null-excluding
part has been scanned-out and it was present
* par-ch3.adb, par-ch4.adb, par-ch6.adb: Give support to AI-231
* sem_aggr.adb: (Check_Can_Never_Be_Null): New subprogram
(Aggregate_Constraint_Checks): Generate conversion to the null-excluding
type to force the corresponding run-time check
(Resolve_Aggregate): Propagate the null-excluding attribute to the array
components
(Resolve_Array_Aggregate): Carry out some static checks
(Resolve_Record_Aggregate.Get_Value): Carry out some static check
* sem_ch3.adb (Access_Definition): In Ada 0Y the Can_Never_Be_Null
attribute must be set only if specified by means of the null-excluding
part. In addition, we must also propagate the access-constant attribute
if present.
(Access_Subprogram_Declaration, Access_Type_Declaration,
Analyze_Component_Declaration, Analyze_Object_Declaration,
Array_Type_Declaration, Process_Discriminants,
Analyze_Subtype_Declaration): Propagate the null-excluding attribute
and carry out some static checks.
(Build_Derived_Access_Type): Set the null-excluding attribute
(Derived_Type_Declaration, Process_Subtype): Carry out some static
checks.
* sem_ch4.adb (Analyze_Allocator): Carry out some static checks
* sem_ch5.adb (Analyze_Assignment): Carry out some static checks
* sem_ch6.adb (Process_Formals): Carry out some static checks.
(Set_Actual_Subtypes): Generate null-excluding subtype if the
null-excluding part was present; it is not required to be done here in
case of anonymous access types.
(Set_Formal_Mode): Ada 0Y allows anonymous access to have the null
value.
* sem_res.adb (Resolve_Actuals): Carry out some static check
(Resolve_Null): Allow null in anonymous access
* sinfo.adb: New subprogram Null_Exclusion_Present
All_Present and Constant_Present available on access_definition nodes
* sinfo.ads: New flag Null_Exclusion_Present on subtype_declaration,
object_declaration, derived_type_definition, component_definition,
discriminant_specification, access_to_object_definition,
access_function_definition, allocator, access_procedure_definition,
access_definition, parameter_specification, All_Present and
Constant_Present flags available on access_definition nodes.
2004-03-29 Robert Dewar <dewar@gnat.com>
* fname.adb, fname.ads, fname-sf.adb, fname-uf.adb, fname-uf.ads,
gnat1drv.adb, lib.adb, lib.ads, lib-load.adb, lib-writ.adb,
opt.ads, osint.adb, osint.ads, osint-c.adb, par.adb,
par-ch10.adb, par-load.adb, par-prag.adb, sfn_scan.adb,
sfn_scan.ads, sinput-l.adb, sinput-l.ads, switch-c.adb,
sem_prag.adb: Updates to handle multiple units/file
* par.adb: Change test for s-rpc to s-rp for detecting rpc and children
* par.adb, memtrack.adb, prj-makr.adb, prj-part.adb,
sem_util.adb: Minor reformatting
* sem_ch12.adb: Add comment for previous change
2004-03-29 Laurent Pautet <pautet@act-europe.fr>
* osint.adb (Executable_Prefix): Set Exec_Name to the current
executable name when not initialized. Otherwise, use its current value.
* osint.ads (Exec_Name): Move Exec_Name from body to spec in order to
initialize it to another executable name than the current one. This
allows to configure paths for an executable name (gnatmake) different
from the current one (gnatdist).
2004-03-29 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Expand_Call): A call to a function declared in the
current unit cannot be inlined if it appears in the body of a withed
unit, to avoid order of elaboration problems in gigi.
* exp_ch9.adb (Build_Protected_Sub_Specification): Generate debugging
information for protected (wrapper) operation as well, to simplify gdb
use.
* sem_ch6.adb (Analyze_Subprogram_Body): For a private operation in a
protected body, indicate that the entity for the generated spec comes
from source, to ensure that references are properly generated for it.
(Build_Body_To_Inline): Do not inline a function that returns a
controlled type.
* sem_prag.adb (Process_Convention): If subprogram is overloaded, only
apply convention to homonyms that are declared explicitly.
* sem_res.adb (Make_Call_Into_Operator): If the operation is a function
that renames an equality operator and the operands are overloaded,
resolve them with the declared formal types, before rewriting as an
operator.
2004-03-29 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 36161 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-25 16:00 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-25 16:00 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2779 bytes --]
Tested on x86-linux
--
2004-03-25 Vasiliy Fofanov <fofanov@act-europe.fr>
* memtrack.adb: Log realloc calls, which are treated as free followed
by alloc.
2004-03-25 Vincent Celier <celier@gnat.com>
* prj-makr.adb (Process_Directories): Detect when a file contains
several units. Do not include such files in the config pragmas or
in the naming scheme.
* prj-nmsc.adb (Record_Source): New parameter Trusted_Mode.
Resolve links only when not in Trusted_Mode.
(Find_Sources, Recursive_Find_Dirs, Find_Source_Dirs, Locate_Directory):
Do not resolve links for the display names.
* prj-part.adb (Parse_Single_Project, Project_Path_Name_Of): Do not
resolve links when computing the display names.
2004-03-25 Thomas Quinot <quinot@act-europe.fr>
* sem_attr.adb (Check_Dereference): When the prefix of a 'Tag
attribute reference does not denote a subtype, it can be any
expression that has a classwide type, potentially after an implicit
dereference. In particular, the prefix can be a view conversion for
a classwide type (for which Is_Object_Reference holds), but it can
also be a value conversion for an access-to-classwide type. In the
latter case, there is an implicit dereference, and the original node
for the prefix does not verify Is_Object_Reference.
* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): A view
conversion of a discriminant-dependent component of a mutable object
is one itself.
2004-03-25 Ed Schonberg <schonberg@gnat.com>
* freeze.adb (Freeze_Entity): When an inherited subprogram is
inherited, has convention C, and has unconstrained array parameters,
place the corresponding warning on the derived type declaration rather
than the original subprogram.
* sem_ch12.adb (Instantiate_Formal_Subprogram): Set From_Default
indication on renaming declaration, if formal has a box and actual
is absent.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Use From_Default flag to
determine whether to generate an implicit or explicit reference to
the renamed entity.
* sinfo.ads, sinfo.adb: New flag From_Default, to indicate that a
subprogram renaming comes from a defaulted formal subprogram in an
instance.
2004-03-25 Gary Dismukes <dismukes@gnat.com>
* sem_elab.adb (Check_Elab_Call): Refine loop that checks for default
value expressions to ensure that calls within a component definition
will be checked (since those are evaluated during the record type's
elaboration).
2004-03-25 Arnaud Charlet <charlet@act-europe.fr>
* s-tpobop.adb: Code clean up:
(Requeue_Call): Extract from PO_Service_Entries to remove duplicated
code.
(PO_Do_Or_Queue): Remove duplicated code and use Requeue_Call.
2004-03-25 Jose Ruiz <ruiz@act-europe.fr>
* Makefile.in: Clean up in the ravenscar run time.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 10974 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-22 14:07 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-22 14:07 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1916 bytes --]
Tested on x86-linux
--
2004-03-22 Cyrille Comar <comar@act-europe.fr>
* ali.ads: Fix Comment about Dynamic_Elab.
* gnatls.adb (Output_Unit): Add output of many flags (Dynamic_Elab,
Has_RACW, Is_Generic, etc.)
(Output_Object, Gnatls): Take into account ALI files not attached to
an object.
2004-03-22 Vincent Celier <celier@gnat.com>
* gprep.adb: Change all String_Access to Name_Id
(Is_ASCII_Letter): new function
(Double_File_Name_Buffer): New procedure
(Preprocess_Infile_Name): New procedure
(Process_Files): New procedure
(Gnatprep): Check if output and input are existing directories.
Call Process_Files to do the real job.
2004-03-22 Robert Dewar <dewar@gnat.com>
* prj-env.adb, prj-nmsc.ads, prj-proc.ads,
s-stache.ads, s-stache.adb: Comment updates. Minor reformatting.
2004-03-22 Sergey Rybin <rybin@act-europe.fr>
* scn.adb (Contains): Add check for EOF, is needed for a degenerated
case when the source contains only comments.
2004-03-22 Ed Schonberg <schonberg@gnat.com>
* sem_ch10.adb (Analyze_Compilation_Unit): When generating a
declaration for a child subprogram body that acts as a spec, indicate
that the entity in the declaration needs debugging information.
* sem_ch3.adb (Complete_Private_Subtype): Do not build an underlying
full view if the subtype is created for a constrained record component;
gigi has enough information to construct the record, and there is no
place in the tree for the declaration.
* sem_ch6.adb (Build_Body_To_Inline): Use an internal name without
serial number for the dummy body that is built for analysis, to avoid
inconsistencies in the generation of internal names when compiling
with -gnatN.
2004-03-22 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb (Is_Object_Reference): A view conversion denotes an
object.
2004-03-22 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 10796 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-19 16:13 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-19 16:13 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-03-19 Arnaud Charlet <charlet@act-europe.fr>
* ada-tree.h: Update copyright notice.
Minor reformatting.
2004-03-19 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_entity, case E_Exception): Handle VMS exceptions
as regular exception objects and not as mere integers representing the
condition code. The latter approach required some dynamics to mask off
severity bits, which did not fit well into the GCC table based model.
(gnat_to_gnu_entity, objects): Don't supply an external name for VMS
exception data objects. We don't it and it would conflict with the other
external symbol we have to generate for such exceptions.
* trans.c (tree_transform, case N_Exception_Handler): Remove part of
the special code for VMS exceptions, since these are now represented
as regular exceptions objects.
--
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.12
diff -u -p -r1.12 ada-tree.h
--- ada-tree.h 18 Mar 2004 20:58:49 -0000 1.12
+++ ada-tree.h 19 Mar 2004 15:08:17 -0000
@@ -6,7 +6,7 @@
* *
* C Header 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- *
@@ -34,32 +34,32 @@ enum gnat_tree_code {
#undef DEFTREECODE
/* A tree to hold a loop ID. */
-struct tree_loop_id GTY(())
+struct tree_loop_id GTY(())
{
struct tree_common common;
struct nesting *loop_id;
};
/* The language-specific tree. */
-union lang_tree_node
+union lang_tree_node
GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"),
chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
{
- union tree_node GTY ((tag ("0"),
- desc ("tree_node_structure (&%h)")))
+ union tree_node GTY ((tag ("0"),
+ desc ("tree_node_structure (&%h)")))
generic;
struct tree_loop_id GTY ((tag ("1"))) loop_id;
};
/* Ada uses the lang_decl and lang_type fields to hold more trees. */
-struct lang_decl GTY(())
+struct lang_decl GTY(())
{
- union lang_tree_node
+ union lang_tree_node
GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"))) t;
};
struct lang_type GTY(())
{
- union lang_tree_node
+ union lang_tree_node
GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"))) t;
};
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.33
diff -u -p -r1.33 decl.c
--- decl.c 19 Mar 2004 14:34:47 -0000 1.33
+++ decl.c 19 Mar 2004 15:08:18 -0000
@@ -365,34 +365,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
goto object;
case E_Exception:
- /* If this is not a VMS exception, treat it as a normal object.
- Otherwise, make an object at the specific address of character
- type, point to it, and convert it to integer, and mask off
- the lower 3 bits. */
- if (! Is_VMS_Exception (gnat_entity))
- goto object;
-
- /* Allocate the global object that we use to get the value of the
- exception. */
- gnu_decl = create_var_decl (gnu_entity_id,
- (Present (Interface_Name (gnat_entity))
- ? create_concat_name (gnat_entity, 0)
- : NULL_TREE),
- char_type_node, NULL_TREE, 0, 0, 1, 1,
- 0);
-
- /* Now return the expression giving the desired value. */
- gnu_decl
- = build_binary_op (BIT_AND_EXPR, integer_type_node,
- convert (integer_type_node,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_decl)),
- build_unary_op (NEGATE_EXPR, integer_type_node,
- build_int_2 (7, 0)));
-
- save_gnu_tree (gnat_entity, gnu_decl, 1);
- saved = 1;
- break;
+ /* We used to special case VMS exceptions here to directly map them to
+ their associated condition code. Since this code had to be masked
+ dynamically to strip off the severity bits, this caused trouble in
+ the GCC/ZCX case because the "type" pointers we store in the tables
+ have to be static. We now don't special case here anymore, and let
+ the regular processing take place, which leaves us with a regular
+ exception data object for VMS exceptions too. The condition code
+ mapping is taken care of by the front end and the bitmasking by the
+ runtime library. */
+ goto object;
case E_Discriminant:
case E_Component:
@@ -1017,13 +999,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
- /* This name is external or there was a name specified, use it.
- Don't use the Interface_Name if there is an address clause.
- (see CD30005). */
- if ((Present (Interface_Name (gnat_entity))
- && No (Address_Clause (gnat_entity)))
- || (Is_Public (gnat_entity)
- && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity))))
+ /* If this name is external or there was a name specified, use it,
+ unless this is a VMS exception object since this would conflict
+ with the symbol we need to export in addition. Don't use the
+ Interface_Name if there is an address clause (see CD30005). */
+ if (! Is_VMS_Exception (gnat_entity)
+ &&
+ ((Present (Interface_Name (gnat_entity))
+ && No (Address_Clause (gnat_entity)))
+ ||
+ (Is_Public (gnat_entity)
+ && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))))
gnu_ext_name = create_concat_name (gnat_entity, 0);
if (const_flag)
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.47
diff -u -p -r1.47 trans.c
--- trans.c 18 Mar 2004 20:58:49 -0000 1.47
+++ trans.c 19 Mar 2004 15:08:18 -0000
@@ -3636,30 +3636,14 @@ tree_transform (Node_Id gnat_node)
if (Present (Renamed_Object (gnat_ex_id)))
gnat_ex_id = Renamed_Object (gnat_ex_id);
- /* ??? Note that we have to use gnat_to_gnu_entity here
- since the type of the exception will be wrong in the
- VMS case and that's exactly what this test is for. */
gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
- /* If this was a VMS exception, check import_code
- against the value of the exception. */
- if (TREE_CODE (TREE_TYPE (gnu_expr)) == INTEGER_TYPE)
- this_choice
- = build_binary_op
- (EQ_EXPR, integer_type_node,
- build_component_ref
- (build_unary_op
- (INDIRECT_REF, NULL_TREE,
- TREE_VALUE (gnu_except_ptr_stack)),
- get_identifier ("import_code"), NULL_TREE, 0),
- gnu_expr);
- else
- this_choice
- = build_binary_op
- (EQ_EXPR, integer_type_node,
- TREE_VALUE (gnu_except_ptr_stack),
- convert
- (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
+ this_choice
+ = build_binary_op
+ (EQ_EXPR, integer_type_node,
+ TREE_VALUE (gnu_except_ptr_stack),
+ convert
+ (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
/* If this is the distinguished exception "Non_Ada_Error"
@@ -3742,6 +3726,9 @@ tree_transform (Node_Id gnat_node)
gnu_etype
= build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
+
+ /* The Non_Ada_Error case for VMS exceptions is handled
+ by the personality routine. */
}
else
gigi_abort (337);
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-03-18 15:19 Arnaud Charlet
@ 2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-19 8:14 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3072 bytes --]
Tested on x86-linux
--
2004-03-18 Arnaud Charlet <charlet@act-europe.fr>
* 5atpopsp.adb: Remove RTEMS from list of platforms using this file.
Code clean up:
* 5ataprop.adb, 5ftaprop.adb, 5htaprop.adb, 5itaprop.adb, 5staprop.adb,
5vtaprop.adb, 5wtaprop.adb, 7staprop.adb (Finalize_TCB): Use
Specific.Set instead of direct call to e.g pthread_setspecific.
2004-03-18 Thomas Quinot <quinot@act-europe.fr>
* adaint.c: Update comments.
* Makefile.in: set PREFIX_OBJS, SYMLIB, THREADSLIB, and
GNATLIB_SHARED for FreeBSD.
2004-03-18 Jose Ruiz <ruiz@act-europe.fr>
* init.c [VxWorks]: Do not fix the stack size for the environment task.
When needed (stack checking) the stack size is retrieved
from the VxWorks kernel.
* Makefile.in: Flag -nostdinc is required when building the run time
for avoiding looking for files in the base compiler.
Add the VxWorks specific version of the package body for
System.Stack_checking.Operations (5zstchop.adb).
* Make-lang.in: Add the object file for
System.Stack_Checking.Operations.
* Makefile.rtl: Add object file for the package
System.Stack_Checking.Operations.
* s-stchop.ads, s-stchop.adb, 5zstchop.adb: New files.
* s-stache.ads, s-stache.adb: Move the operations related to stack
checking from this package to package System.Stack_Checking.Operations.
This way, stack checking operations are only linked in the final
executable when using the -fstack-check flag.
2004-03-18 Doug Rupp <rupp@gnat.com>
* Makefile.in [VMS]: Handle 64 bit specs (5qsystem.ads, 5xcrtl.ads).
Reorganize ifeq's.
* 5qsystem.ads, 5xcrtl.ads: New files.
2004-03-18 Vincent Celier <celier@gnat.com>
* prj.adb (Reset): Reset hash table Files_Htable
* prj-env.adb (Source_Paths, Object_Paths): New tables.
(Add_To_Source_Path, Add_To_Object_Path): New procedures, to replace
the procedures Add_To_Path_File.
(Set_Ada_Paths): Accumulate source and object dirs in the tables,
making sure that each directory is present only once and, for object
dirs, when a directory already present is added, the duplicate is
removed and the directory is always put as the last in the table.
Write the path files at the end of these accumulations.
* prj-nmsc.adb (Record_Source): Add source file name in hash table
Files_Htable for all sources.
* prj-proc.adb (Process): Remove restrictions between not directly
related extending projects.
2004-03-18 Emmanuel Briot <briot@act-europe.fr>
* prj-nmsc.ads, prj-nmsc.adb (Ada_Check): New parameter Trusted_Mode.
(Find_Sources): Minor speed optimization.
* prj-proc.ads, prj-proc.adb (Check, Recursive_Check, Process): New
parameter Trusted_Mode.
2004-03-18 Sergey Rybin <rybin@act-europe.fr>
* scn.adb (Determine_License): Take into account a degenerated case
when the source contains only comments.
2004-03-18 Ed Schonberg <schonberg@gnat.com>
* sem_warn.adb (Check_References): For a warning on a selected
component that does not come from source, locate an uninitialized
component of the record type to produce a more precise error message.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 12578 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-03-02 13:53 Arnaud Charlet
@ 2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-19 8:14 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3227 bytes --]
Tested on x86-linux
--
2004-03-02 Emmanuel Briot <briot@act-europe.fr>
* ali.adb (Read_Instantiation_Instance): Do not modify the
current_file_num when reading information about instantiations, since
this corrupts files in later references.
2004-03-02 Vincent Celier <celier@gnat.com>
* bcheck.adb (Check_Consistency): Get the full path of an ALI file
before checking if it is read-only.
* bld.adb (Recursive_Process): Concatenate <PROJECT>.src_dirs in front
of SRC_DIRS and eliminate duplicates.
* gprcmd.adb: Replace command "path" with command "path_sep" to return
the path separator.
(Usage): Document path_sep
* Makefile.generic: For Ada and GNU C++ cases, link directly with the
C++ compiler. No need for a script.
Replace use of C*_INCLUDE_PATH env var for GCC compilers with CPATH.
Do not call gprcmd to build the C*_INCLUDE_PATHs, do it with function
subst.
* prj-env.adb (For_All_Source_Dirs): Only add source dirs in project
where there are Ada sources.
(Set_Ada_Paths): Only add to the include path the source dirs of project
with Ada sources.
(Add_To_Path): Add the Display_Values of the directories, not their
Values.
* prj-nmsc.adb (Find_Sources): Set flag Sources_Present in the project
data.
* prj-nmsc.adb (Add_ALI_For): Make sure that the element Display_Value
is not No_Name.
(Find_Source_Dirs): Set Display_Value to a non canonicalized value, only
Value is canonicalized.
(Language_Independent_Check): Do not copy Value to Display_Value when
canonicalizing Value.
* prj-part.adb (Post_Parse_Context_Clause): Compare canonical cased
path to find limited with cycles.
(Parse_Single_Project): Use canonical cased path to find the end of a
with cycle.
2004-03-02 Ed Schonberg <schonberg@gnat.com>
* sem_ch10.adb (Optional_Subunit): Verify that unit contains a subunit
and not a child unit.
* sinfo.ads, sinfo.adb: Rearrange flags so that Private_Present can
appear in a with_clause.
* decl.c (gnat_to_gnu_type): If entity is a generic type, which can
only happen in type_annotate mode, do not try to elaborate it.
* exp_util.adb (Force_Evaluation): If expression is a selected
component on the left of an assignment, use a renaming rather than a
temporary to remove side effects.
* freeze.adb (Freeze_Entity): Do not freeze a global entity within an
inlined instance body, which is analyzed before the end of the
enclosing scope.
2004-03-02 Robert Dewar <dewar@gnat.com>
* par-ch10.adb, par-ch3.adb, par-ch4.adb, scng.adb,
sem_ch4.adb: Use new feature for substitution of keywords in VMS
* errout.ads, errout.adb: Implement new circuit for substitution of
keywords in VMS.
* sem_case.adb (Analyze_Choices): Place message properly when case is
a subtype reference rather than an explicit range.
* sem_elim.adb, s-tpobop.ads, exp_ch2.adb: Minor reformatting
2004-03-02 Doug Rupp <rupp@gnat.com>
* init.c (__gnat_initialize)[VMS]: Resignal RDB-E-STREAM_EOF.
2004-03-02 Thomas Quinot <quinot@act-europe.fr>
* s-tporft.adb: Add missing locking around call to Initialize_ATCB.
2004-03-02 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils.c (finish_record_type): Do not set DECL_NONADDRESSABLE for a
BLKmode bitfield.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 12431 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-03-05 10:59 Arnaud Charlet
@ 2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-19 8:14 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4407 bytes --]
Tested on x86-linux
Richard's change fixes recent breakage of Ada on the HEAD.
--
2004-03-05 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c: Reflect GCC changes to fix bootstrap problem.
Add warning for suspicious aliasing unchecked conversion.
2004-03-05 Robert Dewar <dewar@gnat.com>
* 56taprop.adb, 5ataprop.adb: Remove unneeded unchecked conversions
* a-tags.adb, a-tags.ads, s-finimp.adb, s-finroo.ads,
i-cpoint.ads, i-cpoint.adb, i-cstrin.adb, i-cstrin.ads,
5iosinte.ads, 5sosinte.ads, 5staspri.ads, 5itaprop.adb,
5staprop.adb, 5wtaprop.adb, s-tataat.ads, s-tataat.adb: Move
unchecked conversion to spec to avoid warnings.
* s-tasini.adb, s-taskin.ads, 5atpopsp.adb: Correct spelling Task_Id
to Task_ID
* 7stpopsp.adb: Correct casing in To_Task_ID call
* a-strsea.ads, a-strsea.adb: Minor reformatting
* einfo.ads, einfo.adb: Define new flag No_Strict_Aliasing
* errout.ads: Switch for VMS is now NO_STRICT_ALIASING.
Adjust Max_Msg_Length to be clearly large enough.
* fe.h: Define In_Same_Source_Unit
* osint.adb: Add pragma Warnings Off to suppress warnings
* g-dyntab.adb, g-table.adb, g-thread.adb: Add Warnings (Off) to kill
aliasing warnings.
* opt.ads: Put entries in alpha order. Add entry for No_Strict_Aliasing
* par-prag.adb: Add dummy entry for No_Strict_Aliasing pragma
* sem_ch13.adb: Generate validate unchecked conversion nodes for gcc.
* sem_ch3.adb: Set No_Strict_Aliasing flag if config pragma set.
* sem_prag.adb: Implement pragma No_Strict_Aliasing.
* sinfo.ads: Remove obsolete comment on validate unchecked conversion
node. We now do generate them for gcc back end.
* table.adb, sinput.adb: Add pragma Warnings Off to suppress aliasing
warning.
* sinput-c.adb: Fix bad name in header.
Add pragma Warnings Off to suppress aliasing warning.
* sinput-l.adb: Add pragma Warnings Off to suppress aliasing warning.
* snames.h, snames.ads, snames.adb: Add entry for pragma
No_Strict_Aliasing.
2004-03-05 Vincent Celier <celier@gnat.com>
* prj-com.ads: Add hash table Files_Htable to check when a file name
is already a source of another project.
* prj-nmsc.adb (Record_Source): Before recording a new source, check
if its file name is not already a source of another project. Report an
error if it is.
* gnatcmd.adb: When GNAT PRETTY is invoked with a project file and no
source file name, call gnatpp with all the sources of the main project.
* vms_conv.adb (Initialize): GNAT PRETTY may be called with any number
of file names.
* vms_data.ads: Correct documentation of new /OPTIMIZE keyword
NO_STRICT_ALIASING. Add new qualifier for GNAT PRETTY:
/RUNTIME_SYSTEM=, converted to --RTS=
/NOTABS, converted to -notabs
2004-03-05 Pascal Obry <obry@gnat.com>
* make.adb: Minor reformatting.
2004-03-05 Ed Schonberg <schonberg@gnat.com>
Part of implemention of AI-262.
* par-ch10.adb (P_Context_Clause): Recognize private with_clauses.
* sem_ch10.ads, sem_ch10.adb: (Install_Private_With_Clauses): New
procedure.
* sem_ch3.adb (Analyze_Component_Declaration): Improve error message
when component type is a partially constrained class-wide subtype.
(Constrain_Discriminated_Type): If parent type has unknown
discriminants, a constraint is illegal, even if full view has
discriminants.
(Build_Derived_Record_Type): Inherit discriminants when deriving a type
with unknown discriminants whose full view is a discriminated record.
* sem_ch7.adb (Preserve_Full_Attributes): Preserve Has_Discriminants
flag, to handle properly derivations of tagged types with unknown
discriminants.
(Analyze_Package_Spec, Analyze_Package_Body): Install
Private_With_Clauses before analyzing private part or body.
* einfo.ads: Indicate that both Has_Unknown_Discriminants and
Has_Discriminants can be true for a given type (documentation).
2004-03-05 Arnaud Charlet <charlet@act-europe.fr>
* s-restri.ads: Fix license (GPL->GMGPL).
* s-tassta.adb: Minor reformatting.
* s-tasren.adb: Replace manual handling of Self_Id.ATC_Nesting_Level
by calls to Exit_One_ATC_Level, since additional clean up is performed
by this function.
* s-tpobop.adb: Replace manual handling of Self_Id.ATC_Nesting_Level
by calls to Exit_One_ATC_Level, since additional clean up is performed
by this function.
2004-03-05 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 39636 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-03-15 14:55 Arnaud Charlet
@ 2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-19 8:14 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
Sorry for the big update in one chunk, I was in vacation last week, and
I don't have any script to split these commits in smaller chunks (nor
do I see any simple way to achieve such task reliably).
If people have scripts that work reliably to be shared, feel free to share
them.
--
2004-03-15 Jerome Guitton <guitton@act-europe.fr>
* 3zsoccon.ads: Fix multicast options.
* s-thread.ads: Move unchecked conversion from ATSD_Access to Address
in the spec.
2004-03-15 Robert Dewar <dewar@gnat.com>
* sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when
pragma used for a private type.
* lib-xref.adb (Generate_Reference): Do not generate warning if
reference is in a different unit from the pragma Unreferenced.
* 5vtpopde.adb: Minor reformatting
Fix casing of To_Task_ID
* sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing
flag if we have an unchecked conversion to an access type in the same
unit.
2004-03-15 Geert Bosch <bosch@gnat.com>
* a-ngcoty.adb (Modulus): In alternate formula for large real or
imaginary parts, use Double precision throughout.
* a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only
we want to be able to compile run-time with -gnata for testing, but
this may also be instantiated in user code that is compiled with -gnata.
2004-03-15 Olivier Hainque <hainque@act-europe.fr>
* s-stalib.ads (Exception_Code): New type, to represent Import/Export
codes. Having a separate type for this is useful to enforce consistency
throughout the various run-time units.
(Exception_Data): Use Exception_Code for Import_Code.
* s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of
Natural and Integer in various places.
(Register_VMS_Exception): Use Base_Code_In to compute the exception code
with the severity bits masked off.
(Register_VMS_Exception): Handle the additional exception data pointer
argument.
* raise.c (_GNAT_Exception structure): Remove the handled_by_others
component, now reflected by an exported accessor.
(is_handled_by): New routine to compute whether the propagated
occurrence matches some handler choice specification. Extracted out of
get_action_description_for, and expanded to take care of the VMS
specifities.
(get_action_description_for): Use is_handled_by instead of an explicit
complex condition to decide if the current choice at hand catches the
propagated occurrence.
* raise.h (Exception_Code): New type for C.
* rtsfind.ads (RE_Id, RE_Unit_Table): Add
System.Standard_Library.Exception_Code, to allow references from the
pragma import/export expander.
* a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For):
New accessors to allow easy access to GNAT exception data
characteristics.
(GNAT_GCC_Exception record, Propagate_Exception): Get rid of the
redundant Handled_By_Others component, helper for the personality
routine which will now be able to call the appropriate exception data
accessor instead.
* cstand.adb (Create_Standard): Adjust the type of the Import_Code
component of Standard_Exception_Type to be the closest possible to
Exception_Code in System.Standard_Library, that we cannot get at this
point. Expand a ??? comment to notify that this type node should
probably be rewritten later on.
* exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the
registration call to include a pointer to the exception object in the
arguments.
* init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In
instead of int and explicit bitmasks.
2004-03-15 Vincent Celier <celier@gnat.com>
* vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED
equivalent to /STATIC and /NOSTATIC equivalent to /SHARED.
* a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no
longer needed now that it is in the spec of
System.Tasking.Task_Attributes.
* adaint.h, adaint.c: (__gnat_create_output_file): New function
* gnatcmd.adb: Fix bug introduced in previous rev: /= instead of =
* g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function.
* make.adb (Gnatmake): Do not check the executable suffix; it is being
taken care of in Scan_Make_Arg.
(Scan_Make_Arg): Add the executable suffix only if the argument
following -o, in canonical case, does not end with the executable
suffix. When in verbose mode and executable file name does not end
with executable suffix, output the executable name, in canonical case.
* s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing
to avoid warnings when instantiating Ada.Task_Attributes.
Minor reformating.
* mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries
in the correct order.
* prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but
redirect standard output and error to a file for the invocation of the
compiler, then read the file.
* prj-nmsc.adb (Find_Sources): Use the Display_Value for each
directory, instead of the Value.
(Find_Source_Dirs): Remove useless code & comments.
2004-03-15 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a
tagged type is inherited, and the parent operation is not frozen yet,
force generation of a freeze node for the inherited operation, so the
corresponding dispatch entry is properly initialized.
(Make_Predefined_Primitive_Specs): Check that return type is Boolean
when looking for user-defined equality operation.
* exp_ch4.adb (Expand_Composite_Equality): Check that return type is
boolean when locating primitive equality of tagged component.
* exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a
bit-aligned field and the right-hand side a string literal, introduce
a temporary before expanding assignment into a loop.
* exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for
priority in full, to ensure that any expanded subepxressions of it are
elaborated in the scope of the init_proc.
* exp_prag.adb (Expand_Pragma_Import): Search for initialization call
after object declaration, skipping over code that may have been
generated for validity checks.
* sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown
discriminants, ignore the known discriminants of its full view, if
any, to check legality.
* sem_ch3.adb (Complete_Private_Subtype): Do not create constrained
component if type has unknown discriminants.
(Analyze_Private_Extension_Declaration): Discriminant constraint is
null if type has unknown discriminants.
* sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference
for end label when present.
* s-fileio.adb (Open): When called with a C_Stream, use given name for
temporary file, rather than an empty string.
2004-03-15 Ed Falis <falis@gnat.com>
* s-thread.adb: Removed, no longer used.
2004-03-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (target.h): Now include.
(gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE
in new build_pointer_from_mode calls for non-fat/non-thin pointer.
(validate_size): For POINTER_TYPE, get smallest size permitted on
machine.
* fe.h: Sort Einfo decls and add Set_Mechanism.
* Makefile.in: (LIBGNAT_SRCS): Remove types.h.
(ada/decl.o): Depends on target.h.
* trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use
FUNCTION_BOUNDARY; always use TYPE_ALIGN.
2004-03-15 Thomas Quinot <quinot@act-europe.fr>
* 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID.
* exp_ch4.adb (Expand_N_Indexed_Component): Do not call
Insert_Dereference_Action when rewriting an implicit dereference into
an explicit one, this will be taken care of during expansion of the
explicit dereference.
(Expand_N_Slice): Same. Always do the rewriting, even for the case
of non-packed slices, since the dereference action generated by
expansion of the explicit dereference is needed in any case.
(Expand_N_Selected_Component): When rewriting an implicit dereference,
analyze and resolve the rewritten explicit dereference so it is seen
by the expander.
(Insert_Dereference_Action): This procedure is now called only for the
expansion of an N_Explcit_Dereference_Node. Do insert a check even for
dereferences that do not come from source (including explicit
dereferences resulting from rewriting implicit ones), but do not
recursively insert a check for the dereference nodes contained within
the check.
(Insert_Dereference_Action): Clarify and correct comment.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-18 15:19 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-18 15:19 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3072 bytes --]
Tested on x86-linux
--
2004-03-18 Arnaud Charlet <charlet@act-europe.fr>
* 5atpopsp.adb: Remove RTEMS from list of platforms using this file.
Code clean up:
* 5ataprop.adb, 5ftaprop.adb, 5htaprop.adb, 5itaprop.adb, 5staprop.adb,
5vtaprop.adb, 5wtaprop.adb, 7staprop.adb (Finalize_TCB): Use
Specific.Set instead of direct call to e.g pthread_setspecific.
2004-03-18 Thomas Quinot <quinot@act-europe.fr>
* adaint.c: Update comments.
* Makefile.in: set PREFIX_OBJS, SYMLIB, THREADSLIB, and
GNATLIB_SHARED for FreeBSD.
2004-03-18 Jose Ruiz <ruiz@act-europe.fr>
* init.c [VxWorks]: Do not fix the stack size for the environment task.
When needed (stack checking) the stack size is retrieved
from the VxWorks kernel.
* Makefile.in: Flag -nostdinc is required when building the run time
for avoiding looking for files in the base compiler.
Add the VxWorks specific version of the package body for
System.Stack_checking.Operations (5zstchop.adb).
* Make-lang.in: Add the object file for
System.Stack_Checking.Operations.
* Makefile.rtl: Add object file for the package
System.Stack_Checking.Operations.
* s-stchop.ads, s-stchop.adb, 5zstchop.adb: New files.
* s-stache.ads, s-stache.adb: Move the operations related to stack
checking from this package to package System.Stack_Checking.Operations.
This way, stack checking operations are only linked in the final
executable when using the -fstack-check flag.
2004-03-18 Doug Rupp <rupp@gnat.com>
* Makefile.in [VMS]: Handle 64 bit specs (5qsystem.ads, 5xcrtl.ads).
Reorganize ifeq's.
* 5qsystem.ads, 5xcrtl.ads: New files.
2004-03-18 Vincent Celier <celier@gnat.com>
* prj.adb (Reset): Reset hash table Files_Htable
* prj-env.adb (Source_Paths, Object_Paths): New tables.
(Add_To_Source_Path, Add_To_Object_Path): New procedures, to replace
the procedures Add_To_Path_File.
(Set_Ada_Paths): Accumulate source and object dirs in the tables,
making sure that each directory is present only once and, for object
dirs, when a directory already present is added, the duplicate is
removed and the directory is always put as the last in the table.
Write the path files at the end of these accumulations.
* prj-nmsc.adb (Record_Source): Add source file name in hash table
Files_Htable for all sources.
* prj-proc.adb (Process): Remove restrictions between not directly
related extending projects.
2004-03-18 Emmanuel Briot <briot@act-europe.fr>
* prj-nmsc.ads, prj-nmsc.adb (Ada_Check): New parameter Trusted_Mode.
(Find_Sources): Minor speed optimization.
* prj-proc.ads, prj-proc.adb (Check, Recursive_Check, Process): New
parameter Trusted_Mode.
2004-03-18 Sergey Rybin <rybin@act-europe.fr>
* scn.adb (Determine_License): Take into account a degenerated case
when the source contains only comments.
2004-03-18 Ed Schonberg <schonberg@gnat.com>
* sem_warn.adb (Check_References): For a warning on a selected
component that does not come from source, locate an uninitialized
component of the record type to produce a more precise error message.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 12578 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-15 14:55 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-15 14:55 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
Sorry for the big update in one chunk, I was in vacation last week, and
I don't have any script to split these commits in smaller chunks (nor
do I see any simple way to achieve such task reliably).
If people have scripts that work reliably to be shared, feel free to share
them.
--
2004-03-15 Jerome Guitton <guitton@act-europe.fr>
* 3zsoccon.ads: Fix multicast options.
* s-thread.ads: Move unchecked conversion from ATSD_Access to Address
in the spec.
2004-03-15 Robert Dewar <dewar@gnat.com>
* sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when
pragma used for a private type.
* lib-xref.adb (Generate_Reference): Do not generate warning if
reference is in a different unit from the pragma Unreferenced.
* 5vtpopde.adb: Minor reformatting
Fix casing of To_Task_ID
* sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing
flag if we have an unchecked conversion to an access type in the same
unit.
2004-03-15 Geert Bosch <bosch@gnat.com>
* a-ngcoty.adb (Modulus): In alternate formula for large real or
imaginary parts, use Double precision throughout.
* a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only
we want to be able to compile run-time with -gnata for testing, but
this may also be instantiated in user code that is compiled with -gnata.
2004-03-15 Olivier Hainque <hainque@act-europe.fr>
* s-stalib.ads (Exception_Code): New type, to represent Import/Export
codes. Having a separate type for this is useful to enforce consistency
throughout the various run-time units.
(Exception_Data): Use Exception_Code for Import_Code.
* s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of
Natural and Integer in various places.
(Register_VMS_Exception): Use Base_Code_In to compute the exception code
with the severity bits masked off.
(Register_VMS_Exception): Handle the additional exception data pointer
argument.
* raise.c (_GNAT_Exception structure): Remove the handled_by_others
component, now reflected by an exported accessor.
(is_handled_by): New routine to compute whether the propagated
occurrence matches some handler choice specification. Extracted out of
get_action_description_for, and expanded to take care of the VMS
specifities.
(get_action_description_for): Use is_handled_by instead of an explicit
complex condition to decide if the current choice at hand catches the
propagated occurrence.
* raise.h (Exception_Code): New type for C.
* rtsfind.ads (RE_Id, RE_Unit_Table): Add
System.Standard_Library.Exception_Code, to allow references from the
pragma import/export expander.
* a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For):
New accessors to allow easy access to GNAT exception data
characteristics.
(GNAT_GCC_Exception record, Propagate_Exception): Get rid of the
redundant Handled_By_Others component, helper for the personality
routine which will now be able to call the appropriate exception data
accessor instead.
* cstand.adb (Create_Standard): Adjust the type of the Import_Code
component of Standard_Exception_Type to be the closest possible to
Exception_Code in System.Standard_Library, that we cannot get at this
point. Expand a ??? comment to notify that this type node should
probably be rewritten later on.
* exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the
registration call to include a pointer to the exception object in the
arguments.
* init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In
instead of int and explicit bitmasks.
2004-03-15 Vincent Celier <celier@gnat.com>
* vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED
equivalent to /STATIC and /NOSTATIC equivalent to /SHARED.
* a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no
longer needed now that it is in the spec of
System.Tasking.Task_Attributes.
* adaint.h, adaint.c: (__gnat_create_output_file): New function
* gnatcmd.adb: Fix bug introduced in previous rev: /= instead of =
* g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function.
* make.adb (Gnatmake): Do not check the executable suffix; it is being
taken care of in Scan_Make_Arg.
(Scan_Make_Arg): Add the executable suffix only if the argument
following -o, in canonical case, does not end with the executable
suffix. When in verbose mode and executable file name does not end
with executable suffix, output the executable name, in canonical case.
* s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing
to avoid warnings when instantiating Ada.Task_Attributes.
Minor reformating.
* mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries
in the correct order.
* prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but
redirect standard output and error to a file for the invocation of the
compiler, then read the file.
* prj-nmsc.adb (Find_Sources): Use the Display_Value for each
directory, instead of the Value.
(Find_Source_Dirs): Remove useless code & comments.
2004-03-15 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a
tagged type is inherited, and the parent operation is not frozen yet,
force generation of a freeze node for the inherited operation, so the
corresponding dispatch entry is properly initialized.
(Make_Predefined_Primitive_Specs): Check that return type is Boolean
when looking for user-defined equality operation.
* exp_ch4.adb (Expand_Composite_Equality): Check that return type is
boolean when locating primitive equality of tagged component.
* exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a
bit-aligned field and the right-hand side a string literal, introduce
a temporary before expanding assignment into a loop.
* exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for
priority in full, to ensure that any expanded subepxressions of it are
elaborated in the scope of the init_proc.
* exp_prag.adb (Expand_Pragma_Import): Search for initialization call
after object declaration, skipping over code that may have been
generated for validity checks.
* sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown
discriminants, ignore the known discriminants of its full view, if
any, to check legality.
* sem_ch3.adb (Complete_Private_Subtype): Do not create constrained
component if type has unknown discriminants.
(Analyze_Private_Extension_Declaration): Discriminant constraint is
null if type has unknown discriminants.
* sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference
for end label when present.
* s-fileio.adb (Open): When called with a C_Stream, use given name for
temporary file, rather than an empty string.
2004-03-15 Ed Falis <falis@gnat.com>
* s-thread.adb: Removed, no longer used.
2004-03-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (target.h): Now include.
(gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE
in new build_pointer_from_mode calls for non-fat/non-thin pointer.
(validate_size): For POINTER_TYPE, get smallest size permitted on
machine.
* fe.h: Sort Einfo decls and add Set_Mechanism.
* Makefile.in: (LIBGNAT_SRCS): Remove types.h.
(ada/decl.o): Depends on target.h.
* trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use
FUNCTION_BOUNDARY; always use TYPE_ALIGN.
2004-03-15 Thomas Quinot <quinot@act-europe.fr>
* 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID.
* exp_ch4.adb (Expand_N_Indexed_Component): Do not call
Insert_Dereference_Action when rewriting an implicit dereference into
an explicit one, this will be taken care of during expansion of the
explicit dereference.
(Expand_N_Slice): Same. Always do the rewriting, even for the case
of non-packed slices, since the dereference action generated by
expansion of the explicit dereference is needed in any case.
(Expand_N_Selected_Component): When rewriting an implicit dereference,
analyze and resolve the rewritten explicit dereference so it is seen
by the expander.
(Insert_Dereference_Action): This procedure is now called only for the
expansion of an N_Explcit_Dereference_Node. Do insert a check even for
dereferences that do not come from source (including explicit
dereferences resulting from rewriting implicit ones), but do not
recursively insert a check for the dereference nodes contained within
the check.
(Insert_Dereference_Action): Clarify and correct comment.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-05 10:59 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-05 10:59 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4407 bytes --]
Tested on x86-linux
Richard's change fixes recent breakage of Ada on the HEAD.
--
2004-03-05 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c: Reflect GCC changes to fix bootstrap problem.
Add warning for suspicious aliasing unchecked conversion.
2004-03-05 Robert Dewar <dewar@gnat.com>
* 56taprop.adb, 5ataprop.adb: Remove unneeded unchecked conversions
* a-tags.adb, a-tags.ads, s-finimp.adb, s-finroo.ads,
i-cpoint.ads, i-cpoint.adb, i-cstrin.adb, i-cstrin.ads,
5iosinte.ads, 5sosinte.ads, 5staspri.ads, 5itaprop.adb,
5staprop.adb, 5wtaprop.adb, s-tataat.ads, s-tataat.adb: Move
unchecked conversion to spec to avoid warnings.
* s-tasini.adb, s-taskin.ads, 5atpopsp.adb: Correct spelling Task_Id
to Task_ID
* 7stpopsp.adb: Correct casing in To_Task_ID call
* a-strsea.ads, a-strsea.adb: Minor reformatting
* einfo.ads, einfo.adb: Define new flag No_Strict_Aliasing
* errout.ads: Switch for VMS is now NO_STRICT_ALIASING.
Adjust Max_Msg_Length to be clearly large enough.
* fe.h: Define In_Same_Source_Unit
* osint.adb: Add pragma Warnings Off to suppress warnings
* g-dyntab.adb, g-table.adb, g-thread.adb: Add Warnings (Off) to kill
aliasing warnings.
* opt.ads: Put entries in alpha order. Add entry for No_Strict_Aliasing
* par-prag.adb: Add dummy entry for No_Strict_Aliasing pragma
* sem_ch13.adb: Generate validate unchecked conversion nodes for gcc.
* sem_ch3.adb: Set No_Strict_Aliasing flag if config pragma set.
* sem_prag.adb: Implement pragma No_Strict_Aliasing.
* sinfo.ads: Remove obsolete comment on validate unchecked conversion
node. We now do generate them for gcc back end.
* table.adb, sinput.adb: Add pragma Warnings Off to suppress aliasing
warning.
* sinput-c.adb: Fix bad name in header.
Add pragma Warnings Off to suppress aliasing warning.
* sinput-l.adb: Add pragma Warnings Off to suppress aliasing warning.
* snames.h, snames.ads, snames.adb: Add entry for pragma
No_Strict_Aliasing.
2004-03-05 Vincent Celier <celier@gnat.com>
* prj-com.ads: Add hash table Files_Htable to check when a file name
is already a source of another project.
* prj-nmsc.adb (Record_Source): Before recording a new source, check
if its file name is not already a source of another project. Report an
error if it is.
* gnatcmd.adb: When GNAT PRETTY is invoked with a project file and no
source file name, call gnatpp with all the sources of the main project.
* vms_conv.adb (Initialize): GNAT PRETTY may be called with any number
of file names.
* vms_data.ads: Correct documentation of new /OPTIMIZE keyword
NO_STRICT_ALIASING. Add new qualifier for GNAT PRETTY:
/RUNTIME_SYSTEM=, converted to --RTS=
/NOTABS, converted to -notabs
2004-03-05 Pascal Obry <obry@gnat.com>
* make.adb: Minor reformatting.
2004-03-05 Ed Schonberg <schonberg@gnat.com>
Part of implemention of AI-262.
* par-ch10.adb (P_Context_Clause): Recognize private with_clauses.
* sem_ch10.ads, sem_ch10.adb: (Install_Private_With_Clauses): New
procedure.
* sem_ch3.adb (Analyze_Component_Declaration): Improve error message
when component type is a partially constrained class-wide subtype.
(Constrain_Discriminated_Type): If parent type has unknown
discriminants, a constraint is illegal, even if full view has
discriminants.
(Build_Derived_Record_Type): Inherit discriminants when deriving a type
with unknown discriminants whose full view is a discriminated record.
* sem_ch7.adb (Preserve_Full_Attributes): Preserve Has_Discriminants
flag, to handle properly derivations of tagged types with unknown
discriminants.
(Analyze_Package_Spec, Analyze_Package_Body): Install
Private_With_Clauses before analyzing private part or body.
* einfo.ads: Indicate that both Has_Unknown_Discriminants and
Has_Discriminants can be true for a given type (documentation).
2004-03-05 Arnaud Charlet <charlet@act-europe.fr>
* s-restri.ads: Fix license (GPL->GMGPL).
* s-tassta.adb: Minor reformatting.
* s-tasren.adb: Replace manual handling of Self_Id.ATC_Nesting_Level
by calls to Exit_One_ATC_Level, since additional clean up is performed
by this function.
* s-tpobop.adb: Replace manual handling of Self_Id.ATC_Nesting_Level
by calls to Exit_One_ATC_Level, since additional clean up is performed
by this function.
2004-03-05 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 39636 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-03-02 13:53 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-03-02 13:53 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3227 bytes --]
Tested on x86-linux
--
2004-03-02 Emmanuel Briot <briot@act-europe.fr>
* ali.adb (Read_Instantiation_Instance): Do not modify the
current_file_num when reading information about instantiations, since
this corrupts files in later references.
2004-03-02 Vincent Celier <celier@gnat.com>
* bcheck.adb (Check_Consistency): Get the full path of an ALI file
before checking if it is read-only.
* bld.adb (Recursive_Process): Concatenate <PROJECT>.src_dirs in front
of SRC_DIRS and eliminate duplicates.
* gprcmd.adb: Replace command "path" with command "path_sep" to return
the path separator.
(Usage): Document path_sep
* Makefile.generic: For Ada and GNU C++ cases, link directly with the
C++ compiler. No need for a script.
Replace use of C*_INCLUDE_PATH env var for GCC compilers with CPATH.
Do not call gprcmd to build the C*_INCLUDE_PATHs, do it with function
subst.
* prj-env.adb (For_All_Source_Dirs): Only add source dirs in project
where there are Ada sources.
(Set_Ada_Paths): Only add to the include path the source dirs of project
with Ada sources.
(Add_To_Path): Add the Display_Values of the directories, not their
Values.
* prj-nmsc.adb (Find_Sources): Set flag Sources_Present in the project
data.
* prj-nmsc.adb (Add_ALI_For): Make sure that the element Display_Value
is not No_Name.
(Find_Source_Dirs): Set Display_Value to a non canonicalized value, only
Value is canonicalized.
(Language_Independent_Check): Do not copy Value to Display_Value when
canonicalizing Value.
* prj-part.adb (Post_Parse_Context_Clause): Compare canonical cased
path to find limited with cycles.
(Parse_Single_Project): Use canonical cased path to find the end of a
with cycle.
2004-03-02 Ed Schonberg <schonberg@gnat.com>
* sem_ch10.adb (Optional_Subunit): Verify that unit contains a subunit
and not a child unit.
* sinfo.ads, sinfo.adb: Rearrange flags so that Private_Present can
appear in a with_clause.
* decl.c (gnat_to_gnu_type): If entity is a generic type, which can
only happen in type_annotate mode, do not try to elaborate it.
* exp_util.adb (Force_Evaluation): If expression is a selected
component on the left of an assignment, use a renaming rather than a
temporary to remove side effects.
* freeze.adb (Freeze_Entity): Do not freeze a global entity within an
inlined instance body, which is analyzed before the end of the
enclosing scope.
2004-03-02 Robert Dewar <dewar@gnat.com>
* par-ch10.adb, par-ch3.adb, par-ch4.adb, scng.adb,
sem_ch4.adb: Use new feature for substitution of keywords in VMS
* errout.ads, errout.adb: Implement new circuit for substitution of
keywords in VMS.
* sem_case.adb (Analyze_Choices): Place message properly when case is
a subtype reference rather than an explicit range.
* sem_elim.adb, s-tpobop.ads, exp_ch2.adb: Minor reformatting
2004-03-02 Doug Rupp <rupp@gnat.com>
* init.c (__gnat_initialize)[VMS]: Resignal RDB-E-STREAM_EOF.
2004-03-02 Thomas Quinot <quinot@act-europe.fr>
* s-tporft.adb: Add missing locking around call to Initialize_ATCB.
2004-03-02 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils.c (finish_record_type): Do not set DECL_NONADDRESSABLE for a
BLKmode bitfield.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 12431 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-25 17:27 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-25 17:27 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2090 bytes --]
Tested on x86-linux
--
2004-02-25 Robert Dewar <dewar@gnat.com>
* 51osinte.ads, 52osinte.ads, 53osinte.ads, 54osinte.ads,
55osinte.ads, 56osinte.ads, 5aosinte.ads, 5bosinte.ads,
5cosinte.ads, 5fosinte.ads, 5gosinte.ads, 5hosinte.ads,
5iosinte.ads, 5losinte.ads, 5nosinte.ads, 5oosinte.ads,
5posinte.ads, 5sosinte.ads, 5tosinte.ads, 5vosinte.ads,
5wosinte.ads, 5zosinte.ads: Move instances of Unchecked_Conversion to
the defining instance of the type to avoid aliasing problems.
Fix copyright header. Fix bad comments in package header.
* exp_util.adb, prj-part.adb, prj-part.adb: Minor reformatting
2004-02-25 Ed Schonberg <schonberg@gnat.com>
* exp_ch2.adb (Param_Entity): Handle properly formals that have been
rewritten as references when aliased through an address clause.
* sem_ch4.adb (Try_Indirect_Call): Normalize actuals before checking
whether call can be interpreted as an indirect call to the result of a
parameterless function call returning an access subprogram.
2004-02-25 Arnaud Charlet <charlet@act-europe.fr>
Code clean up:
* exp_ch7.adb (Make_Clean): Remove generation of calls to
Unlock[_Entries], since this is now done by Service_Entries directly.
* exp_ch9.adb (Build_Protected_Subprogram_Body): ditto.
* s-tpobop.ads, s-tpobop.adb (PO_Service_Entries): New nested procedure
Requeue_Call for better code readability. Change spec and update calls:
PO_Service_Entries now unlock the PO on exit.
(Protected_Entry_Call, Timed_Protected_Entry_Call): Update calls to
PO_Service_Entries.
* s-tposen.ads, s-tposen.adb (Service_Entry): Now unlock the PO on exit.
* s-taenca.adb, s-tasren.adb: Update calls to PO_Service_Entries.
2004-02-25 Sergey Rybin <rybin@act-europe.fr>
* exp_ch9.adb (Build_Simple_Entry_Call): Prevent expanding the
protected subprogram call and analyzing the result of such expanding
in case when the called protected subprogram is eliminated.
* sem_elim.adb (Check_Eliminated): Skip blocks when comparing scope
names.
2004-02-25 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: Clean ups.
[-- Attachment #2: difs.1.gz --]
[-- Type: application/x-gunzip, Size: 9623 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 19:42 ` Rainer Orth
@ 2004-02-21 13:45 ` Rainer Orth
0 siblings, 0 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-21 13:45 UTC (permalink / raw)
To: Zack Weinberg; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Zack Weinberg writes:
> Okay, so sdbout_symbol needs the same treatment that dbxout_symbol
> got. Sorry about this. Here is a revised patch.
Except for the obvious typo
> +/* The C front end may call sdbout_symbol before sdbout_init runs.
> + We save all such decls in this list and output them when we get
> + to sdbout_init. */
> +
> +static GTY(()) tree preinit_symbols;
> +statid GTY(()) bool sdbout_initialized;
^c
this worked for me, i.e. I rebuilt cc1plus and successfully run the
testcase that crashed before. I'll run a full bootstrap overnight.
Thanks for the quick help.
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 19:41 ` Zack Weinberg
2004-02-18 19:42 ` Rainer Orth
2004-02-19 14:44 ` Rainer Orth
@ 2004-02-21 13:45 ` Zack Weinberg
2 siblings, 0 replies; 178+ messages in thread
From: Zack Weinberg @ 2004-02-21 13:45 UTC (permalink / raw)
To: Rainer Orth; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Rainer Orth <ro@TechFak.Uni-Bielefeld.DE> writes:
> Zack Weinberg writes:
>
>> Argh, this is yet another thing I fixed in the 3.4 iteration (not yet
>> applied) of that patch but that got lost somehow when I redid it for
>> mainline.
>>
>> Please try the appended:
>
> That's the patch that I came up with myself and that got me through
> bootstrap.
>
> Unfortunately, there are lots of testsuite regressions: cf. current
> alpha-dec-osf4.0f testresults
...
> E.g.
>
> FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
> Excess errors:
> In file included from /vol/gnu/src/gcc/gcc-dist/gcc/testsuite/g++.dg/debug/anonunion1.C:1:
> <internal>:0: internal compiler error: Segmentation fault
>
> This gets down to
>
> $ ../cc1plus anonunion1.ii -gcoff1
> In file included from anonunion1.ii:1:
> <internal>:0: internal compiler error: Segmentation fault
>
> Program received signal SIGSEGV, Segmentation fault.
> 0x000003ff800db020 in fprintf () from /usr/shlib/libc.so
...
> The crash happens because asm_out_file is NULL in varasm.c (text_section).
Okay, so sdbout_symbol needs the same treatment that dbxout_symbol
got. Sorry about this. Here is a revised patch.
zw
* sdbout.c (preinit_symbols, sdbout_initialized): New statics.
(sdbout_symbol): If called before sdbout_init, queue DECL for
later and return.
(sdbout_init): Set sdbout_initialized true, process decls
queued earlier by sdbout_symbol.
(sdbout_finish): Use size_t for index variable.
===================================================================
Index: sdbout.c
--- sdbout.c 16 Feb 2004 18:55:01 -0000 1.87
+++ sdbout.c 18 Feb 2004 18:23:13 -0000
@@ -64,6 +64,13 @@ static GTY(()) int unnamed_struct_number
static GTY(()) varray_type deferred_global_decls;
+/* The C front end may call sdbout_symbol before sdbout_init runs.
+ We save all such decls in this list and output them when we get
+ to sdbout_init. */
+
+static GTY(()) tree preinit_symbols;
+statid GTY(()) bool sdbout_initialized;
+
#ifdef SDB_DEBUGGING_INFO
#include "rtl.h"
@@ -699,6 +706,14 @@ sdbout_symbol (tree decl, int local)
int regno = -1;
const char *name;
+ /* If we are called before sdbout_init is run, just save the symbol
+ for later. */
+ if (!sdbout_initialized)
+ {
+ preinit_symbols = tree_cons (0, decl, preinit_symbols);
+ return;
+ }
+
sdbout_one_type (type);
switch (TREE_CODE (decl))
@@ -1460,7 +1475,7 @@ sdbout_global_decl (tree decl)
static void
sdbout_finish (const char *main_filename ATTRIBUTE_UNUSED)
{
- int i;
+ size_t i;
for (i = 0; i < VARRAY_ACTIVE_SIZE (deferred_global_decls); i++)
sdbout_symbol (VARRAY_TREE (deferred_global_decls, i), 0);
@@ -1663,6 +1678,8 @@ sdbout_end_source_file (unsigned int lin
static void
sdbout_init (const char *input_file_name ATTRIBUTE_UNUSED)
{
+ tree t;
+
#ifdef MIPS_DEBUGGING_INFO
current_file = xmalloc (sizeof *current_file);
current_file->next = NULL;
@@ -1670,6 +1687,14 @@ sdbout_init (const char *input_file_name
#endif
VARRAY_TREE_INIT (deferred_global_decls, 12, "deferred_global_decls");
+
+ /* Emit debug information which was queued by sdbout_symbol before
+ we got here. */
+ sdbout_initialized = true;
+
+ for (t = nreverse (preinit_symbols); t; t = TREE_CHAIN (t))
+ sdbout_symbol (TREE_VALUE (t), 0);
+ preinit_symbols = 0;
}
#else /* SDB_DEBUGGING_INFO */
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-02-21 1:21 Arnaud Charlet
@ 2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux and alpha-tru64
--
2004-02-20 Robert Dewar <dewar@gnat.com>
* bld.adb, exp_util.adb, gprcmd.adb: Minor reformatting
2004-02-20 Ed Schonberg <schonberg@gnat.com>
* freeze.adb (Freeze_Record_Type): Generalize mechanism that generates
itype references for the constrained designated type of a component
whose base type is already frozen.
2004-02-20 Arnaud Charlet <charlet@act-europe.fr>
* init.c (__gnat_error_handler [tru64]): Rewrite previous change to
avoid GCC warnings.
2004-02-20 Sergey Rybin <rybin@act-europe.fr>
* sem_ch12.adb (Analyze_Formal_Package): Create a new defining
identifier for a phantom package that rewrites the formal package
declaration with a box. The Add semantic decorations for the defining
identifier from the original node (that represents the formal package).
--
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.9
diff -u -p -r1.9 bld.adb
--- bld.adb 18 Feb 2004 11:52:54 -0000 1.9
+++ bld.adb 20 Feb 2004 10:28:30 -0000
@@ -1972,16 +1972,16 @@ package body Bld is
elsif Pkg = Snames.Name_Linker then
if Item_Name = Snames.Name_Linker_Options then
- -- Only add linker options if this is not the root
- -- project.
+
+ -- Only add linker options if this is not the
+ -- root project.
Put ("ifeq ($(");
Put (Project_Name);
Put (".root),False)");
New_Line;
- -- Add the linker options to FLDFLAGS, in reverse
- -- order.
+ -- Add linker options to FLDFLAGS in reverse order
Put (" FLDFLAGS:=$(shell gprcmd linkopts $(");
Put (Project_Name);
@@ -1994,10 +1994,10 @@ package body Bld is
Put ("endif");
New_Line;
- else
- -- Other attribute are of no interest; suppress
- -- their declarations.
+ -- Other attributes are of no interest. Suppress
+ -- their declarations.
+ else
Put_Declaration := False;
end if;
end if;
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.21
diff -u -p -r1.21 exp_util.adb
--- exp_util.adb 18 Feb 2004 11:52:55 -0000 1.21
+++ exp_util.adb 20 Feb 2004 10:28:31 -0000
@@ -3353,8 +3353,7 @@ package body Exp_Util is
when N_Character_Literal |
N_Integer_Literal |
N_Real_Literal |
- N_String_Literal
- =>
+ N_String_Literal =>
return True;
-- We consider that anything else has side effects. This is a bit
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.12
diff -u -p -r1.12 freeze.adb
--- freeze.adb 2 Feb 2004 12:31:51 -0000 1.12
+++ freeze.adb 20 Feb 2004 10:28:31 -0000
@@ -1473,6 +1473,41 @@ package body Freeze is
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas).
+ procedure Check_Itype (Desig : Entity_Id);
+ -- If the component subtype is an access to a constrained subtype
+ -- of an already frozen type, make the subtype frozen as well. It
+ -- might otherwise be frozen in the wrong scope, and a freeze node
+ -- on subtype has no effect.
+
+ procedure Check_Itype (Desig : Entity_Id) is
+ begin
+ if not Is_Frozen (Desig)
+ and then Is_Frozen (Base_Type (Desig))
+ then
+ Set_Is_Frozen (Desig);
+
+ -- In addition, add an Itype_Reference to ensure that the
+ -- access subtype is elaborated early enough. This cannot
+ -- be done if the subtype may depend on discriminants.
+
+ if Ekind (Comp) = E_Component
+ and then Is_Itype (Etype (Comp))
+ and then not Has_Discriminants (Rec)
+ then
+ IR := Make_Itype_Reference (Sloc (Comp));
+ Set_Itype (IR, Desig);
+
+ if No (Result) then
+ Result := New_List (IR);
+ else
+ Append (IR, Result);
+ end if;
+ end if;
+ end if;
+ end Check_Itype;
+
+ -- Start of processing for Freeze_Record_Type
+
begin
-- If this is a subtype of a controlled type, declared without
-- a constraint, the _controller may not appear in the component
@@ -1548,40 +1583,19 @@ package body Freeze is
Loc, Result);
end if;
+ elsif Is_Itype (Designated_Type (Etype (Comp))) then
+ Check_Itype (Designated_Type (Etype (Comp)));
+
else
Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result);
end if;
end;
- -- If this is a constrained subtype of an already frozen type,
- -- make the subtype frozen as well. It might otherwise be frozen
- -- in the wrong scope, and a freeze node on subtype has no effect.
-
elsif Is_Access_Type (Etype (Comp))
- and then not Is_Frozen (Designated_Type (Etype (Comp)))
and then Is_Itype (Designated_Type (Etype (Comp)))
- and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp))))
then
- Set_Is_Frozen (Designated_Type (Etype (Comp)));
-
- -- In addition, add an Itype_Reference to ensure that the
- -- access subtype is elaborated early enough. This cannot
- -- be done if the subtype may depend on discriminants.
-
- if Ekind (Comp) = E_Component
- and then Is_Itype (Etype (Comp))
- and then not Has_Discriminants (Rec)
- then
- IR := Make_Itype_Reference (Sloc (Comp));
- Set_Itype (IR, Designated_Type (Etype (Comp)));
-
- if No (Result) then
- Result := New_List (IR);
- else
- Append (IR, Result);
- end if;
- end if;
+ Check_Itype (Designated_Type (Etype (Comp)));
elsif Is_Array_Type (Etype (Comp))
and then Is_Access_Type (Component_Type (Etype (Comp)))
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.9
diff -u -p -r1.9 gprcmd.adb
--- gprcmd.adb 18 Feb 2004 11:52:55 -0000 1.9
+++ gprcmd.adb 20 Feb 2004 10:28:31 -0000
@@ -454,19 +454,20 @@ begin
Dir : constant String := Argument (2);
begin
- for J in 3 .. Argument_Count loop
-
- -- Remove quotes that may have been added around each argument
+ -- Loop to remove quotes that may have been added around arguments
+ for J in 3 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
First : Natural := Arg'First;
Last : Natural := Arg'Last;
+
begin
if Arg (First) = '"' and then Arg (Last) = '"' then
First := First + 1;
Last := Last - 1;
end if;
+
if Is_Absolute_Path (Arg (First .. Last)) then
Extend (Format_Pathname (Arg (First .. Last), UNIX));
else
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.24
diff -u -p -r1.24 init.c
--- init.c 12 Feb 2004 13:28:10 -0000 1.24
+++ init.c 20 Feb 2004 10:28:31 -0000
@@ -388,6 +388,7 @@ __gnat_error_handler (int sig, siginfo_t
static int recurse = 0;
struct sigcontext *mstate;
const char *msg;
+ jmp_buf handler_jmpbuf;
/* If this was an explicit signal from a "kill", just resignal it. */
if (SI_FROMUSER (sip))
@@ -397,6 +398,43 @@ __gnat_error_handler (int sig, siginfo_t
}
/* Otherwise, treat it as something we handle. */
+
+ /* We are now going to raise the exception corresponding to the signal we
+ caught, which may eventually end up resuming the application code if the
+ exception is handled.
+
+ When the exception is handled, merely arranging for the *exception*
+ handler's context (stack pointer, program counter, other registers, ...)
+ to be installed is *not* enough to let the kernel think we've left the
+ *signal* handler. This has annoying implications if an alternate stack
+ has been setup for this *signal* handler, because the kernel thinks we
+ are still running on that alternate stack even after the jump, which
+ causes trouble at least as soon as another signal is raised.
+
+ We deal with this by forcing a "local" longjmp within the signal handler
+ below, forcing the "on alternate stack" indication to be reset (kernel
+ wise) on the way. If no alternate stack has been setup, this should be a
+ neutral operation. Otherwise, we will be in a delicate situation for a
+ short while because we are going to run the exception propagation code
+ within the alternate stack area (that is, with the stack pointer inside
+ the alternate stack bounds), but with the corresponding flag off from the
+ kernel's standpoint. We expect this to be ok as long as the propagation
+ code does not trigger a signal itself, which is expected.
+
+ ??? A better approach would be to at least delay this operation until the
+ last second, that is, until just before we jump to the exception handler,
+ if any. */
+
+ if (setjmp (handler_jmpbuf) == 0)
+ {
+#define JB_ONSIGSTK 0
+
+ /* Arrange for the "on alternate stack" flag to be reset. See the
+ comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
+ handler_jmpbuf [JB_ONSIGSTK] = 0;
+ longjmp (handler_jmpbuf, 1);
+ }
+
switch (sig)
{
case SIGSEGV:
@@ -448,48 +486,7 @@ __gnat_error_handler (int sig, siginfo_t
if (mstate != 0)
*mstate = *context;
- /* We are now going to raise the exception corresponding to the signal we
- caught, which may eventually end up resuming the application code if the
- exception is handled.
-
- When the exception is handled, merely arranging for the *exception*
- handler's context (stack pointer, program counter, other registers, ...)
- to be installed is *not* enough to let the kernel think we've left the
- *signal* handler. This has annoying implications if an alternate stack
- has been setup for this *signal* handler, because the kernel thinks we
- are still running on that alternate stack even after the jump, which
- causes trouble at least as soon as another signal is raised.
-
- We deal with this by forcing a "local" longjmp within the signal handler
- below, forcing the "on alternate stack" indication to be reset (kernel
- wise) on the way. If no alternate stack has been setup, this should be a
- neutral operation. Otherwise, we will be in a delicate situation for a
- short while because we are going to run the exception propagation code
- within the alternate stack area (that is, with the stack pointer inside
- the alternate stack bounds), but with the corresponding flag off from the
- kernel's standpoint. We expect this to be ok as long as the propagation
- code does not trigger a signal itself, which is expected.
-
- ??? A better approach would be to at least delay this operation until the
- last second, that is, until just before we jump to the exception handler,
- if any. */
- {
- jmp_buf handler_jmpbuf;
-
- if (setjmp (handler_jmpbuf) != 0)
- Raise_From_Signal_Handler (exception, (char *) msg);
- else
- {
- /* Arrange for the "on alternate stack" flag to be reset. See the
- comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
- struct sigcontext * handler_context
- = (struct sigcontext *) & handler_jmpbuf;
-
- handler_context->sc_onstack = 0;
-
- longjmp (handler_jmpbuf, 1);
- }
- }
+ Raise_From_Signal_Handler (exception, (char *) msg);
}
void
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.32
diff -u -p -r1.32 sem_ch12.adb
--- sem_ch12.adb 2 Feb 2004 12:31:56 -0000 1.32
+++ sem_ch12.adb 20 Feb 2004 10:28:33 -0000
@@ -1578,7 +1578,8 @@ package body Sem_Ch12 is
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Formal : constant Entity_Id := Defining_Identifier (N);
+ Pack_Id : constant Entity_Id := Defining_Identifier (N);
+ Formal : Entity_Id;
Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
@@ -1653,8 +1654,6 @@ package body Sem_Ch12 is
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
- Set_Instance_Env (Gen_Unit, Formal);
-
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
if In_Extended_Main_Source_Unit (N) then
@@ -1662,11 +1661,13 @@ package body Sem_Ch12 is
Generate_Reference (Gen_Unit, N);
end if;
+ Formal := New_Copy (Pack_Id);
New_N :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
- Set_Defining_Unit_Name (Specification (New_N), Formal);
Rewrite (N, New_N);
+ Set_Defining_Unit_Name (Specification (New_N), Formal);
+ Set_Instance_Env (Gen_Unit, Formal);
Enter_Name (Formal);
Set_Ekind (Formal, E_Generic_Package);
@@ -1728,6 +1729,11 @@ package body Sem_Ch12 is
Set_Ekind (Formal, E_Package);
Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Has_Completion (Formal, True);
+
+ Set_Ekind (Pack_Id, E_Package);
+ Set_Etype (Pack_Id, Standard_Void_Type);
+ Set_Scope (Pack_Id, Scope (Formal));
+ Set_Has_Completion (Pack_Id, True);
end if;
end Analyze_Formal_Package;
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 11:56 ` Arnaud Charlet
2004-02-18 18:36 ` Zack Weinberg
2004-02-19 14:57 ` Rainer Orth
@ 2004-02-21 13:45 ` Arnaud Charlet
2 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: Rainer Orth; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
> This change broke Ada bootstrap on alpha-dec-osf*:
>
> /vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c: In function `__gnat_error_handler':
> /vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:486: warning: dereferencing type-punned pointer will break strict-aliasing rules
> make[2]: *** [ada/init.o] Error 1
>
> It cannot have been tested at all ;-(
It has been tested with mainline on x86-linux, and with gcc 3.2.3 on
alpha-tru64. Enabling addition warnings or changing warnings as error is
certainly 'expected' to generate lots of additional problems on various
platforms.
Addressing the warnings is easy in this case, I'll prepare a patch.
> only to fail later on with another error:
>
> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
OK, I can't resist:
It cannot have been tested at all ;-)
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-02-02 12:36 Arnaud Charlet
@ 2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
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.
--
Index: 5staprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5staprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5staprop.adb
--- 5staprop.adb 5 Jan 2004 15:20:43 -0000 1.8
+++ 5staprop.adb 2 Feb 2004 11:46:51 -0000
@@ -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.Oper
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.Oper
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.Oper
-----------------
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.Oper
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.Oper
------------------
function Check_Unlock (L : Lock_Ptr) return Boolean is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
Index: 6vcstrea.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/6vcstrea.adb,v
retrieving revision 1.9
diff -u -p -r1.9 6vcstrea.adb
--- 6vcstrea.adb 5 Jan 2004 15:20:43 -0000 1.9
+++ 6vcstrea.adb 2 Feb 2004 11:46:51 -0000
@@ -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.???
-
- -- 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.???
+ -- As the functions fread, fwrite and setvbuf are too big to be inlined,
+ -- they are just wrappers to the following implementation functions.
+
+ 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;
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.12
diff -u -p -r1.12 ali.adb
--- ali.adb 5 Jan 2004 15:20:43 -0000 1.12
+++ ali.adb 2 Feb 2004 11:46:51 -0000
@@ -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;
@@ -840,6 +845,109 @@ package body ALI is
end if;
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
Index: ali.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.ads,v
retrieving revision 1.11
diff -u -p -r1.11 ali.ads
--- ali.ads 21 Oct 2003 13:41:58 -0000 1.11
+++ ali.ads 2 Feb 2004 11:46:51 -0000
@@ -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
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.10
diff -u -p -r1.10 atree.adb
--- atree.adb 21 Nov 2003 10:46:37 -0000 1.10
+++ atree.adb 2 Feb 2004 11:46:51 -0000
@@ -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 --
@@ -1925,8 +1925,6 @@ package body Atree is
Write_Eol;
end if;
end New_Node_Debugging_Output;
-
- pragma Inline (New_Node_Debugging_Output);
-- Start of processing for New_Node
Index: atree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.ads,v
retrieving revision 1.6
diff -u -p -r1.6 atree.ads
--- atree.ads 21 Oct 2003 13:41:58 -0000 1.6
+++ atree.ads 2 Feb 2004 11:46:51 -0000
@@ -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);
Index: bcheck.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bcheck.adb,v
retrieving revision 1.8
diff -u -p -r1.8 bcheck.adb
--- bcheck.adb 21 Oct 2003 13:41:58 -0000 1.8
+++ bcheck.adb 2 Feb 2004 11:46:51 -0000
@@ -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,148 +362,6 @@ 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
-
- No_Recursion => True,
- -- Not checkable at compile time
-
- No_Reentrancy => True,
- -- Not checkable at compile time
-
- 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.
-
- R : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id);
- -- Record the first unit specifying each compilation unit restriction
-
- 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.
-
- Additional_Restrictions_Listed : Boolean := False;
- -- Set True if we have listed header for restrictions
-
- begin
- -- Loop to find restrictions
-
- 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;
-
- -- Loop to find violations
-
- 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
-
- V (J) := A;
-
- -- 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.
-
- if R (J) /= No_ALI_Id
- and then J in Partition_Restrictions
- then
- declare
- M1 : constant String := "% has Restriction (";
- S : constant String := Restriction_Id'Image (J);
- M2 : String (1 .. M1'Length + S'Length + 1);
-
- begin
- Name_Buffer (1 .. S'Length) := S;
- Name_Len := S'Length;
- Set_Casing
- (Units.Table (ALIs.Table (R (J)).First_Unit).Icasing);
-
- M2 (M1'Range) := M1;
- M2 (M1'Length + 1 .. M2'Last - 1) :=
- Name_Buffer (1 .. S'Length);
- M2 (M2'Last) := ')';
-
- Error_Msg_Name_1 := ALIs.Table (R (J)).Sfile;
- Consistency_Error_Msg (M2);
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
- Consistency_Error_Msg
- ("but file % violates this restriction");
- end;
- end if;
- end if;
- end loop;
- end loop;
-
- -- List applicable restrictions if option set
-
- if List_Restrictions then
-
- -- List any restrictions which were not violated and not specified
-
- 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;
-
- Write_Str ("pragma Restrictions (");
-
- declare
- S : constant String := Restriction_Id'Image (J);
- begin
- Name_Len := S'Length;
- Name_Buffer (1 .. Name_Len) := S;
- end;
-
- 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;
-
-------------------------------------
-- Check_Consistent_Queuing_Policy --
-------------------------------------
@@ -540,6 +398,135 @@ package body Bcheck is
end if;
end loop Find_Policy;
end Check_Consistent_Queuing_Policy;
+
+ -----------------------------------
+ -- Check_Consistent_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.
+
+ procedure Check_Consistent_Restrictions is
+ Restriction_File_Output : Boolean;
+ -- Shows if we have output header messages for restriction violation
+
+ procedure Print_Restriction_File (R : All_Restrictions);
+ -- Print header line for R if not printed yet
+
+ ----------------------------
+ -- Print_Restriction_File --
+ ----------------------------
+
+ procedure Print_Restriction_File (R : All_Restrictions) is
+ begin
+ if not Restriction_File_Output then
+ Restriction_File_Output := True;
+
+ -- Find the ali file specifying the restriction
+
+ 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 (R);
+ M2 : String (1 .. 200); -- big enough!
+ P : Integer;
+
+ begin
+ Name_Buffer (1 .. S'Length) := S;
+ Name_Len := S'Length;
+ Set_Casing (Mixed_Case);
+
+ M2 (M1'Range) := M1;
+ 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 (A).Sfile;
+ Consistency_Error_Msg (M2 (1 .. P - 1));
+ Consistency_Error_Msg
+ ("but the following files violate this restriction:");
+ end;
+ end if;
+ end loop;
+ end if;
+ end Print_Restriction_File;
+
+ -- Start of processing for Check_Consistent_Restrictions
+
+ begin
+ -- Loop through all restriction violations
+
+ for R in All_Restrictions loop
+
+ -- Check for violation of this restriction
+
+ 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;
+
+ -- Loop through files looking for violators
+
+ for A2 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A2).Restrictions.Violated (R) then
+
+ -- 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.
+
+ if not Is_Internal_File_Name (ALIs.Table (A2).Sfile) then
+ Print_Restriction_File (R);
+
+ Error_Msg_Name_1 := ALIs.Table (A2).Sfile;
+
+ if R in All_Boolean_Restrictions then
+ Consistency_Error_Msg (" %");
+
+ 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));
+
+ 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;
+ end Check_Consistent_Restrictions;
---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling --
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.18
diff -u -p -r1.18 bindgen.adb
--- bindgen.adb 5 Jan 2004 15:20:43 -0000 1.18
+++ bindgen.adb 2 Feb 2004 11:46:51 -0000
@@ -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;
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.15
diff -u -p -r1.15 checks.adb
--- checks.adb 5 Jan 2004 15:20:43 -0000 1.15
+++ checks.adb 2 Feb 2004 11:46:52 -0000
@@ -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 =>
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.16
diff -u -p -r1.16 cstand.adb
--- cstand.adb 13 Jan 2004 11:51:31 -0000 1.16
+++ cstand.adb 2 Feb 2004 11:46:52 -0000
@@ -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);
@@ -1503,7 +1505,6 @@ package body CStand is
Write_Str (IEEES_First'Universal_Literal_String);
Write_Str (" .. ");
Write_Str (IEEES_Last'Universal_Literal_String);
-
elsif Digs = IEEEL_Digits then
Write_Str (IEEEL_First'Universal_Literal_String);
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.26
diff -u -p -r1.26 decl.c
--- decl.c 23 Jan 2004 10:30:03 -0000 1.26
+++ decl.c 2 Feb 2004 11:46:52 -0000
@@ -1315,6 +1315,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
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_entit
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));
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_aggr.adb
--- exp_aggr.adb 23 Jan 2004 10:30:03 -0000 1.15
+++ exp_aggr.adb 2 Feb 2004 11:46:52 -0000
@@ -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
Index: exp_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_attr.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_attr.adb
--- exp_attr.adb 3 Dec 2003 11:47:52 -0000 1.8
+++ exp_attr.adb 2 Feb 2004 11:46:52 -0000
@@ -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);
Index: exp_ch11.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch11.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_ch11.adb
--- exp_ch11.adb 5 Jan 2004 15:20:43 -0000 1.8
+++ exp_ch11.adb 2 Feb 2004 11:46:52 -0000
@@ -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;
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_ch3.adb
--- exp_ch3.adb 26 Jan 2004 14:47:47 -0000 1.15
+++ exp_ch3.adb 2 Feb 2004 11:46:52 -0000
@@ -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
-
- Decls : List_Id;
- Loops : Node_Id;
- Stats : List_Id;
+ 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;
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))
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch5.adb
--- exp_ch5.adb 26 Jan 2004 14:47:47 -0000 1.14
+++ exp_ch5.adb 2 Feb 2004 11:46:53 -0000
@@ -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,
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.18
diff -u -p -r1.18 exp_ch6.adb
--- exp_ch6.adb 19 Jan 2004 10:37:59 -0000 1.18
+++ exp_ch6.adb 2 Feb 2004 11:46:53 -0000
@@ -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
Index: exp_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch7.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch7.adb
--- exp_ch7.adb 5 Jan 2004 15:20:43 -0000 1.11
+++ exp_ch7.adb 2 Feb 2004 11:46:53 -0000
@@ -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);
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch9.adb
--- exp_ch9.adb 23 Jan 2004 10:30:03 -0000 1.14
+++ exp_ch9.adb 2 Feb 2004 11:46:53 -0000
@@ -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));
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.18
diff -u -p -r1.18 exp_util.adb
--- exp_util.adb 12 Jan 2004 11:45:23 -0000 1.18
+++ exp_util.adb 2 Feb 2004 11:46:53 -0000
@@ -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'));
Index: fname-uf.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.adb,v
retrieving revision 1.9
diff -u -p -r1.9 fname-uf.adb
--- fname-uf.adb 21 Oct 2003 13:42:00 -0000 1.9
+++ fname-uf.adb 2 Feb 2004 11:46:54 -0000
@@ -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
Index: fname-uf.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.ads,v
retrieving revision 1.5
diff -u -p -r1.5 fname-uf.ads
--- fname-uf.ads 21 Oct 2003 13:42:00 -0000 1.5
+++ fname-uf.ads 2 Feb 2004 11:46:54 -0000
@@ -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
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.11
diff -u -p -r1.11 freeze.adb
--- freeze.adb 5 Jan 2004 15:20:44 -0000 1.11
+++ freeze.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: g-crc32.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-crc32.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-crc32.ads
--- g-crc32.ads 21 Oct 2003 13:42:00 -0000 1.4
+++ g-crc32.ads 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: g-md5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-md5.adb,v
retrieving revision 1.4
diff -u -p -r1.4 g-md5.adb
--- g-md5.adb 21 Oct 2003 13:42:03 -0000 1.4
+++ g-md5.adb 2 Feb 2004 11:46:54 -0000
@@ -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
Index: g-md5.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-md5.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-md5.ads
--- g-md5.ads 21 Oct 2003 13:42:03 -0000 1.4
+++ g-md5.ads 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: gnat1drv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat1drv.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnat1drv.adb
--- gnat1drv.adb 5 Jan 2004 15:20:44 -0000 1.10
+++ gnat1drv.adb 2 Feb 2004 11:46:54 -0000
@@ -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
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.9
diff -u -p -r1.9 gnatbind.adb
--- gnatbind.adb 5 Jan 2004 15:20:44 -0000 1.9
+++ gnatbind.adb 2 Feb 2004 11:46:54 -0000
@@ -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.
-
- for J in Partition_Restrictions loop
- if Restrictions (J) = 'r' then
- Restrictions_On_Target (J) := True;
- end if;
- end loop;
+ -- List restrictions that could be applied to this partition
+
+ if List_Restrictions then
+ List_Applicable_Restrictions;
+ end if;
-- Complete bind if no errors
Index: gnatcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatcmd.adb,v
retrieving revision 1.15
diff -u -p -r1.15 gnatcmd.adb
--- gnatcmd.adb 26 Jan 2004 14:47:48 -0000 1.15
+++ gnatcmd.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.14
diff -u -p -r1.14 gnatlink.adb
--- gnatlink.adb 26 Jan 2004 14:47:48 -0000 1.14
+++ gnatlink.adb 2 Feb 2004 11:46:54 -0000
@@ -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);
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.5
diff -u -p -r1.5 gprcmd.adb
--- gprcmd.adb 5 Jan 2004 15:20:44 -0000 1.5
+++ gprcmd.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: i-cobol.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/i-cobol.ads,v
retrieving revision 1.4
diff -u -p -r1.4 i-cobol.ads
--- i-cobol.ads 24 Apr 2003 17:54:05 -0000 1.4
+++ i-cobol.ads 2 Feb 2004 11:46:54 -0000
@@ -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);
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.22
diff -u -p -r1.22 init.c
--- init.c 11 Dec 2003 16:21:39 -0000 1.22
+++ init.c 2 Feb 2004 11:46:54 -0000
@@ -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- *
@@ -447,6 +447,29 @@ void
__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
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.9
diff -u -p -r1.9 lib.ads
--- lib.ads 8 Dec 2003 10:33:15 -0000 1.9
+++ lib.ads 2 Feb 2004 11:46:54 -0000
@@ -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.
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.12
diff -u -p -r1.12 lib-writ.adb
--- lib-writ.adb 5 Jan 2004 15:20:44 -0000 1.12
+++ lib-writ.adb 2 Feb 2004 11:46:54 -0000
@@ -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,23 +918,53 @@ 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');
+ end if;
+ end loop;
+
+ 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;
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.9
diff -u -p -r1.9 lib-writ.ads
--- lib-writ.ads 5 Jan 2004 15:20:44 -0000 1.9
+++ lib-writ.ads 2 Feb 2004 11:46:54 -0000
@@ -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
@@ -230,6 +235,58 @@ package Lib.Writ is
-- i.e. to detect cases where one unit has "r" and another unit
-- 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 --
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.69
diff -u -p -r1.69 Makefile.in
--- Makefile.in 26 Jan 2004 21:56:05 -0000 1.69
+++ Makefile.in 2 Feb 2004 11:46:54 -0000
@@ -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 sol
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%,$(
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 hpux
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%,$(ma
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 os
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% min
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
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
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.5
diff -u -p -r1.5 Makefile.rtl
--- Makefile.rtl 5 Jan 2004 15:20:45 -0000 1.5
+++ Makefile.rtl 2 Feb 2004 11:46:54 -0000
@@ -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) \
Index: par-ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch3.adb,v
retrieving revision 1.10
diff -u -p -r1.10 par-ch3.adb
--- par-ch3.adb 12 Jan 2004 11:45:24 -0000 1.10
+++ par-ch3.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: restrict.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.adb,v
retrieving revision 1.8
diff -u -p -r1.8 restrict.adb
--- restrict.adb 21 Oct 2003 13:42:13 -0000 1.8
+++ restrict.adb 2 Feb 2004 11:46:54 -0000
@@ -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).
+
+ procedure Update_Restrictions (Info : in out Restrictions_Info);
+ -- Update violation information in Info.Violated and Info.Count
+
+ -------------------------
+ -- Update_Restrictions --
+ -------------------------
+
+ procedure Update_Restrictions (Info : in out Restrictions_Info) is
+ begin
+ -- If not violated, set as violated now
+
+ 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;
- 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
+ -- Otherwise if violated already and a parameter restriction,
+ -- update count by maximizing or summing depending on restriction.
- if not Restrictions (R) then
- Restriction_Msg
- ("?violation of restriction %", Rimage, N);
+ elsif R in All_Parameter_Restrictions then
- -- If this is a real restriction violation, then generate
- -- a non-serious message with appropriate location.
+ -- If new value is unknown, result is unknown
- else
- Error_Msg_Sloc := Restrictions_Loc (R);
+ 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;
+ Restrictions.Set (R) := True;
+
+ -- Set location, but preserve location of system
+ -- restriction for nice error msg with run time name
- if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
- Restriction_Parameters (Max_Protected_Entries) := Uint_1;
+ 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;
Index: restrict.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.ads,v
retrieving revision 1.6
diff -u -p -r1.6 restrict.ads
--- restrict.ads 21 Oct 2003 13:42:13 -0000 1.6
+++ restrict.ads 2 Feb 2004 11:46:54 -0000
@@ -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 : 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 (Restriction_Id) of Source_Ptr :=
+ 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.
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.19
diff -u -p -r1.19 sem_attr.adb
--- sem_attr.adb 19 Jan 2004 10:37:59 -0000 1.19
+++ sem_attr.adb 2 Feb 2004 11:46:55 -0000
@@ -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;
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_ch10.adb
--- sem_ch10.adb 5 Jan 2004 15:20:45 -0000 1.14
+++ sem_ch10.adb 2 Feb 2004 11:46:55 -0000
@@ -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
Index: sem_ch11.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch11.adb,v
retrieving revision 1.6
diff -u -p -r1.6 sem_ch11.adb
--- sem_ch11.adb 21 Oct 2003 13:42:19 -0000 1.6
+++ sem_ch11.adb 2 Feb 2004 11:46:55 -0000
@@ -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;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.31
diff -u -p -r1.31 sem_ch12.adb
--- sem_ch12.adb 12 Jan 2004 11:38:15 -0000 1.31
+++ sem_ch12.adb 2 Feb 2004 11:46:55 -0000
@@ -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
Index: sem_ch2.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch2.adb,v
retrieving revision 1.5
diff -u -p -r1.5 sem_ch2.adb
--- sem_ch2.adb 24 Apr 2003 17:54:16 -0000 1.5
+++ sem_ch2.adb 2 Feb 2004 11:46:55 -0000
@@ -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;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.29
diff -u -p -r1.29 sem_ch3.adb
--- sem_ch3.adb 21 Jan 2004 10:35:17 -0000 1.29
+++ sem_ch3.adb 2 Feb 2004 11:46:56 -0000
@@ -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
- Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+ if not Extensions_Allowed then
+
+ -- 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
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_ch4.adb
--- sem_ch4.adb 5 Jan 2004 15:20:46 -0000 1.11
+++ sem_ch4.adb 2 Feb 2004 11:46:56 -0000
@@ -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
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_ch8.adb
--- sem_ch8.adb 5 Jan 2004 15:20:46 -0000 1.15
+++ sem_ch8.adb 2 Feb 2004 11:46:56 -0000
@@ -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);
Index: sem_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch9.adb,v
retrieving revision 1.8
diff -u -p -r1.8 sem_ch9.adb
--- sem_ch9.adb 21 Jan 2004 10:35:17 -0000 1.8
+++ sem_ch9.adb 2 Feb 2004 11:46:56 -0000
@@ -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;
Index: sem_elab.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elab.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sem_elab.adb
--- sem_elab.adb 5 Jan 2004 15:20:46 -0000 1.12
+++ sem_elab.adb 2 Feb 2004 11:46:56 -0000
@@ -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.
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_prag.adb
--- sem_prag.adb 12 Jan 2004 11:45:25 -0000 1.17
+++ sem_prag.adb 2 Feb 2004 11:46:56 -0000
@@ -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 --
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_res.adb
--- sem_res.adb 19 Jan 2004 10:37:59 -0000 1.20
+++ sem_res.adb 2 Feb 2004 11:46:57 -0000
@@ -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
Index: sem_type.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_type.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_type.adb
--- sem_type.adb 20 Nov 2003 09:54:01 -0000 1.10
+++ sem_type.adb 2 Feb 2004 11:46:57 -0000
@@ -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
@@ -1468,6 +1468,23 @@ package body Sem_Type is
return T;
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
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sinfo.adb
--- sinfo.adb 12 Jan 2004 11:45:25 -0000 1.12
+++ sinfo.adb 2 Feb 2004 11:46:57 -0000
@@ -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
@@ -2564,6 +2573,15 @@ package body Sinfo is
or else NT (N).Nkind = N_Accept_Alternative);
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
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.18
diff -u -p -r1.18 sinfo.ads
--- sinfo.ads 12 Jan 2004 11:45:25 -0000 1.18
+++ sinfo.ads 2 Feb 2004 11:46:57 -0000
@@ -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);
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.15
diff -u -p -r1.15 snames.adb
--- snames.adb 26 Jan 2004 14:47:48 -0000 1.15
+++ snames.adb 2 Feb 2004 11:46:57 -0000
@@ -334,6 +334,7 @@ package body Snames is
"on#" &
"parameter_types#" &
"reference#" &
+ "no_requeue#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.15
diff -u -p -r1.15 snames.ads
--- snames.ads 20 Nov 2003 09:54:02 -0000 1.15
+++ snames.ads 2 Feb 2004 11:46:57 -0000
@@ -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;
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sprint.adb
--- sprint.adb 13 Jan 2004 11:51:34 -0000 1.15
+++ sprint.adb 2 Feb 2004 11:46:57 -0000
@@ -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 ");
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.2
diff -u -p -r1.2 s-rident.ads
--- s-rident.ads 27 Nov 2003 11:40:45 -0000 1.2
+++ s-rident.ads 2 Feb 2004 11:46:57 -0000
@@ -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;
-
- -- 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);
+ -- 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.
+
+ 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;
Index: s-stoele.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-stoele.ads,v
retrieving revision 1.4
diff -u -p -r1.4 s-stoele.ads
--- s-stoele.ads 21 Oct 2003 13:42:14 -0000 1.4
+++ s-stoele.ads 2 Feb 2004 11:46:57 -0000
@@ -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, "-");
Index: s-thread.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.ads,v
retrieving revision 1.4
diff -u -p -r1.4 s-thread.ads
--- s-thread.ads 24 Nov 2003 14:27:57 -0000 1.4
+++ s-thread.ads 2 Feb 2004 11:46:57 -0000
@@ -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);
Index: style.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/style.ads,v
retrieving revision 1.5
diff -u -p -r1.5 style.ads
--- style.ads 21 Oct 2003 13:42:22 -0000 1.5
+++ style.ads 2 Feb 2004 11:46:57 -0000
@@ -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.
Index: targparm.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.adb,v
retrieving revision 1.7
diff -u -p -r1.7 targparm.adb
--- targparm.adb 23 Jan 2004 09:53:05 -0000 1.7
+++ targparm.adb 2 Feb 2004 11:46:57 -0000
@@ -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
Index: targparm.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.ads,v
retrieving revision 1.7
diff -u -p -r1.7 targparm.ads
--- targparm.ads 8 Dec 2003 10:33:16 -0000 1.7
+++ targparm.ads 2 Feb 2004 11:46:57 -0000
@@ -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).
+ -- required (see definition of Rident.Restriction_Info).
- 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.
+ 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 --
Index: tbuild.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/tbuild.adb,v
retrieving revision 1.6
diff -u -p -r1.6 tbuild.adb
--- tbuild.adb 21 Oct 2003 13:42:23 -0000 1.6
+++ tbuild.adb 2 Feb 2004 11:46:57 -0000
@@ -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;
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.41
diff -u -p -r1.41 utils.c
--- utils.c 19 Jan 2004 10:37:59 -0000 1.41
+++ utils.c 2 Feb 2004 11:46:58 -0000
@@ -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 ();
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-02-09 12:31 Arnaud Charlet
@ 2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-09 Albert Lee <lee@gnat.com>
* errno.c: define _SGI_MP_SOURCE for task-safe errno on IRIX
2004-02-09 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Build_Slice_Assignment): Handle properly case of null
slices.
* exp_ch6.adb (Expand_Call): Do not inline a call when the subprogram
is nested in an instance that is not frozen yet, to avoid
order-of-elaboration problems in gigi.
* sem_attr.adb (Analyze_Attribute, case 'Access): Within an inlined
body the attribute is legal.
2004-02-09 Robert Dewar <dewar@gnat.com>
* s-rident.ads: Minor comment correction
* targparm.adb: Remove dependence on uintp completely. There was
always a bug in Make in that it called Targparm before initializing
the Uint package. The old code appeared to get away with this, but
the new code did not! This caused an assertion error in gnatmake.
* targparm.ads: Fix bad comment, restriction pragmas with parameters
are indeed fully supported.
--
Index: errno.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/errno.c,v
retrieving revision 1.6
diff -u -p -r1.6 errno.c
--- errno.c 4 Nov 2003 12:51:45 -0000 1.6
+++ errno.c 6 Feb 2004 09:52:38 -0000
@@ -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- *
@@ -39,6 +39,7 @@
#define _REENTRANT
#define _THREAD_SAFE
+#define _SGI_MP_SOURCE
#include <errno.h>
int
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.16
diff -u -p -r1.16 exp_ch3.adb
--- exp_ch3.adb 2 Feb 2004 12:31:50 -0000 1.16
+++ exp_ch3.adb 6 Feb 2004 09:52:39 -0000
@@ -2505,16 +2505,20 @@ package body Exp_Ch3 is
-- end if;
-- loop
+ -- if Rev then
+ -- exit when Li1 < Left_Lo;
+ -- else
+ -- exit when Li1 > Left_Hi;
+ -- end if;
+
-- Target (Li1) := Source (Ri1);
-- if Rev then
- -- exit when Li2 = Left_Lo;
- -- Li2 := Index'pred (Li2);
- -- Ri2 := Index'pred (Ri2);
+ -- Li1 := Index'pred (Li1);
+ -- Ri1 := Index'pred (Ri1);
-- else
- -- exit when Li2 = Left_Hi;
- -- Li2 := Index'succ (Li2);
- -- Ri2 := Index'succ (Ri2);
+ -- Li1 := Index'succ (Li1);
+ -- Ri1 := Index'succ (Ri1);
-- end if;
-- end loop;
-- end Assign;
@@ -2561,7 +2565,6 @@ package body Exp_Ch3 is
Stats : List_Id;
begin
-
-- Build declarations for indices
Decls := New_List;
@@ -2630,7 +2633,7 @@ package body Exp_Ch3 is
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
End_Label => Empty);
- -- Build the increment/decrement statements
+ -- Build exit condition.
declare
F_Ass : constant List_Id := New_List;
@@ -2640,17 +2643,31 @@ package body Exp_Ch3 is
Append_To (F_Ass,
Make_Exit_Statement (Loc,
Condition =>
- Make_Op_Eq (Loc,
+ Make_Op_Gt (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
Append_To (B_Ass,
Make_Exit_Statement (Loc,
Condition =>
- Make_Op_Eq (Loc,
+ Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
+ Prepend_To (Statements (Loops),
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Ass,
+ Else_Statements => F_Ass));
+ end;
+
+ -- Build the increment/decrement statements
+
+ declare
+ F_Ass : constant List_Id := New_List;
+ B_Ass : constant List_Id := New_List;
+
+ begin
Append_To (F_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.19
diff -u -p -r1.19 exp_ch6.adb
--- exp_ch6.adb 2 Feb 2004 12:31:50 -0000 1.19
+++ exp_ch6.adb 6 Feb 2004 09:52:39 -0000
@@ -1915,12 +1915,43 @@ package body Exp_Ch6 is
then
if Is_Inlined (Subp) then
- declare
+ Inlined_Subprogram : declare
Bod : Node_Id;
Must_Inline : Boolean := False;
Spec : constant Node_Id := Unit_Declaration_Node (Subp);
Scop : constant Entity_Id := Scope (Subp);
+ function In_Unfrozen_Instance return Boolean;
+ -- If the subprogram comes from an instance in the same
+ -- unit, and the instance is not yet frozen, inlining might
+ -- trigger order-of-elaboration problems in gigi.
+
+ --------------------------
+ -- In_Unfrozen_Instance --
+ --------------------------
+
+ function In_Unfrozen_Instance return Boolean is
+ S : Entity_Id := Scop;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S)
+ and then Present (Freeze_Node (S))
+ and then not Analyzed (Freeze_Node (S))
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Unfrozen_Instance;
+
+ -- Start of processing for Inlined_Subprogram
+
begin
-- Verify that the body to inline has already been seen,
-- and that if the body is in the current unit the inlining
@@ -1943,14 +1974,7 @@ package body Exp_Ch6 is
then
Must_Inline := False;
- -- If the subprogram comes from an instance in the same
- -- unit, and the instance is not yet frozen, inlining might
- -- trigger order-of-elaboration problems in gigi.
-
- elsif Is_Generic_Instance (Scop)
- and then Present (Freeze_Node (Scop))
- and then not Analyzed (Freeze_Node (Scop))
- then
+ elsif In_Unfrozen_Instance then
Must_Inline := False;
else
@@ -1998,7 +2022,7 @@ package body Exp_Ch6 is
N, Subp);
end if;
end if;
- end;
+ end Inlined_Subprogram;
end if;
end if;
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_attr.adb
--- sem_attr.adb 2 Feb 2004 12:31:56 -0000 1.20
+++ sem_attr.adb 6 Feb 2004 09:52:39 -0000
@@ -605,10 +605,14 @@ package body Sem_Attr is
-- prefix may have been a tagged formal object, which is
-- defined to be aliased even when the actual might not be
-- (other instance cases will have been caught in the generic).
+ -- Similarly, within an inlined body we know that the attribute
+ -- is legal in the original subprogram, and therefore legal in
+ -- the expansion.
if Aname /= Name_Unrestricted_Access
and then not Is_Aliased_View (P)
and then not In_Instance
+ and then not In_Inlined_Body
then
Error_Attr ("prefix of % attribute must be aliased", P);
end if;
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.4
diff -u -p -r1.4 s-rident.ads
--- s-rident.ads 4 Feb 2004 11:06:19 -0000 1.4
+++ s-rident.ads 6 Feb 2004 09:52:39 -0000
@@ -155,7 +155,6 @@ package System.Rident is
-- Synonyms permitted for historical purposes of compatibility
-- No_Requeue synonym for No_Requeue_Statements
- -- No_Tasking synonym for Max_Tasks => 0
-- No_Task_Attributes synonym for No_Task_Attributes_Package
subtype All_Restrictions is Restriction_Id range
Index: targparm.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.adb,v
retrieving revision 1.8
diff -u -p -r1.8 targparm.adb
--- targparm.adb 2 Feb 2004 12:32:01 -0000 1.8
+++ targparm.adb 6 Feb 2004 09:52:39 -0000
@@ -29,7 +29,6 @@ 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;
@@ -193,7 +192,7 @@ package body Targparm is
Source_Last : Source_Ptr)
is
P : Source_Ptr;
- V : Uint;
+ -- Scans source buffer containing source of system.ads
Fatal : Boolean := False;
-- Set True if a fatal error is detected
@@ -221,7 +220,7 @@ package body Targparm is
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
- Rloop : for K in Partition_Boolean_Restrictions loop
+ Rloop : for K in All_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
@@ -249,6 +248,9 @@ package body Targparm is
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
+ V : Natural;
+ -- Accumulates value
+
begin
for J in Rname'Range loop
if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
@@ -262,22 +264,36 @@ package body Targparm is
" => "
then
P := P + Rname'Length + 4;
- V := Uint_0;
+ V := 0;
loop
if System_Text (P) in '0' .. '9' then
- V := 10 * V + Character'Pos (System_Text (P)) - 48;
+ declare
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ -- Accumulate next digit
+
+ V := 10 * V +
+ Character'Pos (System_Text (P)) -
+ Character'Pos ('0');
+
+ exception
+ -- On overflow, we just ignore the pragma since
+ -- that is the standard handling in this case.
+
+ when Constraint_Error =>
+ goto Line_Loop_Continue;
+ end;
+
elsif System_Text (P) = '_' then
null;
+
elsif System_Text (P) = ')' then
- 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;
+ Restrictions_On_Target.Value (K) := V;
+ Restrictions_On_Target.Set (K) := True;
+ goto Line_Loop_Continue;
+
else
exit Ploop;
end if;
Index: targparm.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.ads,v
retrieving revision 1.8
diff -u -p -r1.8 targparm.ads
--- targparm.ads 2 Feb 2004 12:32:01 -0000 1.8
+++ targparm.ads 6 Feb 2004 09:52:39 -0000
@@ -104,9 +104,10 @@ package Targparm is
-- if a pragma Suppress_Exception_Locations appears, then the flag
-- Opt.Exception_Locations_Suppressed is set to True.
- -- 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.Restriction_Info).
+ -- The only other pragma allowed is a pragma Restrictions that specifies
+ -- a restriction that will be imposed on all units in the partition. Note
+ -- that in this context, only one restriction can be specified in a single
+ -- pragma, and the pragma must appear on its own on a single source line.
Restrictions_On_Target : Restrictions_Info;
-- Records restrictions specified by system.ads. Only the Set and Value
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-02-04 11:07 Arnaud Charlet
@ 2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-04 Robert Dewar <dewar@gnat.com>
* 5gtasinf.adb, 5gtasinf.ads, 5gtaprop.adb, ali.adb,
ali.ads, gprcmd.adb: Minor reformatting
* bindgen.adb: Output restrictions string for new style restrictions
handling
* impunit.adb: Add s-rident.ads (System.Rident) and
s-restri (System.Restrictions)
* lib-writ.adb: Fix bug in writing restrictions string (last few
entries wrong)
* s-restri.ads, s-restri.adb: Change name Restrictions to
Run_Time_Restrictions to avoid conflict with package name.
Add circuit to read and acquire run time restrictions.
2004-02-04 Jose Ruiz <ruiz@act-europe.fr>
* restrict.ads, restrict.adb: Use the new restriction
No_Task_Attributes_Package instead of the old No_Task_Attributes.
* sem_prag.adb: No_Task_Attributes is a synonym of
No_Task_Attributes_Package.
* snames.ads, snames.adb: New entry for proper handling of
No_Task_Attributes.
* s-rident.ads: Adding restriction No_Task_Attributes_Package
(AI-00249) that supersedes the GNAT specific restriction
No_Task_Attributes.
2004-02-04 Ed Schonberg <schonberg@gnat.com>
* sem_prag.adb:
(Analyze_Pragma, case Warnings): In an inlined body, as in an instance
body, an identifier may be wrapped in an unchecked conversion.
2004-02-04 Vincent Celier <celier@gnat.com>
* lib-writ.ads: Comment update for the W lines
* bld.adb: (Expression): An empty string list is static
* fname-uf.adb: Minor comment update
* fname-uf.ads: (Get_File_Name): Document new parameter May_Fail
* gnatbind.adb:
Initialize Cumulative_Restrictions with the restrictions on the target
--
Index: 5gtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtaprop.adb,v
retrieving revision 1.9
diff -u -p -r1.9 5gtaprop.adb
--- 5gtaprop.adb 26 Jan 2004 21:56:05 -0000 1.9
+++ 5gtaprop.adb 4 Feb 2004 09:48:40 -0000
@@ -141,7 +141,6 @@ package body System.Task_Primitives.Oper
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
@@ -251,7 +250,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -259,7 +257,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -271,10 +268,8 @@ package body System.Task_Primitives.Oper
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_lock (L);
-
Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
pragma Assert (Result /= FUNC_ERR);
end Write_Lock;
@@ -283,7 +278,6 @@ package body System.Task_Primitives.Oper
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -293,7 +287,6 @@ package body System.Task_Primitives.Oper
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -316,7 +309,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
@@ -324,7 +316,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -334,7 +325,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -543,7 +533,6 @@ package body System.Task_Primitives.Oper
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
@@ -813,10 +802,8 @@ package body System.Task_Primitives.Oper
procedure Exit_Task is
Result : Interfaces.C.int;
-
begin
Result := pthread_set_ada_tcb (pthread_self, System.Null_Address);
-
pragma Assert (Result = 0);
end Exit_Task;
@@ -826,7 +813,6 @@ package body System.Task_Primitives.Oper
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result :=
pthread_kill (T.Common.LL.Thread,
@@ -854,7 +840,6 @@ package body System.Task_Primitives.Oper
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
@@ -961,8 +946,9 @@ package body System.Task_Primitives.Oper
if Result = FUNC_ERR then
raise Storage_Error; -- Insufficient resources.
end if;
-
end Initialize_Athread_Library;
+
+-- Package initialization
begin
Initialize_Athread_Library;
Index: 5gtasinf.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtasinf.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5gtasinf.adb
--- 5gtasinf.adb 26 Jan 2004 21:56:05 -0000 1.6
+++ 5gtasinf.adb 4 Feb 2004 09:48:40 -0000
@@ -77,16 +77,14 @@ package body System.Task_Info is
---------
function "+" (R : Resource_T) return Resource_Vector_T is
- Result : Resource_Vector_T := NO_RESOURCES;
-
+ Result : Resource_Vector_T := NO_RESOURCES;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
end "+";
function "+" (R1, R2 : Resource_T) return Resource_Vector_T is
- Result : Resource_Vector_T := NO_RESOURCES;
-
+ Result : Resource_Vector_T := NO_RESOURCES;
begin
Result (Resource_T'Pos (R1)) := True;
Result (Resource_T'Pos (R2)) := True;
@@ -94,44 +92,37 @@ package body System.Task_Info is
end "+";
function "+"
- (R : Resource_T;
- S : Resource_Vector_T)
- return Resource_Vector_T
+ (R : Resource_T;
+ S : Resource_Vector_T) return Resource_Vector_T
is
- Result : Resource_Vector_T := S;
-
+ Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
end "+";
function "+"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T
is
- Result : Resource_Vector_T := S;
-
+ Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
end "+";
function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is
- Result : Resource_Vector_T;
-
+ Result : Resource_Vector_T;
begin
Result := S1 or S2;
return Result;
end "+";
function "-"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T
is
- Result : Resource_Vector_T := S;
-
+ Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := False;
return Result;
@@ -177,21 +168,23 @@ package body System.Task_Info is
end if;
if Attr.NDPRI /= NDP_NONE then
--- ??? why is that comment out, should it be removed ?
+
+-- ??? why is this commented out, should it be removed ?
-- if Geteuid /= 0 then
-- raise Permission_Error;
-- end if;
- Status := sproc_attr_setprio
- (Sproc_Attr'Unrestricted_Access,
- int (Attr.NDPRI));
+ Status :=
+ sproc_attr_setprio
+ (Sproc_Attr'Unrestricted_Access, int (Attr.NDPRI));
end if;
- Status := sproc_create
- (Sproc'Unrestricted_Access,
- Sproc_Attr'Unrestricted_Access,
- null,
- System.Null_Address);
+ Status :=
+ sproc_create
+ (Sproc'Unrestricted_Access,
+ Sproc_Attr'Unrestricted_Access,
+ null,
+ System.Null_Address);
if Status /= 0 then
Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
@@ -199,7 +192,6 @@ package body System.Task_Info is
end if;
Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
-
end if;
if Status /= 0 then
@@ -217,12 +209,10 @@ package body System.Task_Info is
(Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
- NDPRI : Non_Degrading_Priority := NDP_NONE)
- return sproc_t
+ NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t
is
Attr : constant Sproc_Attributes :=
- (Sproc_Resources, CPU, Resident, NDPRI);
-
+ (Sproc_Resources, CPU, Resident, NDPRI);
begin
return New_Sproc (Attr);
end New_Sproc;
@@ -233,8 +223,7 @@ package body System.Task_Info is
function Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
- Thread_Timeslice : Duration := 0.0)
- return Thread_Attributes
+ Thread_Timeslice : Duration := 0.0) return Thread_Attributes
is
begin
return (False, Thread_Resources, Thread_Timeslice);
@@ -265,11 +254,10 @@ package body System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Thread_Attributes
+ return Thread_Attributes
is
Sproc : constant sproc_t := New_Sproc
- (Sproc_Resources, CPU, Resident, NDPRI);
-
+ (Sproc_Resources, CPU, Resident, NDPRI);
begin
return (True, Thread_Resources, Thread_Timeslice, Sproc);
end Bound_Thread_Attributes;
@@ -280,8 +268,7 @@ package body System.Task_Info is
function New_Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
- Thread_Timeslice : Duration := 0.0)
- return Task_Info_Type
+ Thread_Timeslice : Duration := 0.0) return Task_Info_Type
is
begin
return new Thread_Attributes'
@@ -295,8 +282,7 @@ package body System.Task_Info is
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
- Sproc : sproc_t)
- return Task_Info_Type
+ Sproc : sproc_t) return Task_Info_Type
is
begin
return new Thread_Attributes'
@@ -314,11 +300,10 @@ package body System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Task_Info_Type
+ return Task_Info_Type
is
Sproc : constant sproc_t := New_Sproc
- (Sproc_Resources, CPU, Resident, NDPRI);
-
+ (Sproc_Resources, CPU, Resident, NDPRI);
begin
return new Thread_Attributes'
(True, Thread_Resources, Thread_Timeslice, Sproc);
Index: 5gtasinf.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtasinf.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5gtasinf.ads
--- 5gtasinf.ads 21 Oct 2003 13:41:51 -0000 1.6
+++ 5gtasinf.ads 4 Feb 2004 09:48:40 -0000
@@ -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- --
@@ -63,14 +63,14 @@ package System.Task_Info is
-- Each thread has a number of attributes that dictate it's scheduling.
-- These attributes are:
- --
+
-- Bound_To_Sproc: whether the thread is bound to a specific sproc
-- for its entire lifetime.
- --
+
-- Timeslice: Amount of time that a thread is allowed to execute
-- before the system yeilds control to another thread
-- of equal priority.
- --
+
-- Resource_Vector: A bitmask used to control the binding of threads
-- to sprocs.
--
@@ -113,33 +113,27 @@ package System.Task_Info is
package Resource_Vector_Functions is
function "+"
- (R : Resource_T)
- return Resource_Vector_T;
+ (R : Resource_T) return Resource_Vector_T;
function "+"
- (R1 : Resource_T;
- R2 : Resource_T)
- return Resource_Vector_T;
+ (R1 : Resource_T;
+ R2 : Resource_T) return Resource_Vector_T;
function "+"
- (R : Resource_T;
- S : Resource_Vector_T)
- return Resource_Vector_T;
+ (R : Resource_T;
+ S : Resource_Vector_T) return Resource_Vector_T;
function "+"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T;
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T;
function "+"
- (S1 : Resource_Vector_T;
- S2 : Resource_Vector_T)
- return Resource_Vector_T;
+ (S1 : Resource_Vector_T;
+ S2 : Resource_Vector_T) return Resource_Vector_T;
function "-"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T;
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T;
end Resource_Vector_Functions;
----------------------
@@ -208,8 +202,7 @@ package System.Task_Info is
(Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
- NDPRI : Non_Degrading_Priority := NDP_NONE)
- return sproc_t;
+ NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t;
-- Allocates a sproc_t control structure and creates the
-- corresponding sproc.
@@ -239,14 +232,12 @@ package System.Task_Info is
function Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
- Thread_Timeslice : Duration := 0.0)
- return Thread_Attributes;
+ Thread_Timeslice : Duration := 0.0) return Thread_Attributes;
function Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
- Sproc : sproc_t)
- return Thread_Attributes;
+ Sproc : sproc_t) return Thread_Attributes;
function Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
@@ -255,20 +246,19 @@ package System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Thread_Attributes;
+ return Thread_Attributes;
type Task_Info_Type is access all Thread_Attributes;
function New_Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0)
- return Task_Info_Type;
+ return Task_Info_Type;
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
- Sproc : sproc_t)
- return Task_Info_Type;
+ Sproc : sproc_t) return Task_Info_Type;
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
@@ -277,7 +267,7 @@ package System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Task_Info_Type;
+ return Task_Info_Type;
Unspecified_Task_Info : constant Task_Info_Type := null;
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.13
diff -u -p -r1.13 ali.adb
--- ali.adb 2 Feb 2004 12:31:47 -0000 1.13
+++ ali.adb 4 Feb 2004 09:48:40 -0000
@@ -24,13 +24,13 @@
-- --
------------------------------------------------------------------------------
-with Butil; use Butil;
-with Debug; use Debug;
-with Fname; use Fname;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
+with Butil; use Butil;
+with Debug; use Debug;
+with Fname; use Fname;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
package body ALI is
@@ -105,8 +105,7 @@ package body ALI is
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
- Ignore_Lines : String := "X")
- return ALI_Id
+ Ignore_Lines : String := "X") return ALI_Id
is
P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
@@ -328,8 +327,10 @@ package body ALI is
-- Get_Name --
--------------
- function Get_Name (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id is
+ function Get_Name
+ (Lower : Boolean := False;
+ Ignore_Spaces : Boolean := False) return Name_Id
+ is
begin
Name_Len := 0;
Skip_Space;
Index: ali.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.ads,v
retrieving revision 1.12
diff -u -p -r1.12 ali.ads
--- ali.ads 2 Feb 2004 12:31:47 -0000 1.12
+++ ali.ads 4 Feb 2004 09:48:40 -0000
@@ -814,8 +814,7 @@ package ALI is
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
- Ignore_Lines : String := "X")
- return ALI_Id;
+ Ignore_Lines : String := "X") return ALI_Id;
-- Given the text, T, of an ALI file, F, scan and store the information
-- from the file, and return the Id of the resulting entry in the ALI
-- table. Switch settings may be modified as described above in the
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.19
diff -u -p -r1.19 bindgen.adb
--- bindgen.adb 2 Feb 2004 12:31:47 -0000 1.19
+++ bindgen.adb 4 Feb 2004 09:48:40 -0000
@@ -141,6 +141,16 @@ package body Bindgen is
procedure Gen_Output_File_C (Filename : String);
-- Generate output file (C code case)
+ procedure Gen_Restrictions_String_1;
+ -- Generate first restrictions string, which consists of the parameters
+ -- the first R line, as described in lib-writ.ads, with the restrictions
+ -- being those for the entire partition (from Cumulative_Restrictions).
+
+ procedure Gen_Restrictions_String_2;
+ -- Generate first restrictions string, which consists of the parameters
+ -- the second R line, as described in lib-writ.ads, with the restrictions
+ -- being those for the entire partition (from Cumulative_Restrictions).
+
procedure Gen_Versions_Ada;
-- Output series of definitions for unit versions (Ada code case)
@@ -358,13 +368,15 @@ package body Bindgen is
Set_String (" Restrictions : constant String :=");
Write_Statement_Buffer;
- Set_String (" """);
- for J in All_Restrictions loop
- null;
- end loop;
+ Set_String (" """);
+ Gen_Restrictions_String_1;
+ Set_String (""" &");
+ Write_Statement_Buffer;
- Set_String (""";");
+ Set_String (" """);
+ Gen_Restrictions_String_2;
+ Set_String (""" & ASCII.Nul;");
Write_Statement_Buffer;
WBI ("");
@@ -606,11 +618,8 @@ package body Bindgen is
-- Generate definition for restrictions string
Set_String (" const char *restrictions = """);
-
- for J in All_Restrictions loop
- null;
- end loop;
-
+ Gen_Restrictions_String_1;
+ Gen_Restrictions_String_2;
Set_String (""";");
Write_Statement_Buffer;
@@ -2452,6 +2461,52 @@ package body Bindgen is
Close_Binder_Output;
end Gen_Output_File_C;
+
+ -------------------------------
+ -- Gen_Restrictions_String_1 --
+ -------------------------------
+
+ procedure Gen_Restrictions_String_1 is
+ begin
+ for R in All_Boolean_Restrictions loop
+ if Cumulative_Restrictions.Set (R) then
+ Set_Char ('r');
+ elsif Cumulative_Restrictions.Violated (R) then
+ Set_Char ('v');
+ else
+ Set_Char ('n');
+ end if;
+ end loop;
+ end Gen_Restrictions_String_1;
+
+ -------------------------------
+ -- Gen_Restrictions_String_2 --
+ -------------------------------
+
+ procedure Gen_Restrictions_String_2 is
+ begin
+ for RP in All_Parameter_Restrictions loop
+ if Cumulative_Restrictions.Set (RP) then
+ Set_Char ('r');
+ Set_Int (Int (Cumulative_Restrictions.Value (RP)));
+ else
+ Set_Char ('n');
+ end if;
+
+ if not Cumulative_Restrictions.Violated (RP)
+ or else RP not in Checked_Parameter_Restrictions
+ then
+ Set_Char ('n');
+ else
+ Set_Char ('v');
+ Set_Int (Int (Cumulative_Restrictions.Count (RP)));
+
+ if Cumulative_Restrictions.Unknown (RP) then
+ Set_Char ('+');
+ end if;
+ end if;
+ end loop;
+ end Gen_Restrictions_String_2;
----------------------
-- Gen_Versions_Ada --
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.6
diff -u -p -r1.6 bld.adb
--- bld.adb 12 Jan 2004 11:36:12 -0000 1.6
+++ bld.adb 4 Feb 2004 09:48:40 -0000
@@ -525,11 +525,16 @@ package body Bld is
First_Expression_In_List (Current_Term);
begin
- if String_Node /= Empty_Node then
+ if String_Node = Empty_Node then
-- If String_Node is nil, it is an empty list,
- -- there is nothing to do
+ -- set Expression_Kind if it is still Undecided
+ if Expression_Kind = Undecided then
+ Expression_Kind := Static_String;
+ end if;
+
+ else
Expression
(Project => Project,
First_Term => Tree.First_Term (String_Node),
Index: fname-uf.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.adb,v
retrieving revision 1.10
diff -u -p -r1.10 fname-uf.adb
--- fname-uf.adb 2 Feb 2004 12:31:51 -0000 1.10
+++ fname-uf.adb 4 Feb 2004 09:48:40 -0000
@@ -123,8 +123,8 @@ package body Fname.UF is
-------------------
function Get_File_Name
- (Uname : Unit_Name_Type;
- Subunit : Boolean;
+ (Uname : Unit_Name_Type;
+ Subunit : Boolean;
May_Fail : Boolean := False) return File_Name_Type
is
Unit_Char : Character;
@@ -387,12 +387,12 @@ package body Fname.UF is
-- If we are in the second search of the table, we accept
-- the file name without checking, because we know that
- -- the file does not exist.
+ -- the file does not exist, except when May_Fail is True,
+ -- in which case we return No_File.
if No_File_Check then
if May_Fail then
return No_File;
-
else
return Fnam;
end if;
Index: fname-uf.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.ads,v
retrieving revision 1.6
diff -u -p -r1.6 fname-uf.ads
--- fname-uf.ads 2 Feb 2004 12:31:51 -0000 1.6
+++ fname-uf.ads 4 Feb 2004 09:48:40 -0000
@@ -44,14 +44,18 @@ package Fname.UF is
-----------------
function Get_File_Name
- (Uname : Unit_Name_Type;
- Subunit : Boolean;
+ (Uname : Unit_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
-- ensuring that the unit name meets the requirements given in package
-- Uname and described above.
+ -- When May_Fail is True, if the file cannot be found, this function
+ -- returns No_File. When it is False, if the file cannot be found,
+ -- a file name compatible with one pattern Source_File_Name pragma is
+ -- returned.
procedure Initialize;
-- Initialize internal tables. This is called automatically when the
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnatbind.adb
--- gnatbind.adb 2 Feb 2004 12:31:52 -0000 1.10
+++ gnatbind.adb 4 Feb 2004 09:48:40 -0000
@@ -447,6 +447,12 @@ begin
Targparm.Get_Target_Parameters;
+ -- Initialize Cumulative_Restrictions with the restrictions on the target
+ -- scanned from the system.ads file. Then as we read ALI files, we will
+ -- accumulate additional restrictions specified in other files.
+
+ Cumulative_Restrictions := Targparm.Restrictions_On_Target;
+
-- On OpenVMS, when -L is used, all external names used in pragmas Export
-- are in upper case. The reason is that on OpenVMS, the macro-assembler
-- MACASM-32, used to build Stand-Alone Libraries, only understands
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.6
diff -u -p -r1.6 gprcmd.adb
--- gprcmd.adb 2 Feb 2004 12:31:53 -0000 1.6
+++ gprcmd.adb 4 Feb 2004 09:48:40 -0000
@@ -113,6 +113,7 @@ procedure Gprcmd is
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;
@@ -473,9 +474,9 @@ begin
end if;
end;
- else
- -- Uknown command
+ -- Unknown command
+ else
Check_Args (False);
end if;
end;
Index: impunit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/impunit.adb,v
retrieving revision 1.10
diff -u -p -r1.10 impunit.adb
--- impunit.adb 12 Jan 2004 11:45:24 -0000 1.10
+++ impunit.adb 4 Feb 2004 09:48:40 -0000
@@ -297,6 +297,8 @@ package body Impunit is
"s-assert", -- System.Assertions
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
+ "s-restri", -- System.Restrictions
+ "s-rident", -- System.Rident
"s-tasinf", -- System.Task_Info
"s-wchcnv", -- System.Wch_Cnv
"s-wchcon"); -- System.Wch_Con
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.13
diff -u -p -r1.13 lib-writ.adb
--- lib-writ.adb 2 Feb 2004 12:31:53 -0000 1.13
+++ lib-writ.adb 4 Feb 2004 09:48:40 -0000
@@ -691,7 +691,7 @@ package body Lib.Writ is
end loop;
end Write_With_Lines;
- -- Start of processing for Writ_ALI
+ -- Start of processing for Write_ALI
begin
-- We never write an ALI file if the original operating mode was
@@ -919,7 +919,6 @@ package body Lib.Writ is
then
if not Has_No_Elaboration_Code (Cunit (Unit)) then
Main_Restrictions.Violated (No_Elaboration_Code) := True;
- Main_Restrictions.Count (No_Elaboration_Code) := -1;
end if;
end if;
end loop;
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.10
diff -u -p -r1.10 lib-writ.ads
--- lib-writ.ads 2 Feb 2004 12:31:54 -0000 1.10
+++ lib-writ.ads 4 Feb 2004 09:48:40 -0000
@@ -406,11 +406,13 @@ package Lib.Writ is
-- One of these lines is present for each unit that is mentioned in
-- an explicit with clause by the current unit. The first parameter
-- is the unit name in internal format. The second parameter is the
- -- file name of the file that must be compiled to compile this unit
- -- (which is usually the file for the body, except for packages
- -- which have no body). The third parameter is the file name of the
- -- library information file that contains the results of compiling
- -- this unit. The optional modifiers are used as follows:
+ -- file name of the file that must be compiled to compile this unit.
+ -- It is usually the file for the body, except for packages
+ -- which have no body; for units that need a body, if the source file
+ -- for the body cannot be found, the file name of the spec is used
+ -- instead. The third parameter is the file name of the library
+ -- information file that contains the results of compiling this unit.
+ -- The optional modifiers are used as follows:
--
-- E pragma Elaborate applies to this unit
--
Index: restrict.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.adb,v
retrieving revision 1.9
diff -u -p -r1.9 restrict.adb
--- restrict.adb 2 Feb 2004 12:31:55 -0000 1.9
+++ restrict.adb 4 Feb 2004 09:48:40 -0000
@@ -372,7 +372,7 @@ package body Restrict is
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 (No_Task_Attributes_Package)
and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
and then Restrictions.Set (Max_Task_Entries)
and then Restrictions.Set (Max_Protected_Entries)
@@ -472,7 +472,7 @@ package body Restrict is
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_Restriction (No_Task_Attributes_Package, N);
-- Set parameter restrictions
Index: restrict.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.ads,v
retrieving revision 1.7
diff -u -p -r1.7 restrict.ads
--- restrict.ads 2 Feb 2004 12:31:56 -0000 1.7
+++ restrict.ads 4 Feb 2004 09:48:40 -0000
@@ -77,27 +77,27 @@ package Restrict is
end record;
Unit_Array : constant array (Positive range <>) of Unit_Entry := (
- (No_Asynchronous_Control, "a-astaco"),
- (No_Calendar, "a-calend"),
- (No_Calendar, "calendar"),
- (No_Delay, "a-calend"),
- (No_Delay, "calendar"),
- (No_Dynamic_Priorities, "a-dynpri"),
- (No_Finalization, "a-finali"),
- (No_IO, "a-direio"),
- (No_IO, "directio"),
- (No_IO, "a-sequio"),
- (No_IO, "sequenio"),
- (No_IO, "a-ststio"),
- (No_IO, "a-textio"),
- (No_IO, "text_io "),
- (No_IO, "a-witeio"),
- (No_Task_Attributes, "a-tasatt"),
- (No_Streams, "a-stream"),
- (No_Unchecked_Conversion, "a-unccon"),
- (No_Unchecked_Conversion, "unchconv"),
- (No_Unchecked_Deallocation, "a-uncdea"),
- (No_Unchecked_Deallocation, "unchdeal"));
+ (No_Asynchronous_Control, "a-astaco"),
+ (No_Calendar, "a-calend"),
+ (No_Calendar, "calendar"),
+ (No_Delay, "a-calend"),
+ (No_Delay, "calendar"),
+ (No_Dynamic_Priorities, "a-dynpri"),
+ (No_Finalization, "a-finali"),
+ (No_IO, "a-direio"),
+ (No_IO, "directio"),
+ (No_IO, "a-sequio"),
+ (No_IO, "sequenio"),
+ (No_IO, "a-ststio"),
+ (No_IO, "a-textio"),
+ (No_IO, "text_io "),
+ (No_IO, "a-witeio"),
+ (No_Task_Attributes_Package, "a-tasatt"),
+ (No_Streams, "a-stream"),
+ (No_Unchecked_Conversion, "a-unccon"),
+ (No_Unchecked_Conversion, "unchconv"),
+ (No_Unchecked_Deallocation, "a-uncdea"),
+ (No_Unchecked_Deallocation, "unchdeal"));
-- The following map has True for all GNAT pragmas. It is used to
-- implement pragma Restrictions (No_Implementation_Restrictions)
@@ -123,7 +123,7 @@ package Restrict is
No_Select_Statements => True,
No_Standard_Storage_Pools => True,
No_Streams => True,
- No_Task_Attributes => True,
+ No_Task_Attributes_Package => True,
No_Task_Termination => True,
No_Wide_Characters => True,
Static_Priorities => True,
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.18
diff -u -p -r1.18 sem_prag.adb
--- sem_prag.adb 2 Feb 2004 12:31:58 -0000 1.18
+++ sem_prag.adb 4 Feb 2004 09:48:41 -0000
@@ -3280,6 +3280,15 @@ package body Sem_Prag is
Set_Restriction (No_Requeue_Statements, N);
Set_Warning (No_Requeue_Statements);
+ -- No_Task_Attributes is a synonym for
+ -- No_Task_Attributes_Package
+
+ elsif Chars (Expr) = Name_No_Task_Attributes then
+ Check_Restriction
+ (No_Implementation_Restrictions, Arg);
+ Set_Restriction (No_Task_Attributes_Package, N);
+ Set_Warning (No_Task_Attributes_Package);
+
-- Normal processing for all other cases
else
@@ -9648,7 +9657,8 @@ package body Sem_Prag is
-- the formal may be wrapped in a conversion if the actual
-- is a conversion. Retrieve the real entity name.
- if In_Instance_Body
+ if (In_Instance_Body
+ or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.16
diff -u -p -r1.16 snames.adb
--- snames.adb 2 Feb 2004 12:32:00 -0000 1.16
+++ snames.adb 4 Feb 2004 09:48:41 -0000
@@ -335,6 +335,7 @@ package body Snames is
"parameter_types#" &
"reference#" &
"no_requeue#" &
+ "no_task_attributes#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.16
diff -u -p -r1.16 snames.ads
--- snames.ads 2 Feb 2004 12:32:00 -0000 1.16
+++ snames.ads 4 Feb 2004 09:48:41 -0000
@@ -524,33 +524,34 @@ package Snames is
Name_Parameter_Types : constant Name_Id := N + 275;
Name_Reference : constant Name_Id := N + 276;
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;
+ Name_No_Task_Attributes : constant Name_Id := N + 278;
+ Name_Restricted : constant Name_Id := N + 279;
+ Name_Result_Mechanism : constant Name_Id := N + 280;
+ Name_Result_Type : constant Name_Id := N + 281;
+ Name_Runtime : constant Name_Id := N + 282;
+ Name_SB : constant Name_Id := N + 283;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 284;
+ Name_Section : constant Name_Id := N + 285;
+ Name_Semaphore : constant Name_Id := N + 286;
+ Name_Spec_File_Name : constant Name_Id := N + 287;
+ Name_Static : constant Name_Id := N + 288;
+ Name_Stack_Size : constant Name_Id := N + 289;
+ Name_Subunit_File_Name : constant Name_Id := N + 290;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 291;
+ Name_Task_Type : constant Name_Id := N + 292;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 293;
+ Name_Top_Guard : constant Name_Id := N + 294;
+ Name_UBA : constant Name_Id := N + 295;
+ Name_UBS : constant Name_Id := N + 296;
+ Name_UBSB : constant Name_Id := N + 297;
+ Name_Unit_Name : constant Name_Id := N + 298;
+ Name_Unknown : constant Name_Id := N + 299;
+ Name_Unrestricted : constant Name_Id := N + 300;
+ Name_Uppercase : constant Name_Id := N + 301;
+ Name_User : constant Name_Id := N + 302;
+ Name_VAX_Float : constant Name_Id := N + 303;
+ Name_VMS : constant Name_Id := N + 304;
+ Name_Working_Storage : constant Name_Id := N + 305;
-- 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
@@ -564,158 +565,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 + 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
+ First_Attribute_Name : constant Name_Id := N + 306;
+ Name_Abort_Signal : constant Name_Id := N + 306; -- GNAT
+ Name_Access : constant Name_Id := N + 307;
+ Name_Address : constant Name_Id := N + 308;
+ Name_Address_Size : constant Name_Id := N + 309; -- GNAT
+ Name_Aft : constant Name_Id := N + 310;
+ Name_Alignment : constant Name_Id := N + 311;
+ Name_Asm_Input : constant Name_Id := N + 312; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 313; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 314; -- VMS
+ Name_Bit : constant Name_Id := N + 315; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 316;
+ Name_Bit_Position : constant Name_Id := N + 317; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 318;
+ Name_Callable : constant Name_Id := N + 319;
+ Name_Caller : constant Name_Id := N + 320;
+ Name_Code_Address : constant Name_Id := N + 321; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 322;
+ Name_Compose : constant Name_Id := N + 323;
+ Name_Constrained : constant Name_Id := N + 324;
+ Name_Count : constant Name_Id := N + 325;
+ Name_Default_Bit_Order : constant Name_Id := N + 326; -- GNAT
+ Name_Definite : constant Name_Id := N + 327;
+ Name_Delta : constant Name_Id := N + 328;
+ Name_Denorm : constant Name_Id := N + 329;
+ Name_Digits : constant Name_Id := N + 330;
+ Name_Elaborated : constant Name_Id := N + 331; -- GNAT
+ Name_Emax : constant Name_Id := N + 332; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 333; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 334; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 335;
+ Name_External_Tag : constant Name_Id := N + 336;
+ Name_First : constant Name_Id := N + 337;
+ Name_First_Bit : constant Name_Id := N + 338;
+ Name_Fixed_Value : constant Name_Id := N + 339; -- GNAT
+ Name_Fore : constant Name_Id := N + 340;
+ Name_Has_Discriminants : constant Name_Id := N + 341; -- GNAT
+ Name_Identity : constant Name_Id := N + 342;
+ Name_Img : constant Name_Id := N + 343; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 344; -- GNAT
+ Name_Large : constant Name_Id := N + 345; -- Ada 83
+ Name_Last : constant Name_Id := N + 346;
+ Name_Last_Bit : constant Name_Id := N + 347;
+ Name_Leading_Part : constant Name_Id := N + 348;
+ Name_Length : constant Name_Id := N + 349;
+ Name_Machine_Emax : constant Name_Id := N + 350;
+ Name_Machine_Emin : constant Name_Id := N + 351;
+ Name_Machine_Mantissa : constant Name_Id := N + 352;
+ Name_Machine_Overflows : constant Name_Id := N + 353;
+ Name_Machine_Radix : constant Name_Id := N + 354;
+ Name_Machine_Rounds : constant Name_Id := N + 355;
+ Name_Machine_Size : constant Name_Id := N + 356; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 357; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 358;
+ Name_Maximum_Alignment : constant Name_Id := N + 359; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 360; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 361;
+ Name_Model_Epsilon : constant Name_Id := N + 362;
+ Name_Model_Mantissa : constant Name_Id := N + 363;
+ Name_Model_Small : constant Name_Id := N + 364;
+ Name_Modulus : constant Name_Id := N + 365;
+ Name_Null_Parameter : constant Name_Id := N + 366; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 367; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 368;
+ Name_Passed_By_Reference : constant Name_Id := N + 369; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 370;
+ Name_Pos : constant Name_Id := N + 371;
+ Name_Position : constant Name_Id := N + 372;
+ Name_Range : constant Name_Id := N + 373;
+ Name_Range_Length : constant Name_Id := N + 374; -- GNAT
+ Name_Round : constant Name_Id := N + 375;
+ Name_Safe_Emax : constant Name_Id := N + 376; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 377;
+ Name_Safe_Large : constant Name_Id := N + 378; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 379;
+ Name_Safe_Small : constant Name_Id := N + 380; -- Ada 83
+ Name_Scale : constant Name_Id := N + 381;
+ Name_Scaling : constant Name_Id := N + 382;
+ Name_Signed_Zeros : constant Name_Id := N + 383;
+ Name_Size : constant Name_Id := N + 384;
+ Name_Small : constant Name_Id := N + 385;
+ Name_Storage_Size : constant Name_Id := N + 386;
+ Name_Storage_Unit : constant Name_Id := N + 387; -- GNAT
+ Name_Tag : constant Name_Id := N + 388;
+ Name_Target_Name : constant Name_Id := N + 389; -- GNAT
+ Name_Terminated : constant Name_Id := N + 390;
+ Name_To_Address : constant Name_Id := N + 391; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 392; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 393; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 394;
+ Name_Unchecked_Access : constant Name_Id := N + 395;
+ Name_Unconstrained_Array : constant Name_Id := N + 396;
+ Name_Universal_Literal_String : constant Name_Id := N + 397; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 398; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 399; -- GNAT
+ Name_Val : constant Name_Id := N + 400;
+ Name_Valid : constant Name_Id := N + 401;
+ Name_Value_Size : constant Name_Id := N + 402; -- GNAT
+ Name_Version : constant Name_Id := N + 403;
+ Name_Wchar_T_Size : constant Name_Id := N + 404; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 405;
+ Name_Width : constant Name_Id := N + 406;
+ Name_Word_Size : constant Name_Id := N + 407; -- 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 + 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;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 408;
+ Name_Adjacent : constant Name_Id := N + 408;
+ Name_Ceiling : constant Name_Id := N + 409;
+ Name_Copy_Sign : constant Name_Id := N + 410;
+ Name_Floor : constant Name_Id := N + 411;
+ Name_Fraction : constant Name_Id := N + 412;
+ Name_Image : constant Name_Id := N + 413;
+ Name_Input : constant Name_Id := N + 414;
+ Name_Machine : constant Name_Id := N + 415;
+ Name_Max : constant Name_Id := N + 416;
+ Name_Min : constant Name_Id := N + 417;
+ Name_Model : constant Name_Id := N + 418;
+ Name_Pred : constant Name_Id := N + 419;
+ Name_Remainder : constant Name_Id := N + 420;
+ Name_Rounding : constant Name_Id := N + 421;
+ Name_Succ : constant Name_Id := N + 422;
+ Name_Truncation : constant Name_Id := N + 423;
+ Name_Value : constant Name_Id := N + 424;
+ Name_Wide_Image : constant Name_Id := N + 425;
+ Name_Wide_Value : constant Name_Id := N + 426;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 426;
-- Attributes that designate procedures
- 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;
+ First_Procedure_Attribute : constant Name_Id := N + 427;
+ Name_Output : constant Name_Id := N + 427;
+ Name_Read : constant Name_Id := N + 428;
+ Name_Write : constant Name_Id := N + 429;
+ Last_Procedure_Attribute : constant Name_Id := N + 429;
-- Remaining attributes are ones that return entities
- 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;
+ First_Entity_Attribute_Name : constant Name_Id := N + 430;
+ Name_Elab_Body : constant Name_Id := N + 430; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 431; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 432;
-- These attributes are the ones that return types
- 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;
+ First_Type_Attribute_Name : constant Name_Id := N + 433;
+ Name_Base : constant Name_Id := N + 433;
+ Name_Class : constant Name_Id := N + 434;
+ Last_Type_Attribute_Name : constant Name_Id := N + 434;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 434;
+ Last_Attribute_Name : constant Name_Id := N + 434;
-- Names of recognized locking policy identifiers
@@ -723,10 +724,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 + 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;
+ First_Locking_Policy_Name : constant Name_Id := N + 435;
+ Name_Ceiling_Locking : constant Name_Id := N + 435;
+ Name_Inheritance_Locking : constant Name_Id := N + 436;
+ Last_Locking_Policy_Name : constant Name_Id := N + 436;
-- Names of recognized queuing policy identifiers.
@@ -734,10 +735,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 + 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;
+ First_Queuing_Policy_Name : constant Name_Id := N + 437;
+ Name_FIFO_Queuing : constant Name_Id := N + 437;
+ Name_Priority_Queuing : constant Name_Id := N + 438;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 438;
-- Names of recognized task dispatching policy identifiers
@@ -745,193 +746,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 + 438;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 438;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 438;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 439;
+ Name_Fifo_Within_Priorities : constant Name_Id := N + 439;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 439;
-- Names of recognized checks for pragma Suppress
- 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;
+ First_Check_Name : constant Name_Id := N + 440;
+ Name_Access_Check : constant Name_Id := N + 440;
+ Name_Accessibility_Check : constant Name_Id := N + 441;
+ Name_Discriminant_Check : constant Name_Id := N + 442;
+ Name_Division_Check : constant Name_Id := N + 443;
+ Name_Elaboration_Check : constant Name_Id := N + 444;
+ Name_Index_Check : constant Name_Id := N + 445;
+ Name_Length_Check : constant Name_Id := N + 446;
+ Name_Overflow_Check : constant Name_Id := N + 447;
+ Name_Range_Check : constant Name_Id := N + 448;
+ Name_Storage_Check : constant Name_Id := N + 449;
+ Name_Tag_Check : constant Name_Id := N + 450;
+ Name_All_Checks : constant Name_Id := N + 451;
+ Last_Check_Name : constant Name_Id := N + 451;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- 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;
+ Name_Abort : constant Name_Id := N + 452;
+ Name_Abs : constant Name_Id := N + 453;
+ Name_Accept : constant Name_Id := N + 454;
+ Name_And : constant Name_Id := N + 455;
+ Name_All : constant Name_Id := N + 456;
+ Name_Array : constant Name_Id := N + 457;
+ Name_At : constant Name_Id := N + 458;
+ Name_Begin : constant Name_Id := N + 459;
+ Name_Body : constant Name_Id := N + 460;
+ Name_Case : constant Name_Id := N + 461;
+ Name_Constant : constant Name_Id := N + 462;
+ Name_Declare : constant Name_Id := N + 463;
+ Name_Delay : constant Name_Id := N + 464;
+ Name_Do : constant Name_Id := N + 465;
+ Name_Else : constant Name_Id := N + 466;
+ Name_Elsif : constant Name_Id := N + 467;
+ Name_End : constant Name_Id := N + 468;
+ Name_Entry : constant Name_Id := N + 469;
+ Name_Exception : constant Name_Id := N + 470;
+ Name_Exit : constant Name_Id := N + 471;
+ Name_For : constant Name_Id := N + 472;
+ Name_Function : constant Name_Id := N + 473;
+ Name_Generic : constant Name_Id := N + 474;
+ Name_Goto : constant Name_Id := N + 475;
+ Name_If : constant Name_Id := N + 476;
+ Name_In : constant Name_Id := N + 477;
+ Name_Is : constant Name_Id := N + 478;
+ Name_Limited : constant Name_Id := N + 479;
+ Name_Loop : constant Name_Id := N + 480;
+ Name_Mod : constant Name_Id := N + 481;
+ Name_New : constant Name_Id := N + 482;
+ Name_Not : constant Name_Id := N + 483;
+ Name_Null : constant Name_Id := N + 484;
+ Name_Of : constant Name_Id := N + 485;
+ Name_Or : constant Name_Id := N + 486;
+ Name_Others : constant Name_Id := N + 487;
+ Name_Out : constant Name_Id := N + 488;
+ Name_Package : constant Name_Id := N + 489;
+ Name_Pragma : constant Name_Id := N + 490;
+ Name_Private : constant Name_Id := N + 491;
+ Name_Procedure : constant Name_Id := N + 492;
+ Name_Raise : constant Name_Id := N + 493;
+ Name_Record : constant Name_Id := N + 494;
+ Name_Rem : constant Name_Id := N + 495;
+ Name_Renames : constant Name_Id := N + 496;
+ Name_Return : constant Name_Id := N + 497;
+ Name_Reverse : constant Name_Id := N + 498;
+ Name_Select : constant Name_Id := N + 499;
+ Name_Separate : constant Name_Id := N + 500;
+ Name_Subtype : constant Name_Id := N + 501;
+ Name_Task : constant Name_Id := N + 502;
+ Name_Terminate : constant Name_Id := N + 503;
+ Name_Then : constant Name_Id := N + 504;
+ Name_Type : constant Name_Id := N + 505;
+ Name_Use : constant Name_Id := N + 506;
+ Name_When : constant Name_Id := N + 507;
+ Name_While : constant Name_Id := N + 508;
+ Name_With : constant Name_Id := N + 509;
+ Name_Xor : constant Name_Id := N + 510;
-- 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 + 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;
+ First_Intrinsic_Name : constant Name_Id := N + 511;
+ Name_Divide : constant Name_Id := N + 511;
+ Name_Enclosing_Entity : constant Name_Id := N + 512;
+ Name_Exception_Information : constant Name_Id := N + 513;
+ Name_Exception_Message : constant Name_Id := N + 514;
+ Name_Exception_Name : constant Name_Id := N + 515;
+ Name_File : constant Name_Id := N + 516;
+ Name_Import_Address : constant Name_Id := N + 517;
+ Name_Import_Largest_Value : constant Name_Id := N + 518;
+ Name_Import_Value : constant Name_Id := N + 519;
+ Name_Is_Negative : constant Name_Id := N + 520;
+ Name_Line : constant Name_Id := N + 521;
+ Name_Rotate_Left : constant Name_Id := N + 522;
+ Name_Rotate_Right : constant Name_Id := N + 523;
+ Name_Shift_Left : constant Name_Id := N + 524;
+ Name_Shift_Right : constant Name_Id := N + 525;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 526;
+ Name_Source_Location : constant Name_Id := N + 527;
+ Name_Unchecked_Conversion : constant Name_Id := N + 528;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 529;
+ Name_To_Pointer : constant Name_Id := N + 530;
+ Last_Intrinsic_Name : constant Name_Id := N + 530;
-- Reserved words used only in Ada 95
- 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;
+ First_95_Reserved_Word : constant Name_Id := N + 531;
+ Name_Abstract : constant Name_Id := N + 531;
+ Name_Aliased : constant Name_Id := N + 532;
+ Name_Protected : constant Name_Id := N + 533;
+ Name_Until : constant Name_Id := N + 534;
+ Name_Requeue : constant Name_Id := N + 535;
+ Name_Tagged : constant Name_Id := N + 536;
+ Last_95_Reserved_Word : constant Name_Id := N + 536;
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 + 536;
+ Name_Raise_Exception : constant Name_Id := N + 537;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- 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;
+ Name_Binder : constant Name_Id := N + 538;
+ Name_Body_Suffix : constant Name_Id := N + 539;
+ Name_Builder : constant Name_Id := N + 540;
+ Name_Compiler : constant Name_Id := N + 541;
+ Name_Cross_Reference : constant Name_Id := N + 542;
+ Name_Default_Switches : constant Name_Id := N + 543;
+ Name_Exec_Dir : constant Name_Id := N + 544;
+ Name_Executable : constant Name_Id := N + 545;
+ Name_Executable_Suffix : constant Name_Id := N + 546;
+ Name_Extends : constant Name_Id := N + 547;
+ Name_Finder : constant Name_Id := N + 548;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 549;
+ Name_Gnatls : constant Name_Id := N + 550;
+ Name_Gnatstub : constant Name_Id := N + 551;
+ Name_Implementation : constant Name_Id := N + 552;
+ Name_Implementation_Exceptions : constant Name_Id := N + 553;
+ Name_Implementation_Suffix : constant Name_Id := N + 554;
+ Name_Languages : constant Name_Id := N + 555;
+ Name_Library_Dir : constant Name_Id := N + 556;
+ Name_Library_Auto_Init : constant Name_Id := N + 557;
+ Name_Library_GCC : constant Name_Id := N + 558;
+ Name_Library_Interface : constant Name_Id := N + 559;
+ Name_Library_Kind : constant Name_Id := N + 560;
+ Name_Library_Name : constant Name_Id := N + 561;
+ Name_Library_Options : constant Name_Id := N + 562;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 563;
+ Name_Library_Src_Dir : constant Name_Id := N + 564;
+ Name_Library_Symbol_File : constant Name_Id := N + 565;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 566;
+ Name_Library_Version : constant Name_Id := N + 567;
+ Name_Linker : constant Name_Id := N + 568;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 569;
+ Name_Locally_Removed_Files : constant Name_Id := N + 570;
+ Name_Naming : constant Name_Id := N + 571;
+ Name_Object_Dir : constant Name_Id := N + 572;
+ Name_Pretty_Printer : constant Name_Id := N + 573;
+ Name_Project : constant Name_Id := N + 574;
+ Name_Separate_Suffix : constant Name_Id := N + 575;
+ Name_Source_Dirs : constant Name_Id := N + 576;
+ Name_Source_Files : constant Name_Id := N + 577;
+ Name_Source_List_File : constant Name_Id := N + 578;
+ Name_Spec : constant Name_Id := N + 579;
+ Name_Spec_Suffix : constant Name_Id := N + 580;
+ Name_Specification : constant Name_Id := N + 581;
+ Name_Specification_Exceptions : constant Name_Id := N + 582;
+ Name_Specification_Suffix : constant Name_Id := N + 583;
+ Name_Switches : constant Name_Id := N + 584;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 584;
+ Name_Unaligned_Valid : constant Name_Id := N + 585;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 584;
+ Last_Predefined_Name : constant Name_Id := N + 585;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Index: s-restri.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-restri.ads,v
retrieving revision 1.1
diff -u -p -r1.1 s-restri.ads
--- s-restri.ads 2 Feb 2004 12:32:00 -0000 1.1
+++ s-restri.ads 4 Feb 2004 09:48:41 -0000
@@ -39,7 +39,7 @@ package System.Restrictions is
pragma Discard_Names;
package Rident is new System.Rident;
- Restrictions : Rident.Restrictions_Info;
+ Run_Time_Restrictions : Rident.Restrictions_Info;
------------------
-- Subprograms --
Index: s-restri.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-restri.adb,v
retrieving revision 1.1
diff -u -p -r1.1 s-restri.adb
--- s-restri.adb 2 Feb 2004 12:32:00 -0000 1.1
+++ s-restri.adb 4 Feb 2004 09:48:41 -0000
@@ -40,9 +40,9 @@ package body System.Restrictions is
function Abort_Allowed return Boolean is
begin
- return Restrictions.Violated (No_Abort_Statements)
+ return Run_Time_Restrictions.Violated (No_Abort_Statements)
or else
- Restrictions.Violated (Max_Asynchronous_Select_Nesting);
+ Run_Time_Restrictions.Violated (Max_Asynchronous_Select_Nesting);
end Abort_Allowed;
---------------------
@@ -51,12 +51,98 @@ package body System.Restrictions is
function Tasking_Allowed return Boolean is
begin
- return Restrictions.Violated (Max_Tasks)
+ return Run_Time_Restrictions.Violated (Max_Tasks)
or else
- Restrictions.Violated (No_Tasking);
+ Run_Time_Restrictions.Violated (No_Tasking);
end Tasking_Allowed;
+-- Package elaboration code (acquire restrictions)
+
begin
- null;
+ Acquire_Restrictions : declare
+
+ subtype Big_String is String (Positive);
+ type Big_String_Ptr is access all Big_String;
+
+ RString : Big_String_Ptr;
+ pragma Import (C, RString, "__gl_restrictions");
+
+ P : Natural := 1;
+ -- Pointer to scan string
+
+ C : Character;
+ -- Next character from string
+
+ function Get_Char return Character;
+ -- Get next character from string
+
+ function Get_Natural return Natural;
+ -- Scan out natural value known to be in range, updating P past it
+
+ --------------
+ -- Get_Char --
+ --------------
+
+ function Get_Char return Character is
+ begin
+ P := P + 1;
+ return RString (P - 1);
+ end Get_Char;
+
+ -----------------
+ -- Get_Natural --
+ -----------------
+
+ function Get_Natural return Natural is
+ N : Natural := 0;
+
+ begin
+ while RString (P) in '0' .. '9' loop
+ N := N * 10 + (Character'Pos (Get_Char) - Character'Pos ('0'));
+ end loop;
+
+ return N;
+ end Get_Natural;
+
+ -- Start of processing for Acquire_Restrictions
+
+ begin
+ -- Acquire data corresponding to first R line
+
+ for R in All_Boolean_Restrictions loop
+ C := Get_Char;
+
+ if C = 'v' then
+ Run_Time_Restrictions.Violated (R) := True;
+
+ elsif C = 'r' then
+ Run_Time_Restrictions.Set (R) := True;
+ end if;
+ end loop;
+
+ -- Acquire data corresponding to second R line
+
+ for RP in All_Parameter_Restrictions loop
+
+ -- Acquire restrictions pragma information
+
+ if Get_Char = 'r' then
+ Run_Time_Restrictions.Set (RP) := True;
+ Run_Time_Restrictions.Value (RP) := Get_Natural;
+ end if;
+
+ -- Acquire restrictions violations information
+
+ if Get_Char = 'v' then
+ Run_Time_Restrictions.Violated (RP) := True;
+ Run_Time_Restrictions.Count (RP) := Get_Natural;
+
+ if RString (P) = '+' then
+ Run_Time_Restrictions.Unknown (RP) := True;
+ P := P + 1;
+ end if;
+ end if;
+ end loop;
+ end Acquire_Restrictions;
end System.Restrictions;
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.3
diff -u -p -r1.3 s-rident.ads
--- s-rident.ads 2 Feb 2004 12:32:01 -0000 1.3
+++ s-rident.ads 4 Feb 2004 09:48:41 -0000
@@ -97,7 +97,7 @@ package System.Rident is
No_Standard_Storage_Pools, -- GNAT
No_Streams, -- GNAT
No_Task_Allocators, -- (RM D.7(7))
- No_Task_Attributes, -- GNAT
+ No_Task_Attributes_Package, -- GNAT
No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
No_Task_Termination, -- GNAT (Ravenscar)
No_Tasking, -- GNAT
@@ -154,8 +154,9 @@ package System.Rident is
-- Synonyms permitted for historical purposes of compatibility
- -- No_Requeue synonym for No_Requeue_Statements
- -- No_Tasking synonym for Max_Tasks => 0
+ -- No_Requeue synonym for No_Requeue_Statements
+ -- No_Tasking synonym for Max_Tasks => 0
+ -- No_Task_Attributes synonym for No_Task_Attributes_Package
subtype All_Restrictions is Restriction_Id range
Boolean_Entry_Barriers .. Max_Storage_At_Blocking;
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-17 23:04 ` Rainer Orth
2004-02-18 11:56 ` Arnaud Charlet
@ 2004-02-21 13:45 ` Rainer Orth
1 sibling, 0 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-21 13:45 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches, Olivier Hainque
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
> Tested on x86-linux
> --
> 2004-02-12 Olivier Hainque <hainque@act-europe.fr>
[...]
> * init.c (__gnat_error_handler for alpha-tru64): Arrange to clear the
> sc_onstack context indication before raising the exception to which
> the signal is mapped. Allows better handling of later signals possibly
> triggered by the resumed user code if the exception is handled.
This change broke Ada bootstrap on alpha-dec-osf*:
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c: In function `__gnat_error_handler':
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:486: warning: dereferencing type-punned pointer will break strict-aliasing rules
make[2]: *** [ada/init.o] Error 1
It cannot have been tested at all ;-(
As a workaround, I've used this patch:
Tue Feb 17 23:17:29 2004 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
* config/alpha/t-osf4: Ignore ada/init.o warnings.
Index: t-osf4
===================================================================
RCS file: /cvs/gcc/gcc/gcc/config/alpha/t-osf4,v
retrieving revision 1.7
diff -u -p -r1.7 t-osf4
--- t-osf4 31 Jul 2003 12:01:06 -0000 1.7
+++ t-osf4 17 Feb 2004 22:17:13 -0000
@@ -24,3 +24,5 @@ SHLIB_LINK = $(GCC_FOR_TARGET) $(LIBGCC2
SHLIB_INSTALL = $(INSTALL_DATA) $(SHLIB_NAME) $$(DESTDIR)$$(slibdir)/$(SHLIB_SONAME); \
rm -f $$(DESTDIR)$$(slibdir)/$(SHLIB_NAME); \
$(LN_S) $(SHLIB_SONAME) $$(DESTDIR)$$(slibdir)/$(SHLIB_NAME)
+
+ada/init.o-warn = -Wno-error
It gets me past this error (although with two additional warnings):
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c: In function `__gnat_error_handler':
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:387: warning: variable 'exception' might be clobbered by `longjmp' or `vfork'
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:390: warning: variable 'msg' might be clobbered by `longjmp' or `vfork'
only to fail later on with another error:
/vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
/vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-02-18 12:47 Arnaud Charlet
@ 2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-18 Emmanuel Briot <briot@act-europe.fr>
* ali.ads, ali.adb (First_Sdep_Entry): No longer a constant, so that
Scan_ALI can be used for multiple ALI files without reinitializing
between calls.
2004-02-18 Robert Dewar <dewar@gnat.com>
* debug.adb: Minor reformatting.
2004-02-18 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, case object): Set DECL_POINTER_ALIAS_SET
to zero if there is an address clause.
2004-02-18 Thomas Quinot <quinot@act-europe.fr>
* exp_util.adb (Side_Effect_Free): Any literal is side effects free.
2004-02-18 Gary Dismukes <dismukes@gnat.com>
* layout.adb (Layout_Component_List): Revise generation of call to
discriminant-checking function to pass selections of all of the type's
discriminants rather than just the variant-controlling discriminant.
2004-02-18 Olivier Hainque <hainque@act-europe.fr>
* 5gmastop.adb (Pop_Frame): Do not call exc_unwind, which is bound to
fail in the current setup and triggers spurious system error messages.
Pretend it occurred and failed instead.
2004-02-18 Vincent Celier <celier@gnat.com>
* bld.adb: Mark FLDFLAGS as saved
(Process_Declarative_Items): Add Linker'Linker_Options to FLDFLAGS when
it is not the root project. Put each directory to be
extended between double quotes to prevent it to be expanded on Windows.
(Recursive_Process): Reset CFLAGS/CXXFLAGS to nothing before processing
the project file. Set them back to their initial values if they have not
been set in the project file.
* gprcmd.adb: (Gprdebug, Debug): New global variables
(Display_Command): New procedure
(Usage): Document new command "linkopts"
Call Display_Command when env var GPRDEBUG has the value "TRUE"
Implement new command "linkopts"
Remove quotes that may be around arguments for "extend"
Always call Normalize_Pathname with arguments formatted for the platform
* Makefile.generic: Link C/C++ mains with $(FLDFLAGS)
Change @echo to @$(display) in target clean to be able to clean silently
* Makefile.prolog: Save FLDFLAGS and give it an initial empty value
* prj-part.adb (Project_Path_Name_Of): Do not put final result in
canonical case.
* prj-part.adb (Parse_Single_Project): Always call with From_Extended
= Extending_All when current project is an extending all project.
* vms_conv.adb (Output_File_Expected): New Boolean global variable,
set to True only for LINK command, after Unix switch -o.
(Process_Arguments): Set Output_File_Expected to True for LINK command
after Unix switch -o. When Output_File_Expected is True, never add an
extension to a file name.
* 5vml-tgt.adb (Build_Dynamic_Library): Do not append "/OPTIONS" to the
option file name, only to the --for-linker= switch.
(Option_File_Name): If option file name do not end with ".opt", append
"/OPTIONS".
2004-02-18 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 5gmastop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gmastop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5gmastop.adb
--- 5gmastop.adb 5 Jan 2004 15:20:42 -0000 1.8
+++ 5gmastop.adb 18 Feb 2004 11:47:54 -0000
@@ -7,7 +7,7 @@
-- B o d y --
-- (Version for IRIX/MIPS) --
-- --
--- 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- --
@@ -301,7 +301,25 @@ package body System.Machine_State_Operat
-- Lock_Task is used in many other places.
Lock_Task.all;
- Exc_Unwind (Scp);
+
+ -- ??? Calling exc_unwind in the current setup does not work and
+ -- triggers the emission of system warning messages. Why it does
+ -- not work remains to be investigated. Part of the problem is
+ -- probably a section naming issue (e.g. .eh_frame/.debug_frame).
+
+ -- Instead of letting the call take place for nothing and emit
+ -- messages we don't expect, we just arrange things to pretend it
+ -- occurred and failed.
+
+ -- ??? Until this is fixed, we shall document that the backtrace
+ -- computation facility does not work.
+
+ if False then
+ Exc_Unwind (Scp);
+ else
+ Scp.SC_PC := 0;
+ end if;
+
Unlock_Task.all;
if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.4
diff -u -p -r1.4 5vml-tgt.adb
--- 5vml-tgt.adb 23 Jan 2004 10:30:03 -0000 1.4
+++ 5vml-tgt.adb 18 Feb 2004 11:47:54 -0000
@@ -209,7 +209,9 @@ package body MLib.Tgt is
if Symbol_Data.Symbol_File = No_Name then
return "symvec.opt";
else
- return Get_Name_String (Symbol_Data.Symbol_File);
+ Get_Name_String (Symbol_Data.Symbol_File);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ return Name_Buffer (1 .. Name_Len);
end if;
end Option_File_Name;
@@ -244,8 +246,7 @@ package body MLib.Tgt is
Opt_File_Name : constant String := Option_File_Name;
Version : constant String := Version_String;
- For_Linker_Opt : constant String_Access :=
- new String'("--for-linker=" & Opt_File_Name);
+ For_Linker_Opt : String_Access;
-- Start of processing for Build_Dynamic_Library
@@ -256,6 +257,19 @@ package body MLib.Tgt is
Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
else
Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
+ end if;
+
+ -- If option file name does not ends with ".opt", append "/OPTIONS"
+ -- to its specification for the VMS linker.
+
+ if Opt_File_Name'Length > 4
+ and then
+ Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
+ then
+ For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
+ else
+ For_Linker_Opt :=
+ new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
end if;
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.16
diff -u -p -r1.16 ali.adb
--- ali.adb 12 Feb 2004 13:28:08 -0000 1.16
+++ ali.adb 18 Feb 2004 11:47:55 -0000
@@ -601,6 +601,8 @@ package body ALI is
-- Start of processing for Scan_ALI
begin
+ First_Sdep_Entry := Sdep.Last + 1;
+
-- Acquire lines to be ignored
if Read_Xref then
Index: ali.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.ads,v
retrieving revision 1.14
diff -u -p -r1.14 ali.ads
--- ali.ads 9 Feb 2004 14:56:03 -0000 1.14
+++ ali.ads 18 Feb 2004 11:47:56 -0000
@@ -593,8 +593,10 @@ package ALI is
No_Sdep_Id : constant Sdep_Id := Sdep_Id'First;
-- Special value indicating no Sdep table entry
- First_Sdep_Entry : constant Sdep_Id := No_Sdep_Id + 1;
- -- Id of first actual entry in table
+ First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1;
+ -- Id of first Sdep entry for current ali file. This is initialized to
+ -- the first Sdep entry in the table, and then incremented appropriately
+ -- as successive ALI files are scanned.
type Sdep_Record is record
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.8
diff -u -p -r1.8 bld.adb
--- bld.adb 12 Feb 2004 13:28:09 -0000 1.8
+++ bld.adb 18 Feb 2004 11:47:56 -0000
@@ -222,6 +222,7 @@ package body Bld is
Deps_Projects_String : aliased String := "DEPS_PROJECT";
Exec_String : aliased String := "EXEC";
Exec_Dir_String : aliased String := "EXEC_DIR";
+ Fldflags_String : aliased String := "FLDFLAGS";
Gnatmake_String : aliased String := "GNATMAKE";
Languages_String : aliased String := "LANGUAGES";
Ld_Flags_String : aliased String := "LD_FLAGS";
@@ -251,6 +252,7 @@ package body Bld is
Deps_Projects_String'Access,
Exec_String 'Access,
Exec_Dir_String 'Access,
+ Fldflags_String 'Access,
Gnatmake_String 'Access,
Languages_String 'Access,
Ld_Flags_String 'Access,
@@ -1426,7 +1428,8 @@ package body Bld is
(Pkg = No_Name
or else Pkg = Snames.Name_Naming
or else Pkg = Snames.Name_Compiler
- or else Pkg = Name_Ide);
+ or else Pkg = Name_Ide
+ or else Pkg = Snames.Name_Linker);
if Put_Declaration then
-- Some attributes are converted into reserved variables
@@ -1508,7 +1511,7 @@ package body Bld is
Put_Attribute (Project, Pkg, Item_Name, No_Name);
Put ("),$(shell gprcmd extend $(");
Put (Project_Name);
- Put_Line (".base_dir) '$(name)'))");
+ Put_Line (".base_dir) '""$(name)""'))");
elsif Item_Name = Snames.Name_Source_Files then
@@ -1959,6 +1962,38 @@ package body Bld is
end if;
end if;
end;
+
+ else
+ -- Other attribute are of no interest; suppress
+ -- their declarations.
+
+ Put_Declaration := False;
+ end if;
+
+ elsif Pkg = Snames.Name_Linker then
+ if Item_Name = Snames.Name_Linker_Options then
+ -- Only add linker options if this is not the root
+ -- project.
+
+ Put ("ifeq ($(");
+ Put (Project_Name);
+ Put (".root),False)");
+ New_Line;
+
+ -- Add the linker options to FLDFLAGS, in reverse
+ -- order.
+
+ Put (" FLDFLAGS:=$(shell gprcmd linkopts $(");
+ Put (Project_Name);
+ Put (".base_dir) $(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, No_Name);
+ Put (")) $(FLDFLAGS)");
+ New_Line;
+
+ Put ("endif");
+ New_Line;
+
else
-- Other attribute are of no interest; suppress
-- their declarations.
@@ -2686,6 +2721,15 @@ package body Bld is
-- Set defaults to some variables
+ -- CFLAGS and CXXFLAGS are set by default to nothing.
+ -- Their initial values have been saved, If they are not set
+ -- by this project file, then they will be reset to their
+ -- initial values. This is to avoid "inheritance" of these
+ -- flags from an imported project file.
+
+ Put_Line ("CFLAGS:=");
+ Put_Line ("CXXFLAGS:=");
+
IO.Mark (Src_Files_Init);
Put_Line ("src_files.specified:=FALSE");
@@ -3344,6 +3388,19 @@ package body Bld is
end if;
end;
+
+ -- If CFLAGS/CXXFLAGS have not been set, set them back to
+ -- their initial values.
+
+ Put_Line ("ifeq ($(CFLAGS),)");
+ Put_Line (" CFLAGS:=$(CFLAGS.saved)");
+ Put_Line ("endif");
+ New_Line;
+
+ Put_Line ("ifeq ($(CXXFLAGS),)");
+ Put_Line (" CXXFLAGS:=$(CXXFLAGS.saved)");
+ Put_Line ("endif");
+ New_Line;
-- If this is the main Makefile, include Makefile.Generic
Index: debug.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/debug.adb,v
retrieving revision 1.9
diff -u -p -r1.9 debug.adb
--- debug.adb 9 Feb 2004 14:56:03 -0000 1.9
+++ debug.adb 18 Feb 2004 11:47:57 -0000
@@ -470,7 +470,7 @@ package body Debug is
-- testing high integrity mode.
-- d.x No exception handlers in generated code. This causes exception
- -- handles to be eliminated from the generated code. They are still
+ -- handlers to be eliminated from the generated code. They are still
-- fully compiled and analyzed, they just get eliminated from the
-- code generation step.
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.28
diff -u -p -r1.28 decl.c
--- decl.c 12 Feb 2004 13:28:09 -0000 1.28
+++ decl.c 18 Feb 2004 11:47:58 -0000
@@ -1048,6 +1048,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
+ /* If we have an address clause and we've made this indirect, it's
+ not enough to merely mark the type as volatile since volatile
+ references only conflict with other volatile references while this
+ reference must conflict with all other references. So ensure that
+ the dereferenced value has alias set 0. */
+ if (Present (Address_Clause (gnat_entity)) && used_by_ref)
+ DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
+
if (definition && DECL_SIZE (gnu_decl) != 0
&& gnu_block_stack != 0
&& TREE_VALUE (gnu_block_stack) != 0
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.20
diff -u -p -r1.20 exp_util.adb
--- exp_util.adb 12 Feb 2004 13:28:10 -0000 1.20
+++ exp_util.adb 18 Feb 2004 11:47:58 -0000
@@ -3348,6 +3348,15 @@ package body Exp_Util is
when N_Unchecked_Expression =>
return Side_Effect_Free (Expression (N));
+ -- A literal is side effect free
+
+ when N_Character_Literal |
+ N_Integer_Literal |
+ N_Real_Literal |
+ N_String_Literal
+ =>
+ return True;
+
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.8
diff -u -p -r1.8 gprcmd.adb
--- gprcmd.adb 12 Feb 2004 13:28:10 -0000 1.8
+++ gprcmd.adb 18 Feb 2004 11:47:58 -0000
@@ -58,6 +58,10 @@ procedure Gprcmd is
-- ??? comments are thin throughout this unit
+ Gprdebug : constant String := To_Lower (Getenv ("GPRDEBUG").all);
+ Debug : constant Boolean := Gprdebug = "true";
+ -- When Debug is True, gprcmd displays its arguments to Standard_Error.
+ -- This is to help to debug.
procedure Cat (File : String);
-- Print the contents of file on standard output.
@@ -82,6 +86,9 @@ procedure Gprcmd is
procedure Copy_Time_Stamp (From, To : String);
-- Copy file time stamp from file From to file To.
+ procedure Display_Command;
+ -- Display the invoked command to Standard_Error
+
---------
-- Cat --
---------
@@ -256,6 +263,19 @@ procedure Gprcmd is
Free (Buffer);
end Deps;
+ ---------------------
+ -- Display_Command --
+ ---------------------
+
+ procedure Display_Command is
+ begin
+ for J in 0 .. Argument_Count loop
+ Put (Standard_Error, Argument (J) & ' ');
+ end loop;
+
+ New_Line (Standard_Error);
+ end Display_Command;
+
------------
-- Extend --
------------
@@ -354,6 +374,8 @@ procedure Gprcmd is
"get the prefix of the GNAT installation");
Put_Line (Standard_Error, " path " &
"convert a directory list into a path list");
+ Put_Line (Standard_Error, " linkopts " &
+ "process attribute Linker'Linker_Options");
Put_Line (Standard_Error, " ignore " &
"do nothing");
OS_Exit (1);
@@ -362,6 +384,10 @@ procedure Gprcmd is
-- Start of processing for Gprcmd
begin
+ if Debug then
+ Display_Command;
+ end if;
+
Check_Args (Argument_Count > 0);
declare
@@ -408,8 +434,11 @@ begin
if Is_Absolute_Path (Argument (J)) then
Put (Format_Pathname (Argument (J), UNIX));
else
- Put (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
- UNIX));
+ Put (Format_Pathname
+ (Normalize_Pathname
+ (Format_Pathname (Argument (J)),
+ Format_Pathname (Dir)),
+ UNIX));
end if;
if J < Argument_Count then
@@ -426,17 +455,33 @@ begin
begin
for J in 3 .. Argument_Count loop
- if Is_Absolute_Path (Argument (J)) then
- Extend (Format_Pathname (Argument (J), UNIX));
- else
- Extend
- (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
- UNIX));
- end if;
- if J < Argument_Count then
- Put (' ');
- end if;
+ -- Remove quotes that may have been added around each argument
+
+ declare
+ Arg : constant String := Argument (J);
+ First : Natural := Arg'First;
+ Last : Natural := Arg'Last;
+ begin
+ if Arg (First) = '"' and then Arg (Last) = '"' then
+ First := First + 1;
+ Last := Last - 1;
+ end if;
+ if Is_Absolute_Path (Arg (First .. Last)) then
+ Extend (Format_Pathname (Arg (First .. Last), UNIX));
+ else
+ Extend
+ (Format_Pathname
+ (Normalize_Pathname
+ (Format_Pathname (Arg (First .. Last)),
+ Format_Pathname (Dir)),
+ UNIX));
+ end if;
+
+ if J < Argument_Count then
+ Put (' ');
+ end if;
+ end;
end loop;
end;
@@ -489,6 +534,70 @@ begin
Put (Argument (J));
Put (Path_Separator);
end loop;
+
+ -- Check the linker options for relative paths. Insert the project
+ -- base dir before relative paths.
+
+ elsif Cmd = "linkopts" then
+ Check_Args (Argument_Count >= 2);
+
+ -- First argument is the base directory of the project file
+
+ declare
+ Base_Dir : constant String := Argument (2) & '/';
+ begin
+ -- process the remainder of the arguments
+
+ for J in 3 .. Argument_Count loop
+ declare
+ Arg : constant String := Argument (J);
+ begin
+ -- If it is a switch other than a -L switch, just send back
+ -- the argument.
+
+ if Arg (Arg'First) = '-' and then
+ (Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
+ then
+ Put (Arg);
+
+ else
+ -- If it is a file, check if its path is relative, and
+ -- if it is relative, add <project base dir>/ in front.
+ -- Otherwise just send back the argument.
+
+ if Arg'Length <= 2
+ or else Arg (Arg'First .. Arg'First + 1) /= "-L"
+ then
+ if not Is_Absolute_Path (Arg) then
+ Put (Base_Dir);
+ end if;
+
+ Put (Arg);
+
+ -- For -L switches, check if the path is relative and
+ -- proceed similarly.
+
+ else
+ Put ("-L");
+
+ if
+ not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
+ then
+ Put (Base_Dir);
+ end if;
+
+ Put (Arg (Arg'First + 2 .. Arg'Last));
+ end if;
+ end if;
+ end;
+
+ -- Insert a space between each processed argument
+
+ if J /= Argument_Count then
+ Put (' ');
+ end if;
+ end loop;
+ end;
-- For "ignore" do nothing
Index: layout.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/layout.adb,v
retrieving revision 1.11
diff -u -p -r1.11 layout.adb
--- layout.adb 21 Oct 2003 13:42:09 -0000 1.11
+++ layout.adb 18 Feb 2004 11:47:59 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -1980,11 +1980,13 @@ package body Layout is
else
declare
- EsizV : SO_Ref;
- RM_SizV : Node_Id;
- Dchoice : Node_Id;
- Discrim : Node_Id;
- Dtest : Node_Id;
+ EsizV : SO_Ref;
+ RM_SizV : Node_Id;
+ Dchoice : Node_Id;
+ Discrim : Node_Id;
+ Dtest : Node_Id;
+ D_List : List_Id;
+ D_Entity : Entity_Id;
begin
RM_Siz_Expr := Empty;
@@ -2052,16 +2054,6 @@ package body Layout is
-- Otherwise construct the appropriate test
else
- -- Discriminant to be tested
-
- Discrim :=
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Chars => Vname),
- Selector_Name =>
- New_Occurrence_Of
- (Entity (Name (Vpart)), Loc));
-
-- The test to be used in general is a call to the
-- discriminant checking function. However, it is
-- definitely worth special casing the very common
@@ -2072,6 +2064,16 @@ package body Layout is
if No (Next (Dchoice))
and then Nkind (Dchoice) /= N_Range
then
+ -- Discriminant to be tested
+
+ Discrim :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars => Vname),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Entity (Name (Vpart)), Loc));
+
Dtest :=
Make_Op_Eq (Loc,
Left_Opnd => Discrim,
@@ -2083,6 +2085,25 @@ package body Layout is
-- False when the passed discriminant value matches.
else
+ -- The checking function takes all of the type's
+ -- discriminants as parameters, so a list of all
+ -- the selected discriminants must be constructed.
+
+ D_List := New_List;
+ D_Entity := First_Discriminant (E);
+ while Present (D_Entity) loop
+ Append (
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars => Vname),
+ Selector_Name =>
+ New_Occurrence_Of
+ (D_Entity, Loc)),
+ D_List);
+
+ D_Entity := Next_Discriminant (D_Entity);
+ end loop;
+
Dtest :=
Make_Op_Not (Loc,
Right_Opnd =>
@@ -2091,7 +2112,7 @@ package body Layout is
New_Occurrence_Of
(Dcheck_Function (Var), Loc),
Parameter_Associations =>
- New_List (Discrim)));
+ D_List));
end if;
RM_Siz_Expr :=
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.7
diff -u -p -r1.7 Makefile.generic
--- Makefile.generic 12 Feb 2004 13:28:10 -0000 1.7
+++ Makefile.generic 18 Feb 2004 11:47:59 -0000
@@ -349,8 +349,8 @@ else
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
- @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
- $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
+ @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
+ @$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
endif
endif
@@ -363,7 +363,7 @@ ifeq ($(strip $(filter-out c c++ ada,$(L
ifeq ($(MAIN),ada)
# Ada main
link: $(LINKER) archive-objects force
- @(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
@$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
@@ -376,15 +376,15 @@ else
# C/C++ main
link: $(LINKER) archive-objects force
- @(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
@$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
- -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
+ -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
internal-build: $(LINKER) archive-objects force
@$(display) $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
- -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
+ -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
endif
else
@@ -483,20 +483,20 @@ internal-c++ : $(CXX_OBJECTS)
.PHONY: force internal-clean internal-archive internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
internal-clean:
- @echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
+ @$(display) $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
@$(RM) $(OBJ_DIR)/*$(OBJ_EXT)
- @echo $(RM) $(OBJ_DIR)/*.ali
+ @$(display) $(RM) $(OBJ_DIR)/*.ali
@$(RM) $(OBJ_DIR)/*.ali
- @echo $(RM) $(OBJ_DIR)/b~*
+ @$(display) $(RM) $(OBJ_DIR)/b~*
@$(RM) $(OBJ_DIR)/b~*
- @echo $(RM) $(OBJ_DIR)/b_*
+ @$(display) $(RM) $(OBJ_DIR)/b_*
@$(RM) $(OBJ_DIR)/b_*
- @echo $(RM) $(OBJ_DIR)/*$(AR_EXT)
+ @$(display) $(RM) $(OBJ_DIR)/*$(AR_EXT)
@$(RM) $(OBJ_DIR)/*$(AR_EXT)
- @echo $(RM) $(OBJ_DIR)/*.d
+ @$(display) $(RM) $(OBJ_DIR)/*.d
@$(RM) $(OBJ_DIR)/*.d
ifneq ($(EXEC),)
- @echo $(RM) $(EXEC_DIR)/$(EXEC)
+ @$(display) $(RM) $(EXEC_DIR)/$(EXEC)
@$(RM) $(EXEC_DIR)/$(EXEC)
endif
Index: Makefile.prolog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.prolog,v
retrieving revision 1.3
diff -u -p -r1.3 Makefile.prolog
--- Makefile.prolog 12 Jan 2004 11:36:13 -0000 1.3
+++ Makefile.prolog 18 Feb 2004 11:47:59 -0000
@@ -40,6 +40,7 @@ GNATMAKE.saved:=$(GNATMAKE)
ADAFLAGS.saved:=$(ADAFLAGS)
CFLAGS.saved:=$(CFLAGS)
CXXFLAGS.saved:=$(CXXFLAGS)
+FLDFLAGS.saved:=$(FLDFLAGS)
LIBS.saved:=$(LIBS)
LDFLAGS.saved:=$(LDFLAGS)
ADA_SOURCES.saved:=$(ADA_SOURCES)
@@ -57,6 +58,7 @@ CXX_EXT:=.cc
AR_EXT=.a
OBJ_EXT=.o
CC=gcc
+FLDFLAGS:=
# Default target is to build (compile/bind/link)
# Target build is defined in Makefile.generic
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.74
diff -u -p -r1.74 Make-lang.in
--- Make-lang.in 18 Feb 2004 07:01:01 -0000 1.74
+++ Make-lang.in 18 Feb 2004 11:47:59 -0000
@@ -1369,8 +1369,8 @@ ada/bindgen.o : ada/ada.ads ada/a-except
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
ada/bindusg.o : ada/bindusg.ads ada/bindusg.adb ada/gnat.ads \
ada/g-os_lib.ads ada/g-string.ads ada/osint.ads ada/output.ads \
@@ -1406,19 +1406,19 @@ ada/checks.o : ada/ada.ads ada/a-except.
ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \
- ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
+ ada/sem.ads ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/comperr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/comperr.ads ada/comperr.adb \
@@ -1565,24 +1565,25 @@ ada/exp_aggr.o : ada/ada.ads ada/a-excep
ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \
ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_tss.ads \
ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \
- ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \
+ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \
+ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch3.ads \
+ ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
+ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imgenu.ads \
+ ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
@@ -1779,36 +1780,35 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except
ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
- ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
- ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads \
- ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads \
- ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_intr.ads \
- ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \
- ada/expander.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
- ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
- ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
+ ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
+ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch6.ads \
+ ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \
+ ada/exp_disp.ads ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \
+ ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \
+ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
- ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads \
- ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads \
- ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \
- ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
- ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads
+ ada/sem.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch6.ads \
+ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \
+ ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
+ ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
+ ada/widechar.ads
ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
@@ -2333,12 +2333,12 @@ ada/gnatbind.o : ada/ada.ads ada/a-excep
ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \
ada/switch.ads ada/switch-b.ads ada/system.ads ada/s-casuti.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \
- ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads
ada/gnatvsn.o : ada/gnatvsn.ads ada/gnatvsn.adb ada/system.ads \
@@ -3345,28 +3345,28 @@ ada/sem_elab.o : ada/ada.ads ada/a-excep
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
- ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
- ada/sem.ads ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads \
- ada/sem_elab.ads ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
- ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \
- ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
- ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/widechar.ads
+ ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \
+ ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
+ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_cat.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_elab.adb \
+ ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
+ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \
@@ -3464,33 +3464,34 @@ ada/sem_prag.o : ada/ada.ads ada/a-excep
ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
ada/erroutc.ads ada/eval_fat.ads ada/exp_ch7.ads ada/exp_dist.ads \
ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/g-speche.ads ada/g-string.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \
- ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \
- ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \
- ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
- ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads \
- ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \
- ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \
- ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads \
- ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \
- ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \
- ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \
- ada/s-exctab.adb ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
- ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
- ada/validsw.ads ada/widechar.ads
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-speche.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
+ ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-sort.adb ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \
+ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
+ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
+ ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \
+ ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \
+ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \
+ ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb \
+ ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \
+ ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \
+ ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \
+ ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \
+ ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \
+ ada/widechar.ads
ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
@@ -3498,29 +3499,30 @@ ada/sem_res.o : ada/ada.ads ada/a-except
ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \
ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads \
ada/exp_ch2.ads ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/exp_util.adb ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
- ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
- ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads \
- ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
- ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb \
- ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \
- ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
- ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \
+ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \
+ ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
+ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
+ ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch4.ads \
+ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \
+ ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
+ ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
+ ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
ada/validsw.ads ada/widechar.ads
@@ -3809,15 +3811,14 @@ ada/table.o : ada/debug.ads ada/gnat.ads
ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/targparm.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/csets.ads \
- ada/debug.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
- ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \
- ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/targparm.adb ada/tree_io.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \
+ ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/namet.adb \
+ ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/targparm.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads ada/widechar.ads
ada/tbuild.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
Index: prj-part.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.adb,v
retrieving revision 1.11
diff -u -p -r1.11 prj-part.adb
--- prj-part.adb 23 Jan 2004 10:30:04 -0000 1.11
+++ prj-part.adb 18 Feb 2004 11:47:59 -0000
@@ -840,6 +840,8 @@ package body Prj.Part is
Project_Scan_State : Saved_Project_Scan_State;
Source_Index : Source_File_Index;
+ Extending : Boolean := False;
+
Extended_Project : Project_Node_Id := Empty_Node;
A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
@@ -1051,6 +1053,27 @@ package body Prj.Part is
Scan;
end loop;
+ -- See if this is an extending project
+
+ if Token = Tok_Extends then
+
+ -- Make sure that gnatmake will use mapping files
+
+ Create_Mapping_File := True;
+
+ -- We are extending another project
+
+ Extending := True;
+
+ Scan; -- scan past EXTENDS
+
+ if Token = Tok_All then
+ Extends_All := True;
+ Set_Is_Extending_All (Project);
+ Scan; -- scan past ALL
+ end if;
+ end if;
+
-- If the name is well formed, Buffer_Last is > 0
if Buffer_Last > 0 then
@@ -1098,7 +1121,7 @@ package body Prj.Part is
begin
-- Extending_All is always propagated
- if From_Extended = Extending_All then
+ if From_Extended = Extending_All or else Extends_All then
From_Ext := Extending_All;
-- Otherwise, From_Extended is set to Extending_Single if the
@@ -1149,22 +1172,7 @@ package body Prj.Part is
end if;
- if Token = Tok_Extends then
-
- -- Make sure that gnatmake will use mapping files
-
- Create_Mapping_File := True;
-
- -- We are extending another project
-
- Scan; -- scan past EXTENDS
-
- if Token = Tok_All then
- Extends_All := True;
- Set_Is_Extending_All (Project);
- Scan; -- scan past ALL
- end if;
-
+ if Extending then
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
@@ -1205,11 +1213,11 @@ package body Prj.Part is
else
declare
- From_Extended : Extension_Origin := None;
+ From_Ext : Extension_Origin := None;
begin
- if Is_Extending_All (Project) then
- From_Extended := Extending_All;
+ if From_Extended = Extending_All or else Extends_All then
+ From_Ext := Extending_All;
end if;
Parse_Single_Project
@@ -1217,7 +1225,7 @@ package body Prj.Part is
Extends_All => Extends_All,
Path_Name => Extended_Project_Path_Name,
Extended => True,
- From_Extended => From_Extended);
+ From_Extended => From_Ext);
end;
-- A project that extends an extending-all project is also
@@ -1640,11 +1648,10 @@ package body Prj.Part is
else
declare
- Final_Result : String :=
+ Final_Result : constant String :=
GNAT.OS_Lib.Normalize_Pathname (Result.all);
begin
Free (Result);
- Canonical_Case_File_Name (Final_Result);
return Final_Result;
end;
end if;
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.5
diff -u -p -r1.5 vms_conv.adb
--- vms_conv.adb 26 Jan 2004 14:47:48 -0000 1.5
+++ vms_conv.adb 18 Feb 2004 11:48:00 -0000
@@ -58,6 +58,10 @@ package body VMS_Conv is
-- if a COMMANDS_TRANSLATION switch has been encountered while processing
-- a MAKE Command.
+ Output_File_Expected : Boolean := False;
+ -- True for GNAT LINK after -o switch, so that the ".ali" extension is
+ -- not added to the executable file name.
+
package Buffer is new Table.Table
(Table_Component_Type => Character,
Table_Index_Type => Integer,
@@ -1111,6 +1115,7 @@ package body VMS_Conv is
end if;
The_Command := Command.Command;
+ Output_File_Expected := False;
-- Give usage information if only command given
@@ -1277,6 +1282,7 @@ package body VMS_Conv is
elsif Arg.all = "/?" then
Display_Command := True;
+ Output_File_Expected := False;
-- Copy -switch unchanged
@@ -1284,6 +1290,11 @@ package body VMS_Conv is
Place (' ');
Place (Arg.all);
+ -- Set Output_File_Expected for the next argument
+
+ Output_File_Expected :=
+ Arg.all = "-o" and then The_Command = Link;
+
-- Copy quoted switch with quotes stripped
elsif Arg (Arg'First) = '"' then
@@ -1297,6 +1308,8 @@ package body VMS_Conv is
Place (Arg (Arg'First + 1 .. Arg'Last - 1));
end if;
+ Output_File_Expected := False;
+
-- Parameter Argument
elsif Arg (Arg'First) /= '/'
@@ -1357,8 +1370,12 @@ package body VMS_Conv is
Place (' ');
Place_Lower (Normal_File.all);
+ -- Add extension if not present, except after
+ -- switch -o.
+
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
+ and then not Output_File_Expected
then
Place ('.');
Place (Command.Defext);
@@ -1488,9 +1505,15 @@ package body VMS_Conv is
end case;
end if;
+ -- Reset Output_File_Expected, in case it was True
+
+ Output_File_Expected := False;
+
-- Qualifier argument
else
+ Output_File_Expected := False;
+
-- This code is too heavily nested, should be
-- separated out as separate subprogram ???
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-19 14:44 ` Rainer Orth
@ 2004-02-21 13:45 ` Rainer Orth
0 siblings, 0 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-21 13:45 UTC (permalink / raw)
To: Zack Weinberg; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Zack Weinberg writes:
> Okay, so sdbout_symbol needs the same treatment that dbxout_symbol
> got. Sorry about this. Here is a revised patch.
With that patch (modulo the typo already mentioned), the alpha-dec-osf4.0f
bootstrap completed successfully without regressions compared to 20040210,
except for those three which occur on other platforms as well:
+FAIL: 23_containers/multiset/insert/1.cc execution test
+FAIL: 23_containers/multiset/invalidation/2.cc execution test
+FAIL: 23_containers/set/invalidation/2.cc execution test
Thanks.
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-19 14:57 ` Rainer Orth
@ 2004-02-21 13:45 ` Rainer Orth
0 siblings, 0 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-21 13:45 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches, Olivier Hainque
Arnaud Charlet writes:
> > It cannot have been tested at all ;-(
>
> It has been tested with mainline on x86-linux, and with gcc 3.2.3 on
> alpha-tru64. Enabling addition warnings or changing warnings as error is
> certainly 'expected' to generate lots of additional problems on various
> platforms.
Exactly, so testing a patch that only affects alpha-dec-osf* on
i386-pc-linux-gnu cannot be enough to check it into mainline.
> Addressing the warnings is easy in this case, I'll prepare a patch.
Fine, thanks. For the moment, I can live with the -Wno-error workaround in
t-osf4.
> > only to fail later on with another error:
> >
> > /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
> > /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
>
> OK, I can't resist:
>
> It cannot have been tested at all ;-)
I couldn't have put this better :-)
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 18:36 ` Zack Weinberg
2004-02-18 18:37 ` Rainer Orth
@ 2004-02-21 13:45 ` Zack Weinberg
1 sibling, 0 replies; 178+ messages in thread
From: Zack Weinberg @ 2004-02-21 13:45 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: Rainer Orth, gcc-patches, Olivier Hainque
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
>> only to fail later on with another error:
>>
>> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
>> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
Argh, this is yet another thing I fixed in the 3.4 iteration (not yet
applied) of that patch but that got lost somehow when I redid it for
mainline.
Please try the appended:
zw
===================================================================
Index: sdbout.c
--- sdbout.c 16 Feb 2004 18:55:01 -0000 1.87
+++ sdbout.c 18 Feb 2004 17:43:54 -0000
@@ -1460,7 +1460,7 @@ sdbout_global_decl (tree decl)
static void
sdbout_finish (const char *main_filename ATTRIBUTE_UNUSED)
{
- int i;
+ size_t i;
for (i = 0; i < VARRAY_ACTIVE_SIZE (deferred_global_decls); i++)
sdbout_symbol (VARRAY_TREE (deferred_global_decls, i), 0);
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 18:37 ` Rainer Orth
2004-02-18 19:41 ` Zack Weinberg
@ 2004-02-21 13:45 ` Rainer Orth
1 sibling, 0 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-21 13:45 UTC (permalink / raw)
To: Zack Weinberg; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Zack Weinberg writes:
> Argh, this is yet another thing I fixed in the 3.4 iteration (not yet
> applied) of that patch but that got lost somehow when I redid it for
> mainline.
>
> Please try the appended:
That's the patch that I came up with myself and that got me through
bootstrap.
Unfortunately, there are lots of testsuite regressions: cf. current
alpha-dec-osf4.0f testresults
http://gcc.gnu.org/ml/gcc-testresults/2004-02/msg00890.html
with
http://gcc.gnu.org/ml/gcc-testresults/2004-02/msg00589.html
--- ../../gcc-3.5.0-20040210/4.0f-gcc/mail-report.log Wed Feb 11 12:27:40 2004
+++ mail-report.log Wed Feb 18 12:44:52 2004
@@ -1,5 +1,5 @@
cat <<'EOF' |
-LAST_UPDATED: Tue Feb 10 18:05:06 UTC 2004
+LAST_UPDATED: Tue Feb 17 16:15:02 UTC 2004
Native configuration is alpha-dec-osf4.0f
@@ -62,6 +62,7 @@
FAIL: Thread_Alive execution - gij test
FAIL: Thread_Interrupt execution - gij test
FAIL: Thread_Interrupt execution - gij test
+FAIL: Thread_Interrupt -O3 output - bytecode->native test
FAIL: Thread_Wait_2 execution - gij test
FAIL: Thread_Wait_2 execution - gij test
FAIL: Thread_Wait_Interrupt execution - gij test
@@ -94,8 +95,8 @@
=== libjava Summary ===
-# of expected passes 3147
-# of unexpected failures 69
+# of expected passes 3146
+# of unexpected failures 70
# of expected failures 14
# of untested testcases 95
=== libstdc++ tests ===
@@ -120,12 +121,15 @@
WARNING: 22_locale/collate/transform/wchar_t/wrapped_env.cc compilation failed to produce executable
FAIL: 22_locale/collate/transform/wchar_t/wrapped_locale.cc (test for excess errors)
WARNING: 22_locale/collate/transform/wchar_t/wrapped_locale.cc compilation failed to produce executable
+FAIL: 23_containers/multiset/insert/1.cc execution test
+FAIL: 23_containers/multiset/invalidation/2.cc execution test
+FAIL: 23_containers/set/invalidation/2.cc execution test
FAIL: 27_io/basic_istream/extractors_arithmetic/char/12.cc execution test
=== libstdc++ Summary ===
-# of expected passes 2540
-# of unexpected failures 10
+# of expected passes 2541
+# of unexpected failures 13
# of expected failures 2
=== acats tests ===
@@ -137,6 +141,159 @@
Running target unix
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
FAIL: g++.dg/parse/attr-ctor1.C (test for excess errors)
FAIL: g++.dg/parse/stack1.C (test for excess errors)
FAIL: g++.dg/pch/system-1.C -g assembly comparison
@@ -147,11 +304,11 @@
=== g++ Summary ===
-# of expected passes 9439
-# of unexpected failures 4
-# of expected failures 68
+# of expected passes 9356
+# of unexpected failures 148
+# of expected failures 80
# of unsupported tests 70
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/testsuite/../g++ version 3.5.0 20040210 (experimental)
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/testsuite/../g++ version 3.5.0 20040217 (experimental)
=== g77 tests ===
@@ -162,7 +319,7 @@
# of expected passes 1788
# of unsupported tests 6
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/testsuite/../g77 version 3.5.0 20040210 (experimental)
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/testsuite/../g77 version 3.5.0 20040217 (experimental)
=== gcc tests ===
@@ -185,12 +342,203 @@
FAIL: gcc.c-torture/execute/20040208-2.c execution, -O3 -fomit-frame-pointer
FAIL: gcc.c-torture/execute/20040208-2.c execution, -O3 -g
FAIL: gcc.c-torture/execute/20040208-2.c execution, -Os
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-1.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+FAIL: gcc.dg/debug/debug-1.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+FAIL: gcc.dg/debug/debug-2.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+FAIL: gcc.dg/debug/debug-2.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
FAIL: gcc.dg/20040123-1.c scan-assembler abort
-FAIL: gcc.dg/array-quals-1.c scan-assembler-not \\.data(?!\\.rel\\.ro)
+FAIL: gcc.dg/array-quals-1.c scan-assembler-not \\\\.data(?!\\\\.rel\\\\.ro)
FAIL: gcc.dg/builtins-18.c (test for excess errors)
FAIL: gcc.dg/builtins-20.c (test for excess errors)
FAIL: gcc.dg/fwritable-strings-1.c (test for errors, line )
-FAIL: gcc.dg/pr14092-1.c (test for excess errors)
UNRESOLVED: gcc.dg/visibility-1.c
UNRESOLVED: gcc.dg/visibility-2.c
UNRESOLVED: gcc.dg/visibility-3.c
@@ -205,13 +553,13 @@
=== gcc Summary ===
-# of expected passes 24198
-# of unexpected failures 26
+# of expected passes 24043
+# of unexpected failures 179
# of expected failures 71
-# of unresolved testcases 8
+# of unresolved testcases 18
# of untested testcases 7
-# of unsupported tests 314
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/xgcc version 3.5.0 20040210 (experimental)
+# of unsupported tests 315
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/xgcc version 3.5.0 20040217 (experimental)
=== objc tests ===
@@ -222,12 +570,12 @@
# of expected passes 1341
# of unsupported tests 8
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/xgcc version 3.5.0 20040210 (experimental)
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/xgcc version 3.5.0 20040217 (experimental)
-Compiler version: 3.5.0 20040210 (experimental)
+Compiler version: 3.5.0 20040217 (experimental)
Platform: alpha-dec-osf4.0f
-configure flags: --prefix=/vol/gcc --with-local-prefix=/vol/gcc --disable-nls --host alpha-dec-osf4.0f --build alpha-dec-osf4.0f --target alpha-dec-osf4.0f
+configure flags: --prefix=/vol/gcc --with-local-prefix=/vol/gcc --disable-nls --enable-languages=ada,c++,f77,java,objc --host alpha-dec-osf4.0f --build alpha-dec-osf4.0f --target alpha-dec-osf4.0f
EOF
-Mail -s "Results for 3.5.0 20040210 (experimental) testsuite on alpha-dec-osf4.0f" gcc-testresults@gcc.gnu.org &&
+Mail -s "Results for 3.5.0 20040217 (experimental) testsuite on alpha-dec-osf4.0f" gcc-testresults@gcc.gnu.org &&
true
E.g.
FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
Excess errors:
In file included from /vol/gnu/src/gcc/gcc-dist/gcc/testsuite/g++.dg/debug/anonunion1.C:1:
<internal>:0: internal compiler error: Segmentation fault
This gets down to
$ ../cc1plus anonunion1.ii -gcoff1
In file included from anonunion1.ii:1:
<internal>:0: internal compiler error: Segmentation fault
Program received signal SIGSEGV, Segmentation fault.
0x000003ff800db020 in fprintf () from /usr/shlib/libc.so
(gdb) where
#0 0x000003ff800db020 in fprintf () from /usr/shlib/libc.so
During symbol reading, bad structure-type format.
#1 0x00000001202e6e08 in text_section () at /vol/gnu/src/gcc/gcc-dist/gcc/varasm.c:201
During symbol reading, bad structure-type format.
#2 0x00000001202e1a60 in sdbout_one_type (type=0x22b60) at /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1046
#3 0x00000001202e3074 in sdbout_symbol (decl=0x23a00, local=0) at /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:702
During symbol reading, bad structure-type format.
#4 0x0000000120079c34 in record_builtin_type (rid_index=RID_STATIC, name=0x140053020 "%s\n", type=0x0) at /vol/gnu/src/gcc/gcc-dist/gcc/cp/decl.c:2809
During symbol reading, bad structure-type format.
#5 0x00000001201dd1c0 in c_common_nodes_and_builtins () at /vol/gnu/src/gcc/gcc-dist/gcc/c-common.c:3085
#6 0x000000012007ae00 in cxx_init_decl_processing () at /vol/gnu/src/gcc/gcc-dist/gcc/cp/decl.c:2976
During symbol reading, bad structure-type format.
#7 0x000000012012ebc0 in cxx_init () at /vol/gnu/src/gcc/gcc-dist/gcc/cp/lex.c:410
During symbol reading, bad structure-type format.
#8 0x0000000120245914 in toplev_main (argc=0, argv=0x22b60) at /vol/gnu/src/gcc/gcc-dist/gcc/toplev.c:4510
#9 0x0000000120212990 in main (argc=0, argv=0x140053020) at /vol/gnu/src/gcc/gcc-dist/gcc/main.c:35
The crash happens because asm_out_file is NULL in varasm.c (text_section).
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
2004-02-12 14:44 Arnaud Charlet
2004-02-17 23:04 ` Rainer Orth
@ 2004-02-21 13:45 ` Arnaud Charlet
1 sibling, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 13:45 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-12 Olivier Hainque <hainque@act-europe.fr>
* decl.c (components_to_record): Don't claim that the internal fields
we make to hold the variant parts are semantically addressable, because
they are not.
* exp_pakd.adb (Create_Packed_Array_Type): Rename Esiz into PASize and
adjust the comment describing the modular type form when we can use it.
(Install_PAT): Account for the Esiz renaming.
* init.c (__gnat_error_handler for alpha-tru64): Arrange to clear the
sc_onstack context indication before raising the exception to which
the signal is mapped. Allows better handling of later signals possibly
triggered by the resumed user code if the exception is handled.
2004-02-12 Arnaud Charlet <charlet@act-europe.fr>
* 5zinit.adb: Removed, no longer used.
2004-02-12 Robert Dewar <dewar@gnat.com>
* ali.adb: Remove separating space between parameters on R line. Makes
format consistent with format used by the binder for Set_Globals call.
* atree.ads, atree.adb: Minor reformatting (new function header format)
* bindgen.adb: Add Run-Time Globals documentation section containing
detailed documentation of the globals passed from the binder file to
the run time.
* gnatls.adb: Minor reformatting
* init.c (__gnat_set_globals): Add note pointing to documentation in
bindgen.
* lib-writ.ads, lib-writ.adb: Remove separating space between
parameters on R line.
Makes format consistent with format used by the binder for Set_Globals
call.
* osint.ads: Add 2004 to copyright notice
Minor reformatting
* snames.ads: Correct capitalization of FIFO_Within_Priorities
Noticed during code reading, documentation issue only
* usage.adb: Remove junk line for obsolete C switch
Noticed during code reading
2004-02-12 Vincent Celier <celier@gnat.com>
* bld.adb (Process_Declarative_Items): For Source_Dirs call gprcmd
extend for each directory, so that multiple /** directories are
extended individually.
(Recursive_Process): Set the default for LANGUAGES to ada
* gprcmd.adb: Define new command "ignore", to do nothing.
Implement new comment "path".
* Makefile.generic: Suppress output when SILENT is set
Make sure that when compiler for C/C++ is gcc, the correct -x switch is
used, so that the correct compiler is invoked.
When compiler is gcc/g++, put search path in env vars C_INCLUDE_PATH/
CXX_INCLUDE_PATH, to avoid failure with too long command lines.
2004-02-12 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: Clean ups and remove obsolete targets.
2004-02-12 Ed Schonberg <schonberg@gnat.com>
* exp_ch5.adb: Remove Possible_Unligned_Slice, in favor of the similar
predicate declared in exp_util.
* exp_util.adb: Add comments.
* sem_ch10.adb (Analyze_Subunit): Remove ultimate parent unit from
visibility before compiling context of the subunit.
* sem_res.adb (Check_Parameterless_Call): If the context expects a
value but the name is a procedure, do not attempt to analyze as a call,
in order to obtain more telling diagnostics.
* sem_util.adb (Wrong_Type): Further enhancement to diagnose missing
'Access on parameterless function calls.
(Normalize_Actuals): For a parameterless function call with missing
actuals, defer diagnostic until resolution of enclosing call.
* sem_util.adb (Wrong_Type): If the context type is an access to
subprogram and the expression is a procedure name, suggest a missing
'attribute.
--
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.15
diff -u -p -r1.15 ali.adb
--- ali.adb 9 Feb 2004 14:56:03 -0000 1.15
+++ ali.adb 12 Feb 2004 13:26:31 -0000
@@ -991,10 +991,6 @@ package body ALI is
end case;
end loop;
- -- Skip separating space
-
- Checkc (' ');
-
-- Acquire information for parameter restrictions
for RP in All_Parameter_Restrictions loop
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.11
diff -u -p -r1.11 atree.adb
--- atree.adb 2 Feb 2004 12:31:47 -0000 1.11
+++ atree.adb 12 Feb 2004 13:26:31 -0000
@@ -1032,8 +1032,7 @@ package body Atree is
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty)
- return Node_Id
+ New_Scope : Entity_Id := Empty) return Node_Id
is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the
@@ -1053,8 +1052,7 @@ package body Atree is
-- Builds hash tables (number of elements >= threshold value)
function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id)
- return Elist_Id;
+ (Old_Elist : Elist_Id) return Elist_Id;
-- Called during second phase to copy element list doing replacements.
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
@@ -1167,8 +1165,7 @@ package body Atree is
---------------------------------
function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id)
- return Elist_Id
+ (Old_Elist : Elist_Id) return Elist_Id
is
M : Elmt_Id;
New_Elist : Elist_Id;
@@ -1243,8 +1240,7 @@ package body Atree is
--------------------------------
function Copy_List_With_Replacement
- (Old_List : List_Id)
- return List_Id
+ (Old_List : List_Id) return List_Id
is
New_List : List_Id;
E : Node_Id;
@@ -1270,14 +1266,12 @@ package body Atree is
--------------------------------
function Copy_Node_With_Replacement
- (Old_Node : Node_Id)
- return Node_Id
+ (Old_Node : Node_Id) return Node_Id
is
New_Node : Node_Id;
function Copy_Field_With_Replacement
- (Field : Union_Id)
- return Union_Id;
+ (Field : Union_Id) return Union_Id;
-- Given Field, which is a field of Old_Node, return a copy of it
-- if it is a syntactic field (i.e. its parent is Node), setting
-- the parent of the copy to poit to New_Node. Otherwise returns
@@ -1288,8 +1282,7 @@ package body Atree is
---------------------------------
function Copy_Field_With_Replacement
- (Field : Union_Id)
- return Union_Id
+ (Field : Union_Id) return Union_Id
is
begin
if Field = Union_Id (Empty) then
@@ -1829,8 +1822,7 @@ package body Atree is
function New_Entity
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Entity_Id
+ New_Sloc : Source_Ptr) return Entity_Id
is
Ent : Entity_Id;
@@ -1900,8 +1892,7 @@ package body Atree is
function New_Node
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Node_Id
+ New_Sloc : Source_Ptr) return Node_Id
is
Nod : Node_Id;
Index: atree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.ads,v
retrieving revision 1.7
diff -u -p -r1.7 atree.ads
--- atree.ads 2 Feb 2004 12:31:47 -0000 1.7
+++ atree.ads 12 Feb 2004 13:26:31 -0000
@@ -332,8 +332,7 @@ package Atree is
function New_Node
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Node_Id;
+ New_Sloc : Source_Ptr) return Node_Id;
-- Allocates a completely new node with the given node type and source
-- location values. All other fields are set to their standard defaults:
--
@@ -351,8 +350,7 @@ package Atree is
function New_Entity
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Entity_Id;
+ New_Sloc : Source_Ptr) return Entity_Id;
-- Similar to New_Node, except that it is used only for entity nodes
-- and returns an extended node.
@@ -427,8 +425,7 @@ package Atree is
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty)
- return Node_Id;
+ New_Scope : Entity_Id := Empty) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Tree copies the entire
-- syntactic subtree, including recursively any descendents whose parent
-- field references a copied node (descendents not linked to a copied node
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.20
diff -u -p -r1.20 bindgen.adb
--- bindgen.adb 4 Feb 2004 11:06:18 -0000 1.20
+++ bindgen.adb 12 Feb 2004 13:26:32 -0000
@@ -80,6 +80,88 @@ package body Bindgen is
Table_Increment => 200,
Table_Name => "IS_Pragma_Settings");
+ ----------------------
+ -- Run-Time Globals --
+ ----------------------
+
+ -- This section documents the global variables that are passed to the
+ -- run time from the generated binder file. The call that is made is
+ -- to the routine Set_Globals, which has the following spec:
+
+ -- procedure Set_Globals
+ -- (Main_Priority : Integer;
+ -- Time_Slice_Value : Integer;
+ -- WC_Encoding : Character;
+ -- Locking_Policy : Character;
+ -- Queuing_Policy : Character;
+ -- Task_Dispatching_Policy : Character;
+ -- Restrictions : System.Address;
+ -- Interrupt_States : System.Address;
+ -- Num_Interrupt_States : Integer;
+ -- Unreserve_All_Interrupts : Integer;
+ -- Exception_Tracebacks : Integer;
+ -- Zero_Cost_Exceptions : Integer);
+
+ -- Main_Priority is the priority value set by pragma Priority in the
+ -- main program. If no such pragma is present, the value is -1.
+
+ -- Time_Slice_Value is the time slice value set by pragma Time_Slice
+ -- in the main program, or by the use of a -Tnnn parameter for the
+ -- binder (if both are present, the binder value overrides). The
+ -- value is in milliseconds. A value of zero indicates that time
+ -- slicing should be suppressed. If no pragma is present, and no
+ -- -T switch was used, the value is -1.
+
+ -- WC_Encoding shows the wide character encoding method used for
+ -- the main program. This is one of the encoding letters defined
+ -- in System.WCh_Con.WC_Encoding_Letters.
+
+ -- Locking_Policy is a space if no locking policy was specified
+ -- for the partition. If a locking policy was specified, the value
+ -- is the upper case first character of the locking policy name,
+ -- for example, 'C' for Ceiling_Locking.
+
+ -- Queuing_Policy is a space if no queuing policy was specified
+ -- for the partition. If a queuing policy was specified, the value
+ -- is the upper case first character of the queuing policy name
+ -- for example, 'F' for FIFO_Queuing.
+
+ -- Task_Dispatching_Policy is a space if no task dispatching policy
+ -- was specified for the partition. If a task dispatching policy
+ -- was specified, the value is the upper case first character of
+ -- the policy name, e.g. 'F' for FIFO_Within_Priorities.
+
+ -- Restrictions is the address of a null-terminated string specifying the
+ -- restrictions information for the partition. The format is identical to
+ -- that of the parameter string found on R lines in ali files (see Lib.Writ
+ -- spec in lib-writ.ads for full details). The difference is that in this
+ -- context the values are the cumulative ones for the entire partition.
+
+ -- Interrupt_States is the address of a string used to specify the
+ -- cumulative results of Interrupt_State pragmas used in the partition.
+ -- The length of this string is determined by the last interrupt for which
+ -- such a pragma is given (the string will be a null string if no pragmas
+ -- were used). If pragma were present the entries apply to the interrupts
+ -- in sequence from the first interrupt, and are set to one of four
+ -- possible settings: 'n' for not specified, 'u' for user, 'r' for
+ -- run time, 's' for system, see description of Interrupt_State pragma
+ -- for further details.
+
+ -- Num_Interrupt_States is the length of the Interrupt_States string.
+ -- It will be set to zero if no Interrupt_State pragmas are present.
+
+ -- Unreserve_All_Interrupts is set to one if at least one unit in the
+ -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
+
+ -- Exception_Tracebacks is set to one if the -E parameter was present
+ -- in the bind and to zero otherwise. Note that on some targets exception
+ -- tracebacks are provided by default, so a value of zero for this
+ -- parameter does not necessarily mean no trace backs are available.
+
+ -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
+ -- this partition, and to zero if longjmp/setjmp exceptions are used.
+ -- the use of zero
+
-----------------------
-- Local Subprograms --
-----------------------
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.7
diff -u -p -r1.7 bld.adb
--- bld.adb 4 Feb 2004 11:06:18 -0000 1.7
+++ bld.adb 12 Feb 2004 13:26:32 -0000
@@ -1504,11 +1504,11 @@ package body Bld is
-- being an absolute directory name.
Put (Project_Name &
- ".src_dirs:=$(shell gprcmd extend $(");
- Put (Project_Name);
- Put (".base_dir) '$(");
+ ".src_dirs:=$(foreach name,$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")')");
+ Put ("),$(shell gprcmd extend $(");
+ Put (Project_Name);
+ Put_Line (".base_dir) '$(name)'))");
elsif Item_Name = Snames.Name_Source_Files then
@@ -2691,6 +2691,13 @@ package body Bld is
IO.Mark (Src_List_File_Init);
Put_Line ("src_list_file.specified:=FALSE");
+
+ -- Default language is Ada, but variable LANGUAGES may have
+ -- been changed by an imported Makefile. So, we set it
+ -- to "ada"; if attribute Languages is defined in the project
+ -- file, it will be redefined.
+
+ Put_Line ("LANGUAGES:=ada");
-- <PROJECT>.src_dirs is set by default to the project
-- directory.
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.27
diff -u -p -r1.27 decl.c
--- decl.c 2 Feb 2004 12:31:48 -0000 1.27
+++ decl.c 12 Feb 2004 13:26:32 -0000
@@ -5366,7 +5366,7 @@ components_to_record (tree gnu_record_ty
? TYPE_SIZE (gnu_record_type) : 0),
(all_rep_and_size
? bitsize_zero_node : 0),
- 1);
+ 0);
DECL_INTERNAL_P (gnu_field) = 1;
DECL_QUALIFIER (gnu_field) = gnu_qual;
@@ -5397,7 +5397,7 @@ components_to_record (tree gnu_record_ty
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
packed,
all_rep ? TYPE_SIZE (gnu_union_type) : 0,
- all_rep ? bitsize_zero_node : 0, 1);
+ all_rep ? bitsize_zero_node : 0, 0);
DECL_INTERNAL_P (gnu_union_field) = 1;
TREE_CHAIN (gnu_union_field) = gnu_field_list;
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_ch5.adb
--- exp_ch5.adb 2 Feb 2004 12:31:50 -0000 1.15
+++ exp_ch5.adb 12 Feb 2004 13:26:32 -0000
@@ -52,7 +52,6 @@ with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
@@ -181,16 +180,6 @@ package body Exp_Ch5 is
-- an object. Such objects can be aliased to parameters (unlike local
-- array references).
- function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean;
- -- Returns True if Arg (either the left or right hand side of the
- -- assignment) is a slice that could be unaligned wrt the array type.
- -- This is true if Arg is a component of a packed record, or is
- -- a record component to which a component clause applies. This
- -- is a little pessimistic, but the result of an unnecessary
- -- decision that something is possibly unaligned is only to
- -- generate a front end loop, which is not so terrible.
- -- It would really be better if backend handled this ???
-
-----------------------
-- Apply_Dereference --
-----------------------
@@ -242,60 +231,6 @@ package body Exp_Ch5 is
and then Is_Non_Local_Array (Prefix (Exp)));
end Is_Non_Local_Array;
- ------------------------------
- -- Possible_Unaligned_Slice --
- ------------------------------
-
- function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean is
- begin
- -- No issue if this is not a slice, or else strict alignment
- -- is not required in any case.
-
- if Nkind (Arg) /= N_Slice
- or else not Target_Strict_Alignment
- then
- return False;
- end if;
-
- -- No issue if the component type is a byte or byte aligned
-
- declare
- Array_Typ : constant Entity_Id := Etype (Arg);
- Comp_Typ : constant Entity_Id := Component_Type (Array_Typ);
- Pref : constant Node_Id := Prefix (Arg);
-
- begin
- if Known_Alignment (Array_Typ) then
- if Alignment (Array_Typ) = 1 then
- return False;
- end if;
-
- elsif Known_Component_Size (Array_Typ) then
- if Component_Size (Array_Typ) = 1 then
- return False;
- end if;
-
- elsif Known_Esize (Comp_Typ) then
- if Esize (Comp_Typ) <= System_Storage_Unit then
- return False;
- end if;
- end if;
-
- -- No issue if this is not a selected component
-
- if Nkind (Pref) /= N_Selected_Component then
- return False;
- end if;
-
- -- Else we test for a possibly unaligned component
-
- return
- Is_Packed (Etype (Pref))
- or else
- Present (Component_Clause (Entity (Selector_Name (Pref))));
- end;
- end Possible_Unaligned_Slice;
-
-- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
@@ -528,8 +463,8 @@ package body Exp_Ch5 is
elsif Is_Bit_Packed_Array (L_Type)
or else Is_Bit_Packed_Array (R_Type)
- or else Possible_Unaligned_Slice (Lhs)
- or else Possible_Unaligned_Slice (Rhs)
+ or else Is_Possibly_Unaligned_Slice (Lhs)
+ or else Is_Possibly_Unaligned_Slice (Rhs)
then
Loop_Required := True;
Index: exp_pakd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_pakd.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_pakd.adb
--- exp_pakd.adb 23 Jan 2004 10:30:03 -0000 1.10
+++ exp_pakd.adb 12 Feb 2004 13:26:32 -0000
@@ -700,7 +700,7 @@ package body Exp_Pakd is
Ancest : Entity_Id;
PB_Type : Entity_Id;
- Esiz : Uint;
+ PASize : Uint;
Decl : Node_Id;
PAT : Entity_Id;
Len_Dim : Node_Id;
@@ -770,10 +770,10 @@ package body Exp_Pakd is
-- Do not reset RM_Size if already set, as happens in the case
-- of a modular type.
- Set_Esize (PAT, Esiz);
+ Set_Esize (PAT, PASize);
if Unknown_RM_Size (PAT) then
- Set_RM_Size (PAT, Esiz);
+ Set_RM_Size (PAT, PASize);
end if;
-- Set remaining fields of packed array type
@@ -853,7 +853,7 @@ package body Exp_Pakd is
-- type, since this size clearly belongs to the packed array type. The
-- size of the conceptual unpacked type is always set to unknown.
- Esiz := Esize (Typ);
+ PASize := Esize (Typ);
-- Case of an array where at least one index is of an enumeration
-- type with a non-standard representation, but the component size
@@ -1099,7 +1099,8 @@ package body Exp_Pakd is
-- We can use the modular type, it has the form:
-- subtype tttPn is btyp
- -- range 0 .. 2 ** (Esize (Typ) * Csize) - 1;
+ -- range 0 .. 2 ** ((Typ'Length (1)
+ -- * ... * Typ'Length (n)) * Csize) - 1;
-- The bounds are statically known, and btyp is one
-- of the unsigned types, depending on the length. If the
@@ -1140,8 +1141,8 @@ package body Exp_Pakd is
Make_Integer_Literal (Loc, 0),
High_Bound => Lit))));
- if Esiz = Uint_0 then
- Esiz := Len_Bits;
+ if PASize = Uint_0 then
+ PASize := Len_Bits;
end if;
Install_PAT;
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.19
diff -u -p -r1.19 exp_util.adb
--- exp_util.adb 2 Feb 2004 12:31:51 -0000 1.19
+++ exp_util.adb 12 Feb 2004 13:26:32 -0000
@@ -2352,6 +2352,13 @@ package body Exp_Util is
function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
begin
+ -- ??? GCC3 will eventually handle strings with arbitrary alignments,
+ -- but for now the following check must be disabled.
+
+ -- if get_gcc_version >= 3 then
+ -- return False;
+ -- end if;
+
if Is_Entity_Name (P)
and then Is_Object (Entity (P))
and then Present (Renamed_Object (Entity (P)))
Index: gnatls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatls.adb,v
retrieving revision 1.13
diff -u -p -r1.13 gnatls.adb
--- gnatls.adb 9 Feb 2004 14:56:04 -0000 1.13
+++ gnatls.adb 12 Feb 2004 13:26:32 -0000
@@ -87,10 +87,10 @@ procedure Gnatls is
Print_Unit : Boolean := True;
Print_Source : Boolean := True;
Print_Object : Boolean := True;
- -- Flags controlling the form of the outpout
+ -- Flags controlling the form of the output
- Dependable : Boolean := False; -- flag -d
- Also_Predef : Boolean := False;
+ Dependable : Boolean := False; -- flag -d
+ Also_Predef : Boolean := False;
Unit_Start : Integer;
Unit_End : Integer;
@@ -132,14 +132,14 @@ procedure Gnatls is
-- updated to the full file name if available.
function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id;
- -- Give the Sdep entry corresponding to the unit U in ali record A.
+ -- Give the Sdep entry corresponding to the unit U in ali record A
procedure Output_Object (O : File_Name_Type);
-- Print out the name of the object when requested
procedure Output_Source (Sdep_I : Sdep_Id);
-- Print out the name and status of the source corresponding to this
- -- sdep entry
+ -- sdep entry.
procedure Output_Status (FS : File_Status; Verbose : Boolean);
-- Print out FS either in a coded form if verbose is false or in an
@@ -152,10 +152,10 @@ procedure Gnatls is
-- Reset Print flags properly when selective output is chosen
procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean);
- -- Scan and process lser specific arguments. Argv is a single argument.
+ -- Scan and process lser specific arguments. Argv is a single argument
procedure Usage;
- -- Print usage message.
+ -- Print usage message
-----------------
-- Add_Lib_Dir --
@@ -279,10 +279,12 @@ procedure Gnatls is
-- Verify is output is not wider than maximum number of columns
- Too_Long := Verbose_Mode or else
- (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
+ Too_Long :=
+ Verbose_Mode
+ or else
+ (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
- -- Set start and end of columns.
+ -- Set start and end of columns
Object_Start := 1;
Object_End := Object_Start - 1;
@@ -817,10 +819,9 @@ begin
Namet.Initialize;
Csets.Initialize;
- -- Use low level argument routines to avoid dragging in the secondary stack
+ -- Loop to scan out arguments
Next_Arg := 1;
-
Scan_Args : while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
@@ -956,6 +957,7 @@ begin
end loop;
Find_General_Layout;
+
for Id in ALIs.First .. ALIs.Last loop
declare
Last_U : Unit_Id;
@@ -993,7 +995,7 @@ begin
end if;
end loop;
- -- Print out list of dependable units
+ -- Print out list of units on which this unit depends (D lines)
if Dependable and then Print_Source then
if Verbose_Mode then
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.7
diff -u -p -r1.7 gprcmd.adb
--- gprcmd.adb 4 Feb 2004 11:06:18 -0000 1.7
+++ gprcmd.adb 12 Feb 2004 13:26:32 -0000
@@ -38,6 +38,9 @@
-- deps post process dependency makefiles
-- stamp copy file time stamp from file1 to file2
-- prefix get the prefix of the GNAT installation
+-- path convert a list of directories to a path list, inserting a
+-- path separator after each directory, including the last one
+-- ignore do nothing
with Gnatvsn;
with Osint; use Osint;
@@ -349,6 +352,10 @@ procedure Gprcmd is
"copy file time stamp from file1 to file2");
Put_Line (Standard_Error, " prefix " &
"get the prefix of the GNAT installation");
+ Put_Line (Standard_Error, " path " &
+ "convert a directory list into a path list");
+ Put_Line (Standard_Error, " ignore " &
+ "do nothing");
OS_Exit (1);
end Usage;
@@ -363,7 +370,8 @@ begin
begin
if Cmd = "-v" then
- -- Should this be on Standard_Error ???
+ -- Output on standard error, because only returned values should
+ -- go to standard output.
Put (Standard_Error, "GPRCMD ");
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
@@ -473,6 +481,19 @@ begin
end if;
end if;
end;
+
+ -- For "path" just add path separator after each directory argument
+
+ elsif Cmd = "path" then
+ for J in 2 .. Argument_Count loop
+ Put (Argument (J));
+ Put (Path_Separator);
+ end loop;
+
+ -- For "ignore" do nothing
+
+ elsif Cmd = "ignore" then
+ null;
-- Unknown command
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.23
diff -u -p -r1.23 init.c
--- init.c 2 Feb 2004 12:31:53 -0000 1.23
+++ init.c 12 Feb 2004 13:26:32 -0000
@@ -39,6 +39,10 @@
installed by this file are used to handle resulting signals that come
from these probes failing (i.e. touching protected pages) */
+/* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, and
+ 5zinit.adb. All these files implement the required functionality for
+ different targets. */
+
/* The following include is here to meet the published VxWorks requirement
that the __vxworks header appear before any other include. */
#ifdef __vxworks
@@ -154,6 +158,9 @@ __gnat_get_interrupt_state (int intrup)
binder file is not in the shared library. Global references across library
boundaries like this are not handled correctly in all systems. */
+/* For detailed description of the parameters to this routine, see the
+ section titled Run-Time Globals in package Bindgen (bindgen.adb) */
+
void
__gnat_set_globals (int main_priority,
int time_slice_val,
@@ -363,6 +370,7 @@ __gnat_initialize (void)
exclude this case in the above test. */
#include <signal.h>
+#include <setjmp.h>
#include <sys/siginfo.h>
static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *);
@@ -440,7 +448,48 @@ __gnat_error_handler (int sig, siginfo_t
if (mstate != 0)
*mstate = *context;
- Raise_From_Signal_Handler (exception, (char *) msg);
+ /* We are now going to raise the exception corresponding to the signal we
+ caught, which may eventually end up resuming the application code if the
+ exception is handled.
+
+ When the exception is handled, merely arranging for the *exception*
+ handler's context (stack pointer, program counter, other registers, ...)
+ to be installed is *not* enough to let the kernel think we've left the
+ *signal* handler. This has annoying implications if an alternate stack
+ has been setup for this *signal* handler, because the kernel thinks we
+ are still running on that alternate stack even after the jump, which
+ causes trouble at least as soon as another signal is raised.
+
+ We deal with this by forcing a "local" longjmp within the signal handler
+ below, forcing the "on alternate stack" indication to be reset (kernel
+ wise) on the way. If no alternate stack has been setup, this should be a
+ neutral operation. Otherwise, we will be in a delicate situation for a
+ short while because we are going to run the exception propagation code
+ within the alternate stack area (that is, with the stack pointer inside
+ the alternate stack bounds), but with the corresponding flag off from the
+ kernel's standpoint. We expect this to be ok as long as the propagation
+ code does not trigger a signal itself, which is expected.
+
+ ??? A better approach would be to at least delay this operation until the
+ last second, that is, until just before we jump to the exception handler,
+ if any. */
+ {
+ jmp_buf handler_jmpbuf;
+
+ if (setjmp (handler_jmpbuf) != 0)
+ Raise_From_Signal_Handler (exception, (char *) msg);
+ else
+ {
+ /* Arrange for the "on alternate stack" flag to be reset. See the
+ comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
+ struct sigcontext * handler_context
+ = (struct sigcontext *) & handler_jmpbuf;
+
+ handler_context->sc_onstack = 0;
+
+ longjmp (handler_jmpbuf, 1);
+ }
+ }
}
void
@@ -461,11 +510,12 @@ __gnat_install_handler (void)
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. */
+ /* 8K is a mininum to be able to propagate an exception using the GCC/ZCX
+ scheme. */
struct sigaltstack ss;
- ss.ss_sp = (void *) & sig_stack;
+ ss.ss_sp = (void *) sig_stack;
ss.ss_size = sizeof (sig_stack);
ss.ss_flags = 0;
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.15
diff -u -p -r1.15 lib-writ.adb
--- lib-writ.adb 9 Feb 2004 14:56:04 -0000 1.15
+++ lib-writ.adb 12 Feb 2004 13:26:32 -0000
@@ -940,10 +940,6 @@ package body Lib.Writ is
end if;
end loop;
- -- A separating space
-
- Write_Info_Char (' ');
-
-- And now the information for the parameter restrictions
for RP in All_Parameter_Restrictions loop
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.12
diff -u -p -r1.12 lib-writ.ads
--- lib-writ.ads 9 Feb 2004 14:56:04 -0000 1.12
+++ lib-writ.ads 12 Feb 2004 13:26:32 -0000
@@ -256,7 +256,7 @@ package Lib.Writ is
-- has been able to determine with respect to restrictions violations.
-- The format is:
- -- R <<restriction-characters>> space <<restriction-param-id-entries>>
+ -- R <<restriction-characters>> <<restriction-param-id-entries>>
-- The first parameter is a string of characters that records
-- information regarding restrictions that do not take parameter
@@ -283,8 +283,9 @@ package Lib.Writ is
-- has "v", which is not permitted, since these restrictions
-- are partition-wide.
- -- Following a space, the second parameter refers to restriction
- -- identifiers for which a parameter is given.
+ -- The second parameter, which immediately follows the first (with
+ -- no separating space) gives restriction information for identifiers
+ -- for which a parameter is given.
-- The parameter is a string of entries, one for each value in
-- Restrict.All_Parameter_Restrictions. Each entry has two
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.6
diff -u -p -r1.6 Makefile.generic
--- Makefile.generic 26 Jan 2004 14:47:48 -0000 1.6
+++ Makefile.generic 12 Feb 2004 13:26:32 -0000
@@ -9,12 +9,12 @@
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
-
+
# GCC is distributed in the hope that it will be useful,
# but WITHOUT 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
# along with GCC; see the file COPYING. If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330,
@@ -64,7 +64,7 @@
# CXX name of the C++ compiler (optional, default to gcc)
# AR_CMD command to create an archive (optional, default to "ar rc")
# AR_EXT file extension of an archive (optional, default to ".a")
-# RANLIB command to generate an index (optional, default to "ranlib")
+# RANLIB command to generate an index (optional, default to "ranlib")
# GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
# CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
@@ -78,6 +78,9 @@
# PROJECT_FILE name of the project file, without the .gpr extension
# DEPS_PROJECTS list of project dependencies (optional)
+# SILENT (optional) when defined, make -s will not output anything
+# when all commands are successful.
+
# Set the source search path for C and C++ if needed
ifndef MAIN
@@ -124,7 +127,7 @@ ifndef RANLIB
endif
ifndef GNATMAKE
- GNATMAKE=gnatmake
+ GNATMAKE:=gnatmake
endif
ifndef ARCHIVE
@@ -135,6 +138,39 @@ ifeq ($(EXEC_DIR),)
EXEC_DIR=$(OBJ_DIR)
endif
+# Define display to echo only when SILENT is not defined
+
+ifdef SILENT
+define display
+ @gprcmd ignore
+endef
+
+else
+define display
+ @echo
+endef
+endif
+
+# Make sure gnatmake is called silently when SILENT is set
+ifdef SILENT
+ GNATMAKE:=$(GNATMAKE) -q
+endif
+
+# If C/C++ compiler is gcc, make sure gcc is called with the switch indicating
+# the language, in case the extension is not standard.
+
+ifeq ($(strip $(filter-out %gcc,$(CC))),)
+ C_Compiler=$(CC) -x c
+else
+ C_Compiler=$(CC)
+endif
+
+ifeq ($(strip $(filter-out %gcc %g++,$(CXX))),)
+ CXX_Compiler=$(CXX) -x c++
+else
+ CXX_Compiler=$(CXX)
+endif
+
# Set the object search path
vpath %$(OBJ_EXT) $(OBJ_DIR)
@@ -222,8 +258,8 @@ else
endif
C_INCLUDES := $(foreach name,$(SRC_DIRS),-I$(name))
-ALL_CFLAGS = $(CFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
-ALL_CXXFLAGS = $(CXXFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
+ALL_CFLAGS = $(CFLAGS) $(DEP_CFLAGS)
+ALL_CXXFLAGS = $(CXXFLAGS) $(DEP_CFLAGS)
LDFLAGS := $(LIBS) $(LDFLAGS)
# Compute list of objects based on languages
@@ -276,7 +312,7 @@ else
internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
- @echo creating archive file for $(PROJECT_BASE)
+ @$(display) creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
-$(RANLIB) $(OBJ_DIR)/$@
@@ -313,7 +349,7 @@ else
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
- @echo $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
+ @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
endif
endif
@@ -327,11 +363,12 @@ ifeq ($(strip $(filter-out c c++ ada,$(L
ifeq ($(MAIN),ada)
# Ada main
link: $(LINKER) archive-objects force
- $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ @(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(display) $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
@@ -339,11 +376,12 @@ else
# C/C++ main
link: $(LINKER) archive-objects force
- $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ @(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(display) $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
@@ -360,7 +398,12 @@ endif
# Automatic handling of dependencies
ifeq ($(strip $(filter-out %gcc %g++,$(CC) $(CXX))),)
-# Compiler is GCC, take avantage of the preprocessor option -MD
+# Compiler is GCC, take avantage of the preprocessor option -MD and
+# C*_INCLUDE_PATH environment variables
+
+export C_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(C_INCLUDE_PATH)
+export CXX_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(CXX_INCLUDE_PATH)
+
DEP_CFLAGS = -Wp,-MD,$(OBJ_DIR)/$(*F).d
define post-compile
@@ -375,6 +418,9 @@ $(OBJ_DIR)/%.d:
else
# Compiler unknown, use a more general approach based on the output of $(CC) -M
+ALL_CFLAGS := $(ALL_CFLAGS) $(C_INCLUDES)
+ALL_CXXFLAGS := $(ALL_CXXFLAGS) $(C_INCLUDES)
+
DEP_FLAGS = -M
DEP_CFLAGS =
@@ -400,17 +446,17 @@ endif
# Compile C files individually
%$(OBJ_EXT) : %$(C_EXT)
- @echo $(CC) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(display) $(C_Compiler) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
ifndef FAKE_COMPILE
- @$(CC) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(C_Compiler) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
@$(post-compile)
endif
# Compile C++ files individually
%$(OBJ_EXT) : %$(CXX_EXT)
- @echo $(CXX) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(display) $(CXX_Compiler) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
ifndef FAKE_COMPILE
- @$(CXX) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(CXX_Compiler) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
@$(post-compile)
endif
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.71
diff -u -p -r1.71 Makefile.in
--- Makefile.in 2 Feb 2004 16:26:37 -0000 1.71
+++ Makefile.in 12 Feb 2004 13:26:33 -0000
@@ -1861,27 +1861,18 @@ rts-zfp: force
RTS_NAME=zfp RTS_SRCS="$(HIE_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
- -$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
+ $(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
$(CHMOD) a-wx rts-zfp/adalib/libgnat.a
-rts-none: force
- $(MAKE) $(FLAGS_TO_PASS) prepare-rts \
- RTS_NAME=none RTS_SRCS="$(HIE_SOURCES)" \
- RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
- COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
- -$(GNATMAKE) -Prts-none/none.gpr --GCC="../../../xgcc -B../../../"
- $(RM) rts-none/adalib/*.o
- $(CHMOD) a-wx rts-none/adalib/*.ali
-
rts-ravenscar: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
- -$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
+ $(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
cd rts-ravenscar/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-ravenscar/adalib/*.o
Index: osint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.ads,v
retrieving revision 1.11
diff -u -p -r1.11 osint.ads
--- osint.ads 5 Jan 2004 15:20:45 -0000 1.11
+++ osint.ads 12 Feb 2004 13:26:33 -0000
@@ -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- --
@@ -52,9 +52,8 @@ package Osint is
type File_Type is (Source, Library, Config, Definition, Preprocessing_Data);
function Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type;
-- Finds a source, library or config file depending on the value
-- of T following the directory search order rules unless N is the
-- name of the file just read with Next_Main_File and already
@@ -155,8 +154,7 @@ package Osint is
function To_Canonical_File_List
(Wildcard_Host_File : String;
- Only_Dirs : Boolean)
- return String_Access_List_Access;
+ Only_Dirs : Boolean) return String_Access_List_Access;
-- Expand a wildcard host syntax file or directory specification (e.g. on
-- a VMS host, any file or directory spec that contains:
-- "*", or "%", or "...")
@@ -165,8 +163,7 @@ package Osint is
function To_Canonical_Dir_Spec
(Host_Dir : String;
- Prefix_Style : Boolean)
- return String_Access;
+ Prefix_Style : Boolean) return String_Access;
-- Convert a host syntax directory specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir").
-- If Prefix_Style then make it a valid file specification prefix.
@@ -176,30 +173,26 @@ package Osint is
-- this simply means the spec has a trailing slash ("/").
function To_Canonical_File_Spec
- (Host_File : String)
- return String_Access;
+ (Host_File : String) return String_Access;
-- Convert a host syntax file specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g.
-- "/sys$device/dir/file.ext.69").
function To_Canonical_Path_Spec
- (Host_Path : String)
- return String_Access;
+ (Host_Path : String) return String_Access;
-- Convert a host syntax Path specification (e.g. on a VMS host:
-- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g.
-- "/sys$device/foo:disk$user/foo").
function To_Host_Dir_Spec
(Canonical_Dir : String;
- Prefix_Style : Boolean)
- return String_Access;
+ Prefix_Style : Boolean) return String_Access;
-- Convert a canonical syntax directory specification to host syntax.
-- The Prefix_Style flag is currently ignored but should be set to
-- False.
function To_Host_File_Spec
- (Canonical_File : String)
- return String_Access;
+ (Canonical_File : String) return String_Access;
-- Convert a canonical syntax file specification to host syntax.
function Relocate_Path
@@ -209,9 +202,8 @@ package Osint is
-- replace the Prefix substring with the root installation directory.
-- By default, try to compute the root installation directory by looking
-- at the executable name as it was typed on the command line and, if
- -- needed, use the PATH environment variable.
- -- If the above computation fails, return Path.
- -- This function assumes that Prefix'First = Path'First
+ -- needed, use the PATH environment variable. If the above computation
+ -- fails, return Path. This function assumes Prefix'First = Path'First.
function Shared_Lib (Name : String) return String;
-- Returns the runtime shared library in the form -l<name>-<version> where
@@ -244,8 +236,7 @@ package Osint is
procedure Get_Next_Dir_In_Path_Init
(Search_Path : String_Access);
function Get_Next_Dir_In_Path
- (Search_Path : String_Access)
- return String_Access;
+ (Search_Path : String_Access) return String_Access;
-- These subprograms are used to parse out the directory names in a
-- search path specified by a Search_Path argument. The procedure
-- initializes an internal pointer to point to the initial directory
@@ -292,8 +283,7 @@ package Osint is
function Get_RTS_Search_Dir
(Search_Dir : String;
- File_Type : Search_File_Type)
- return String_Ptr;
+ File_Type : Search_File_Type) return String_Ptr;
-- This function retrieves the paths to the search (resp. lib) dirs and
-- return them. The search dir can be absolute or relative. If the search
-- dir contains Include_Search_File (resp. Object_Search_File), then this
@@ -382,9 +372,8 @@ package Osint is
-- called Source_File_Data (Cache => True). See below.
function Matching_Full_Source_Name
- (N : File_Name_Type;
- T : Time_Stamp_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : Time_Stamp_Type) return File_Name_Type;
-- Same semantics than Full_Source_Name but will search on the source
-- path until a source file with time stamp matching T is found. If
-- none is found returns No_File.
@@ -440,8 +429,7 @@ package Osint is
function Read_Library_Info
(Lib_File : File_Name_Type;
- Fatal_Err : Boolean := False)
- return Text_Buffer_Ptr;
+ Fatal_Err : Boolean := False) return Text_Buffer_Ptr;
-- Allocates a Text_Buffer of appropriate length and reads in the entire
-- source of the library information from the library information file
-- whose name is given by the parameter Name.
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_ch10.adb
--- sem_ch10.adb 2 Feb 2004 12:31:56 -0000 1.15
+++ sem_ch10.adb 12 Feb 2004 13:26:33 -0000
@@ -1475,8 +1475,12 @@ package body Sem_Ch10 is
end if;
end if;
+ Set_Is_Immediately_Visible (Par_Unit, False);
+
Analyze_Subunit_Context;
+
Re_Install_Parents (Lib_Unit, Par_Unit);
+ Set_Is_Immediately_Visible (Par_Unit);
-- If the context includes a child unit of the parent of the
-- subunit, the parent will have been removed from visibility,
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.21
diff -u -p -r1.21 sem_res.adb
--- sem_res.adb 2 Feb 2004 12:31:59 -0000 1.21
+++ sem_res.adb 12 Feb 2004 13:26:33 -0000
@@ -801,6 +801,22 @@ package body Sem_Res is
Require_Entity (N);
end if;
+ -- If the context expects a value, and the name is a procedure,
+ -- this is most likely a missing 'Access. Do not try to resolve
+ -- the parameterless call, error will be caught when the outer
+ -- call is analyzed.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Procedure
+ and then not Is_Overloaded (N)
+ and then
+ (Nkind (Parent (N)) = N_Parameter_Association
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ then
+ return;
+ end if;
+
-- Rewrite as call if overloadable entity that is (or could be, in
-- the overloaded case) a function call. If we know for sure that
-- the entity is an enumeration literal, we do not rewrite it.
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_util.adb
--- sem_util.adb 13 Jan 2004 11:51:34 -0000 1.20
+++ sem_util.adb 12 Feb 2004 13:26:33 -0000
@@ -4881,17 +4881,28 @@ package body Sem_Util is
or else Sloc (S) = Standard_Location)
and then Is_Overloadable (S)
then
- Error_Msg_Name_1 := Chars (S);
- Error_Msg_Sloc := Sloc (S);
- Error_Msg_NE
- ("missing argument for parameter & " &
- "in call to % declared #", N, Formal);
+ if No (Actuals)
+ and then
+ (Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) = N_Function_Call
+ or else
+ Nkind (Parent (N)) = N_Parameter_Association))
+ then
+ Set_Etype (N, Etype (S));
+ else
+ Error_Msg_Name_1 := Chars (S);
+ Error_Msg_Sloc := Sloc (S);
+ Error_Msg_NE
+ ("missing argument for parameter & " &
+ "in call to % declared #", N, Formal);
+ end if;
elsif Is_Overloadable (S) then
Error_Msg_Name_1 := Chars (S);
- -- Point to type derivation that
- -- generated the operation.
+ -- Point to type derivation that generated the
+ -- operation.
Error_Msg_Sloc := Sloc (Parent (S));
@@ -6358,7 +6369,22 @@ package body Sem_Util is
or else
Ekind (Entity (Expr)) = E_Generic_Procedure)
then
- Error_Msg_N ("found procedure name instead of function!", Expr);
+ if Ekind (Expec_Type) = E_Access_Subprogram_Type then
+ Error_Msg_N
+ ("found procedure name, possibly missing Access attribute!",
+ Expr);
+ else
+ Error_Msg_N ("found procedure name instead of function!", Expr);
+ end if;
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Expec_Type) = E_Access_Subprogram_Type
+ and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
+ and then No (Parameter_Associations (Expr))
+ then
+ Error_Msg_N
+ ("found function name, possibly missing Access attribute!",
+ Expr);
-- catch common error: a prefix or infix operator which is not
-- directly visible because the type isn't.
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.18
diff -u -p -r1.18 snames.ads
--- snames.ads 9 Feb 2004 14:56:04 -0000 1.18
+++ snames.ads 12 Feb 2004 13:26:33 -0000
@@ -751,7 +751,7 @@ package Snames is
-- are added, the first character must be distinct.
First_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 440;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 440;
Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
-- Names of recognized checks for pragma Suppress
Index: usage.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/usage.adb,v
retrieving revision 1.14
diff -u -p -r1.14 usage.adb
--- usage.adb 9 Feb 2004 14:56:05 -0000 1.14
+++ usage.adb 12 Feb 2004 13:26:33 -0000
@@ -134,9 +134,6 @@ begin
Write_Switch_Char ("c");
Write_Line ("Check syntax and semantics only (no code generation)");
- Write_Switch_Char ("C");
- Write_Line ("Compress names in external names and debug info tables");
-
-- Line for -gnatd switch
Write_Switch_Char ("d?");
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-21 1:21 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-21 1:21 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux and alpha-tru64
--
2004-02-20 Robert Dewar <dewar@gnat.com>
* bld.adb, exp_util.adb, gprcmd.adb: Minor reformatting
2004-02-20 Ed Schonberg <schonberg@gnat.com>
* freeze.adb (Freeze_Record_Type): Generalize mechanism that generates
itype references for the constrained designated type of a component
whose base type is already frozen.
2004-02-20 Arnaud Charlet <charlet@act-europe.fr>
* init.c (__gnat_error_handler [tru64]): Rewrite previous change to
avoid GCC warnings.
2004-02-20 Sergey Rybin <rybin@act-europe.fr>
* sem_ch12.adb (Analyze_Formal_Package): Create a new defining
identifier for a phantom package that rewrites the formal package
declaration with a box. The Add semantic decorations for the defining
identifier from the original node (that represents the formal package).
--
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.9
diff -u -p -r1.9 bld.adb
--- bld.adb 18 Feb 2004 11:52:54 -0000 1.9
+++ bld.adb 20 Feb 2004 10:28:30 -0000
@@ -1972,16 +1972,16 @@ package body Bld is
elsif Pkg = Snames.Name_Linker then
if Item_Name = Snames.Name_Linker_Options then
- -- Only add linker options if this is not the root
- -- project.
+
+ -- Only add linker options if this is not the
+ -- root project.
Put ("ifeq ($(");
Put (Project_Name);
Put (".root),False)");
New_Line;
- -- Add the linker options to FLDFLAGS, in reverse
- -- order.
+ -- Add linker options to FLDFLAGS in reverse order
Put (" FLDFLAGS:=$(shell gprcmd linkopts $(");
Put (Project_Name);
@@ -1994,10 +1994,10 @@ package body Bld is
Put ("endif");
New_Line;
- else
- -- Other attribute are of no interest; suppress
- -- their declarations.
+ -- Other attributes are of no interest. Suppress
+ -- their declarations.
+ else
Put_Declaration := False;
end if;
end if;
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.21
diff -u -p -r1.21 exp_util.adb
--- exp_util.adb 18 Feb 2004 11:52:55 -0000 1.21
+++ exp_util.adb 20 Feb 2004 10:28:31 -0000
@@ -3353,8 +3353,7 @@ package body Exp_Util is
when N_Character_Literal |
N_Integer_Literal |
N_Real_Literal |
- N_String_Literal
- =>
+ N_String_Literal =>
return True;
-- We consider that anything else has side effects. This is a bit
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.12
diff -u -p -r1.12 freeze.adb
--- freeze.adb 2 Feb 2004 12:31:51 -0000 1.12
+++ freeze.adb 20 Feb 2004 10:28:31 -0000
@@ -1473,6 +1473,41 @@ package body Freeze is
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas).
+ procedure Check_Itype (Desig : Entity_Id);
+ -- If the component subtype is an access to a constrained subtype
+ -- of an already frozen type, make the subtype frozen as well. It
+ -- might otherwise be frozen in the wrong scope, and a freeze node
+ -- on subtype has no effect.
+
+ procedure Check_Itype (Desig : Entity_Id) is
+ begin
+ if not Is_Frozen (Desig)
+ and then Is_Frozen (Base_Type (Desig))
+ then
+ Set_Is_Frozen (Desig);
+
+ -- In addition, add an Itype_Reference to ensure that the
+ -- access subtype is elaborated early enough. This cannot
+ -- be done if the subtype may depend on discriminants.
+
+ if Ekind (Comp) = E_Component
+ and then Is_Itype (Etype (Comp))
+ and then not Has_Discriminants (Rec)
+ then
+ IR := Make_Itype_Reference (Sloc (Comp));
+ Set_Itype (IR, Desig);
+
+ if No (Result) then
+ Result := New_List (IR);
+ else
+ Append (IR, Result);
+ end if;
+ end if;
+ end if;
+ end Check_Itype;
+
+ -- Start of processing for Freeze_Record_Type
+
begin
-- If this is a subtype of a controlled type, declared without
-- a constraint, the _controller may not appear in the component
@@ -1548,40 +1583,19 @@ package body Freeze is
Loc, Result);
end if;
+ elsif Is_Itype (Designated_Type (Etype (Comp))) then
+ Check_Itype (Designated_Type (Etype (Comp)));
+
else
Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result);
end if;
end;
- -- If this is a constrained subtype of an already frozen type,
- -- make the subtype frozen as well. It might otherwise be frozen
- -- in the wrong scope, and a freeze node on subtype has no effect.
-
elsif Is_Access_Type (Etype (Comp))
- and then not Is_Frozen (Designated_Type (Etype (Comp)))
and then Is_Itype (Designated_Type (Etype (Comp)))
- and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp))))
then
- Set_Is_Frozen (Designated_Type (Etype (Comp)));
-
- -- In addition, add an Itype_Reference to ensure that the
- -- access subtype is elaborated early enough. This cannot
- -- be done if the subtype may depend on discriminants.
-
- if Ekind (Comp) = E_Component
- and then Is_Itype (Etype (Comp))
- and then not Has_Discriminants (Rec)
- then
- IR := Make_Itype_Reference (Sloc (Comp));
- Set_Itype (IR, Designated_Type (Etype (Comp)));
-
- if No (Result) then
- Result := New_List (IR);
- else
- Append (IR, Result);
- end if;
- end if;
+ Check_Itype (Designated_Type (Etype (Comp)));
elsif Is_Array_Type (Etype (Comp))
and then Is_Access_Type (Component_Type (Etype (Comp)))
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.9
diff -u -p -r1.9 gprcmd.adb
--- gprcmd.adb 18 Feb 2004 11:52:55 -0000 1.9
+++ gprcmd.adb 20 Feb 2004 10:28:31 -0000
@@ -454,19 +454,20 @@ begin
Dir : constant String := Argument (2);
begin
- for J in 3 .. Argument_Count loop
-
- -- Remove quotes that may have been added around each argument
+ -- Loop to remove quotes that may have been added around arguments
+ for J in 3 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
First : Natural := Arg'First;
Last : Natural := Arg'Last;
+
begin
if Arg (First) = '"' and then Arg (Last) = '"' then
First := First + 1;
Last := Last - 1;
end if;
+
if Is_Absolute_Path (Arg (First .. Last)) then
Extend (Format_Pathname (Arg (First .. Last), UNIX));
else
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.24
diff -u -p -r1.24 init.c
--- init.c 12 Feb 2004 13:28:10 -0000 1.24
+++ init.c 20 Feb 2004 10:28:31 -0000
@@ -388,6 +388,7 @@ __gnat_error_handler (int sig, siginfo_t
static int recurse = 0;
struct sigcontext *mstate;
const char *msg;
+ jmp_buf handler_jmpbuf;
/* If this was an explicit signal from a "kill", just resignal it. */
if (SI_FROMUSER (sip))
@@ -397,6 +398,43 @@ __gnat_error_handler (int sig, siginfo_t
}
/* Otherwise, treat it as something we handle. */
+
+ /* We are now going to raise the exception corresponding to the signal we
+ caught, which may eventually end up resuming the application code if the
+ exception is handled.
+
+ When the exception is handled, merely arranging for the *exception*
+ handler's context (stack pointer, program counter, other registers, ...)
+ to be installed is *not* enough to let the kernel think we've left the
+ *signal* handler. This has annoying implications if an alternate stack
+ has been setup for this *signal* handler, because the kernel thinks we
+ are still running on that alternate stack even after the jump, which
+ causes trouble at least as soon as another signal is raised.
+
+ We deal with this by forcing a "local" longjmp within the signal handler
+ below, forcing the "on alternate stack" indication to be reset (kernel
+ wise) on the way. If no alternate stack has been setup, this should be a
+ neutral operation. Otherwise, we will be in a delicate situation for a
+ short while because we are going to run the exception propagation code
+ within the alternate stack area (that is, with the stack pointer inside
+ the alternate stack bounds), but with the corresponding flag off from the
+ kernel's standpoint. We expect this to be ok as long as the propagation
+ code does not trigger a signal itself, which is expected.
+
+ ??? A better approach would be to at least delay this operation until the
+ last second, that is, until just before we jump to the exception handler,
+ if any. */
+
+ if (setjmp (handler_jmpbuf) == 0)
+ {
+#define JB_ONSIGSTK 0
+
+ /* Arrange for the "on alternate stack" flag to be reset. See the
+ comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
+ handler_jmpbuf [JB_ONSIGSTK] = 0;
+ longjmp (handler_jmpbuf, 1);
+ }
+
switch (sig)
{
case SIGSEGV:
@@ -448,48 +486,7 @@ __gnat_error_handler (int sig, siginfo_t
if (mstate != 0)
*mstate = *context;
- /* We are now going to raise the exception corresponding to the signal we
- caught, which may eventually end up resuming the application code if the
- exception is handled.
-
- When the exception is handled, merely arranging for the *exception*
- handler's context (stack pointer, program counter, other registers, ...)
- to be installed is *not* enough to let the kernel think we've left the
- *signal* handler. This has annoying implications if an alternate stack
- has been setup for this *signal* handler, because the kernel thinks we
- are still running on that alternate stack even after the jump, which
- causes trouble at least as soon as another signal is raised.
-
- We deal with this by forcing a "local" longjmp within the signal handler
- below, forcing the "on alternate stack" indication to be reset (kernel
- wise) on the way. If no alternate stack has been setup, this should be a
- neutral operation. Otherwise, we will be in a delicate situation for a
- short while because we are going to run the exception propagation code
- within the alternate stack area (that is, with the stack pointer inside
- the alternate stack bounds), but with the corresponding flag off from the
- kernel's standpoint. We expect this to be ok as long as the propagation
- code does not trigger a signal itself, which is expected.
-
- ??? A better approach would be to at least delay this operation until the
- last second, that is, until just before we jump to the exception handler,
- if any. */
- {
- jmp_buf handler_jmpbuf;
-
- if (setjmp (handler_jmpbuf) != 0)
- Raise_From_Signal_Handler (exception, (char *) msg);
- else
- {
- /* Arrange for the "on alternate stack" flag to be reset. See the
- comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
- struct sigcontext * handler_context
- = (struct sigcontext *) & handler_jmpbuf;
-
- handler_context->sc_onstack = 0;
-
- longjmp (handler_jmpbuf, 1);
- }
- }
+ Raise_From_Signal_Handler (exception, (char *) msg);
}
void
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.32
diff -u -p -r1.32 sem_ch12.adb
--- sem_ch12.adb 2 Feb 2004 12:31:56 -0000 1.32
+++ sem_ch12.adb 20 Feb 2004 10:28:33 -0000
@@ -1578,7 +1578,8 @@ package body Sem_Ch12 is
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Formal : constant Entity_Id := Defining_Identifier (N);
+ Pack_Id : constant Entity_Id := Defining_Identifier (N);
+ Formal : Entity_Id;
Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
@@ -1653,8 +1654,6 @@ package body Sem_Ch12 is
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
- Set_Instance_Env (Gen_Unit, Formal);
-
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
if In_Extended_Main_Source_Unit (N) then
@@ -1662,11 +1661,13 @@ package body Sem_Ch12 is
Generate_Reference (Gen_Unit, N);
end if;
+ Formal := New_Copy (Pack_Id);
New_N :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
- Set_Defining_Unit_Name (Specification (New_N), Formal);
Rewrite (N, New_N);
+ Set_Defining_Unit_Name (Specification (New_N), Formal);
+ Set_Instance_Env (Gen_Unit, Formal);
Enter_Name (Formal);
Set_Ekind (Formal, E_Generic_Package);
@@ -1728,6 +1729,11 @@ package body Sem_Ch12 is
Set_Ekind (Formal, E_Package);
Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Has_Completion (Formal, True);
+
+ Set_Ekind (Pack_Id, E_Package);
+ Set_Etype (Pack_Id, Standard_Void_Type);
+ Set_Scope (Pack_Id, Scope (Formal));
+ Set_Has_Completion (Pack_Id, True);
end if;
end Analyze_Formal_Package;
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 11:56 ` Arnaud Charlet
2004-02-18 18:36 ` Zack Weinberg
@ 2004-02-19 14:57 ` Rainer Orth
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Arnaud Charlet
2 siblings, 1 reply; 178+ messages in thread
From: Rainer Orth @ 2004-02-19 14:57 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches, Olivier Hainque
Arnaud Charlet writes:
> > It cannot have been tested at all ;-(
>
> It has been tested with mainline on x86-linux, and with gcc 3.2.3 on
> alpha-tru64. Enabling addition warnings or changing warnings as error is
> certainly 'expected' to generate lots of additional problems on various
> platforms.
Exactly, so testing a patch that only affects alpha-dec-osf* on
i386-pc-linux-gnu cannot be enough to check it into mainline.
> Addressing the warnings is easy in this case, I'll prepare a patch.
Fine, thanks. For the moment, I can live with the -Wno-error workaround in
t-osf4.
> > only to fail later on with another error:
> >
> > /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
> > /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
>
> OK, I can't resist:
>
> It cannot have been tested at all ;-)
I couldn't have put this better :-)
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 19:41 ` Zack Weinberg
2004-02-18 19:42 ` Rainer Orth
@ 2004-02-19 14:44 ` Rainer Orth
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Zack Weinberg
2 siblings, 1 reply; 178+ messages in thread
From: Rainer Orth @ 2004-02-19 14:44 UTC (permalink / raw)
To: Zack Weinberg; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Zack Weinberg writes:
> Okay, so sdbout_symbol needs the same treatment that dbxout_symbol
> got. Sorry about this. Here is a revised patch.
With that patch (modulo the typo already mentioned), the alpha-dec-osf4.0f
bootstrap completed successfully without regressions compared to 20040210,
except for those three which occur on other platforms as well:
+FAIL: 23_containers/multiset/insert/1.cc execution test
+FAIL: 23_containers/multiset/invalidation/2.cc execution test
+FAIL: 23_containers/set/invalidation/2.cc execution test
Thanks.
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 19:41 ` Zack Weinberg
@ 2004-02-18 19:42 ` Rainer Orth
2004-02-21 13:45 ` Rainer Orth
2004-02-19 14:44 ` Rainer Orth
2004-02-21 13:45 ` Zack Weinberg
2 siblings, 1 reply; 178+ messages in thread
From: Rainer Orth @ 2004-02-18 19:42 UTC (permalink / raw)
To: Zack Weinberg; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Zack Weinberg writes:
> Okay, so sdbout_symbol needs the same treatment that dbxout_symbol
> got. Sorry about this. Here is a revised patch.
Except for the obvious typo
> +/* The C front end may call sdbout_symbol before sdbout_init runs.
> + We save all such decls in this list and output them when we get
> + to sdbout_init. */
> +
> +static GTY(()) tree preinit_symbols;
> +statid GTY(()) bool sdbout_initialized;
^c
this worked for me, i.e. I rebuilt cc1plus and successfully run the
testcase that crashed before. I'll run a full bootstrap overnight.
Thanks for the quick help.
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 18:37 ` Rainer Orth
@ 2004-02-18 19:41 ` Zack Weinberg
2004-02-18 19:42 ` Rainer Orth
` (2 more replies)
2004-02-21 13:45 ` Rainer Orth
1 sibling, 3 replies; 178+ messages in thread
From: Zack Weinberg @ 2004-02-18 19:41 UTC (permalink / raw)
To: Rainer Orth; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Rainer Orth <ro@TechFak.Uni-Bielefeld.DE> writes:
> Zack Weinberg writes:
>
>> Argh, this is yet another thing I fixed in the 3.4 iteration (not yet
>> applied) of that patch but that got lost somehow when I redid it for
>> mainline.
>>
>> Please try the appended:
>
> That's the patch that I came up with myself and that got me through
> bootstrap.
>
> Unfortunately, there are lots of testsuite regressions: cf. current
> alpha-dec-osf4.0f testresults
...
> E.g.
>
> FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
> Excess errors:
> In file included from /vol/gnu/src/gcc/gcc-dist/gcc/testsuite/g++.dg/debug/anonunion1.C:1:
> <internal>:0: internal compiler error: Segmentation fault
>
> This gets down to
>
> $ ../cc1plus anonunion1.ii -gcoff1
> In file included from anonunion1.ii:1:
> <internal>:0: internal compiler error: Segmentation fault
>
> Program received signal SIGSEGV, Segmentation fault.
> 0x000003ff800db020 in fprintf () from /usr/shlib/libc.so
...
> The crash happens because asm_out_file is NULL in varasm.c (text_section).
Okay, so sdbout_symbol needs the same treatment that dbxout_symbol
got. Sorry about this. Here is a revised patch.
zw
* sdbout.c (preinit_symbols, sdbout_initialized): New statics.
(sdbout_symbol): If called before sdbout_init, queue DECL for
later and return.
(sdbout_init): Set sdbout_initialized true, process decls
queued earlier by sdbout_symbol.
(sdbout_finish): Use size_t for index variable.
===================================================================
Index: sdbout.c
--- sdbout.c 16 Feb 2004 18:55:01 -0000 1.87
+++ sdbout.c 18 Feb 2004 18:23:13 -0000
@@ -64,6 +64,13 @@ static GTY(()) int unnamed_struct_number
static GTY(()) varray_type deferred_global_decls;
+/* The C front end may call sdbout_symbol before sdbout_init runs.
+ We save all such decls in this list and output them when we get
+ to sdbout_init. */
+
+static GTY(()) tree preinit_symbols;
+statid GTY(()) bool sdbout_initialized;
+
#ifdef SDB_DEBUGGING_INFO
#include "rtl.h"
@@ -699,6 +706,14 @@ sdbout_symbol (tree decl, int local)
int regno = -1;
const char *name;
+ /* If we are called before sdbout_init is run, just save the symbol
+ for later. */
+ if (!sdbout_initialized)
+ {
+ preinit_symbols = tree_cons (0, decl, preinit_symbols);
+ return;
+ }
+
sdbout_one_type (type);
switch (TREE_CODE (decl))
@@ -1460,7 +1475,7 @@ sdbout_global_decl (tree decl)
static void
sdbout_finish (const char *main_filename ATTRIBUTE_UNUSED)
{
- int i;
+ size_t i;
for (i = 0; i < VARRAY_ACTIVE_SIZE (deferred_global_decls); i++)
sdbout_symbol (VARRAY_TREE (deferred_global_decls, i), 0);
@@ -1663,6 +1678,8 @@ sdbout_end_source_file (unsigned int lin
static void
sdbout_init (const char *input_file_name ATTRIBUTE_UNUSED)
{
+ tree t;
+
#ifdef MIPS_DEBUGGING_INFO
current_file = xmalloc (sizeof *current_file);
current_file->next = NULL;
@@ -1670,6 +1687,14 @@ sdbout_init (const char *input_file_name
#endif
VARRAY_TREE_INIT (deferred_global_decls, 12, "deferred_global_decls");
+
+ /* Emit debug information which was queued by sdbout_symbol before
+ we got here. */
+ sdbout_initialized = true;
+
+ for (t = nreverse (preinit_symbols); t; t = TREE_CHAIN (t))
+ sdbout_symbol (TREE_VALUE (t), 0);
+ preinit_symbols = 0;
}
#else /* SDB_DEBUGGING_INFO */
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 18:36 ` Zack Weinberg
@ 2004-02-18 18:37 ` Rainer Orth
2004-02-18 19:41 ` Zack Weinberg
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Zack Weinberg
1 sibling, 2 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-18 18:37 UTC (permalink / raw)
To: Zack Weinberg; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
Zack Weinberg writes:
> Argh, this is yet another thing I fixed in the 3.4 iteration (not yet
> applied) of that patch but that got lost somehow when I redid it for
> mainline.
>
> Please try the appended:
That's the patch that I came up with myself and that got me through
bootstrap.
Unfortunately, there are lots of testsuite regressions: cf. current
alpha-dec-osf4.0f testresults
http://gcc.gnu.org/ml/gcc-testresults/2004-02/msg00890.html
with
http://gcc.gnu.org/ml/gcc-testresults/2004-02/msg00589.html
--- ../../gcc-3.5.0-20040210/4.0f-gcc/mail-report.log Wed Feb 11 12:27:40 2004
+++ mail-report.log Wed Feb 18 12:44:52 2004
@@ -1,5 +1,5 @@
cat <<'EOF' |
-LAST_UPDATED: Tue Feb 10 18:05:06 UTC 2004
+LAST_UPDATED: Tue Feb 17 16:15:02 UTC 2004
Native configuration is alpha-dec-osf4.0f
@@ -62,6 +62,7 @@
FAIL: Thread_Alive execution - gij test
FAIL: Thread_Interrupt execution - gij test
FAIL: Thread_Interrupt execution - gij test
+FAIL: Thread_Interrupt -O3 output - bytecode->native test
FAIL: Thread_Wait_2 execution - gij test
FAIL: Thread_Wait_2 execution - gij test
FAIL: Thread_Wait_Interrupt execution - gij test
@@ -94,8 +95,8 @@
=== libjava Summary ===
-# of expected passes 3147
-# of unexpected failures 69
+# of expected passes 3146
+# of unexpected failures 70
# of expected failures 14
# of untested testcases 95
=== libstdc++ tests ===
@@ -120,12 +121,15 @@
WARNING: 22_locale/collate/transform/wchar_t/wrapped_env.cc compilation failed to produce executable
FAIL: 22_locale/collate/transform/wchar_t/wrapped_locale.cc (test for excess errors)
WARNING: 22_locale/collate/transform/wchar_t/wrapped_locale.cc compilation failed to produce executable
+FAIL: 23_containers/multiset/insert/1.cc execution test
+FAIL: 23_containers/multiset/invalidation/2.cc execution test
+FAIL: 23_containers/set/invalidation/2.cc execution test
FAIL: 27_io/basic_istream/extractors_arithmetic/char/12.cc execution test
=== libstdc++ Summary ===
-# of expected passes 2540
-# of unexpected failures 10
+# of expected passes 2541
+# of unexpected failures 13
# of expected failures 2
=== acats tests ===
@@ -137,6 +141,159 @@
Running target unix
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/const1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug1.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug2.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug3.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug4.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug5.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug6.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug7.C (test for errors, line 10)
+FAIL: g++.dg/debug/debug7.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/debug8.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/minimal1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/namespace1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/template1.C (test for excess errors)
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/trivial.C (test for excess errors)
+WARNING: g++.dg/debug/trivial.C compilation failed to produce executable
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
+FAIL: g++.dg/debug/typedef1.C (test for excess errors)
FAIL: g++.dg/parse/attr-ctor1.C (test for excess errors)
FAIL: g++.dg/parse/stack1.C (test for excess errors)
FAIL: g++.dg/pch/system-1.C -g assembly comparison
@@ -147,11 +304,11 @@
=== g++ Summary ===
-# of expected passes 9439
-# of unexpected failures 4
-# of expected failures 68
+# of expected passes 9356
+# of unexpected failures 148
+# of expected failures 80
# of unsupported tests 70
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/testsuite/../g++ version 3.5.0 20040210 (experimental)
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/testsuite/../g++ version 3.5.0 20040217 (experimental)
=== g77 tests ===
@@ -162,7 +319,7 @@
# of expected passes 1788
# of unsupported tests 6
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/testsuite/../g77 version 3.5.0 20040210 (experimental)
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/testsuite/../g77 version 3.5.0 20040217 (experimental)
=== gcc tests ===
@@ -185,12 +342,203 @@
FAIL: gcc.c-torture/execute/20040208-2.c execution, -O3 -fomit-frame-pointer
FAIL: gcc.c-torture/execute/20040208-2.c execution, -O3 -g
FAIL: gcc.c-torture/execute/20040208-2.c execution, -Os
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20000503-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20010207-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20011223-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020104-2.c (test for excess errors)
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020220-1.c (test for excess errors)
+WARNING: gcc.dg/debug/20020220-1.c compilation failed to produce executable
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020224-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20020327-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20030605-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/20031231-1.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-1.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+FAIL: gcc.dg/debug/debug-1.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-1.c: error executing dg-final: couldn't open "debug-1.s": no such file or directory
+FAIL: gcc.dg/debug/debug-2.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+FAIL: gcc.dg/debug/debug-2.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-2.c: error executing dg-final: couldn't open "debug-2.s": no such file or directory
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-3.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-4.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-5.c (test for excess errors)
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/debug-6.c (test for excess errors)
+ERROR: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+UNRESOLVED: gcc.dg/debug/debug-6.c: error executing dg-final: couldn't open "debug-6.s": no such file or directory
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-1.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-2.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/dwarf2-3.c (test for excess errors)
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
+FAIL: gcc.dg/debug/trivial.c (test for excess errors)
+WARNING: gcc.dg/debug/trivial.c compilation failed to produce executable
FAIL: gcc.dg/20040123-1.c scan-assembler abort
-FAIL: gcc.dg/array-quals-1.c scan-assembler-not \\.data(?!\\.rel\\.ro)
+FAIL: gcc.dg/array-quals-1.c scan-assembler-not \\\\.data(?!\\\\.rel\\\\.ro)
FAIL: gcc.dg/builtins-18.c (test for excess errors)
FAIL: gcc.dg/builtins-20.c (test for excess errors)
FAIL: gcc.dg/fwritable-strings-1.c (test for errors, line )
-FAIL: gcc.dg/pr14092-1.c (test for excess errors)
UNRESOLVED: gcc.dg/visibility-1.c
UNRESOLVED: gcc.dg/visibility-2.c
UNRESOLVED: gcc.dg/visibility-3.c
@@ -205,13 +553,13 @@
=== gcc Summary ===
-# of expected passes 24198
-# of unexpected failures 26
+# of expected passes 24043
+# of unexpected failures 179
# of expected failures 71
-# of unresolved testcases 8
+# of unresolved testcases 18
# of untested testcases 7
-# of unsupported tests 314
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/xgcc version 3.5.0 20040210 (experimental)
+# of unsupported tests 315
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/xgcc version 3.5.0 20040217 (experimental)
=== objc tests ===
@@ -222,12 +570,12 @@
# of expected passes 1341
# of unsupported tests 8
-/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040210/4.0f-gcc/gcc/xgcc version 3.5.0 20040210 (experimental)
+/amnt/figaro/volumes/obj-gcc/gcc/obj.alpha/gcc-3.5.0-20040217/4.0f-gcc/gcc/xgcc version 3.5.0 20040217 (experimental)
-Compiler version: 3.5.0 20040210 (experimental)
+Compiler version: 3.5.0 20040217 (experimental)
Platform: alpha-dec-osf4.0f
-configure flags: --prefix=/vol/gcc --with-local-prefix=/vol/gcc --disable-nls --host alpha-dec-osf4.0f --build alpha-dec-osf4.0f --target alpha-dec-osf4.0f
+configure flags: --prefix=/vol/gcc --with-local-prefix=/vol/gcc --disable-nls --enable-languages=ada,c++,f77,java,objc --host alpha-dec-osf4.0f --build alpha-dec-osf4.0f --target alpha-dec-osf4.0f
EOF
-Mail -s "Results for 3.5.0 20040210 (experimental) testsuite on alpha-dec-osf4.0f" gcc-testresults@gcc.gnu.org &&
+Mail -s "Results for 3.5.0 20040217 (experimental) testsuite on alpha-dec-osf4.0f" gcc-testresults@gcc.gnu.org &&
true
E.g.
FAIL: g++.dg/debug/anonunion1.C (test for excess errors)
Excess errors:
In file included from /vol/gnu/src/gcc/gcc-dist/gcc/testsuite/g++.dg/debug/anonunion1.C:1:
<internal>:0: internal compiler error: Segmentation fault
This gets down to
$ ../cc1plus anonunion1.ii -gcoff1
In file included from anonunion1.ii:1:
<internal>:0: internal compiler error: Segmentation fault
Program received signal SIGSEGV, Segmentation fault.
0x000003ff800db020 in fprintf () from /usr/shlib/libc.so
(gdb) where
#0 0x000003ff800db020 in fprintf () from /usr/shlib/libc.so
During symbol reading, bad structure-type format.
#1 0x00000001202e6e08 in text_section () at /vol/gnu/src/gcc/gcc-dist/gcc/varasm.c:201
During symbol reading, bad structure-type format.
#2 0x00000001202e1a60 in sdbout_one_type (type=0x22b60) at /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1046
#3 0x00000001202e3074 in sdbout_symbol (decl=0x23a00, local=0) at /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:702
During symbol reading, bad structure-type format.
#4 0x0000000120079c34 in record_builtin_type (rid_index=RID_STATIC, name=0x140053020 "%s\n", type=0x0) at /vol/gnu/src/gcc/gcc-dist/gcc/cp/decl.c:2809
During symbol reading, bad structure-type format.
#5 0x00000001201dd1c0 in c_common_nodes_and_builtins () at /vol/gnu/src/gcc/gcc-dist/gcc/c-common.c:3085
#6 0x000000012007ae00 in cxx_init_decl_processing () at /vol/gnu/src/gcc/gcc-dist/gcc/cp/decl.c:2976
During symbol reading, bad structure-type format.
#7 0x000000012012ebc0 in cxx_init () at /vol/gnu/src/gcc/gcc-dist/gcc/cp/lex.c:410
During symbol reading, bad structure-type format.
#8 0x0000000120245914 in toplev_main (argc=0, argv=0x22b60) at /vol/gnu/src/gcc/gcc-dist/gcc/toplev.c:4510
#9 0x0000000120212990 in main (argc=0, argv=0x140053020) at /vol/gnu/src/gcc/gcc-dist/gcc/main.c:35
The crash happens because asm_out_file is NULL in varasm.c (text_section).
Rainer
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-18 11:56 ` Arnaud Charlet
@ 2004-02-18 18:36 ` Zack Weinberg
2004-02-18 18:37 ` Rainer Orth
2004-02-21 13:45 ` Zack Weinberg
2004-02-19 14:57 ` Rainer Orth
2004-02-21 13:45 ` Arnaud Charlet
2 siblings, 2 replies; 178+ messages in thread
From: Zack Weinberg @ 2004-02-18 18:36 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: Rainer Orth, gcc-patches, Olivier Hainque
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
>> only to fail later on with another error:
>>
>> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
>> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
Argh, this is yet another thing I fixed in the 3.4 iteration (not yet
applied) of that patch but that got lost somehow when I redid it for
mainline.
Please try the appended:
zw
===================================================================
Index: sdbout.c
--- sdbout.c 16 Feb 2004 18:55:01 -0000 1.87
+++ sdbout.c 18 Feb 2004 17:43:54 -0000
@@ -1460,7 +1460,7 @@ sdbout_global_decl (tree decl)
static void
sdbout_finish (const char *main_filename ATTRIBUTE_UNUSED)
{
- int i;
+ size_t i;
for (i = 0; i < VARRAY_ACTIVE_SIZE (deferred_global_decls); i++)
sdbout_symbol (VARRAY_TREE (deferred_global_decls, i), 0);
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-18 12:47 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-18 12:47 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-18 Emmanuel Briot <briot@act-europe.fr>
* ali.ads, ali.adb (First_Sdep_Entry): No longer a constant, so that
Scan_ALI can be used for multiple ALI files without reinitializing
between calls.
2004-02-18 Robert Dewar <dewar@gnat.com>
* debug.adb: Minor reformatting.
2004-02-18 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, case object): Set DECL_POINTER_ALIAS_SET
to zero if there is an address clause.
2004-02-18 Thomas Quinot <quinot@act-europe.fr>
* exp_util.adb (Side_Effect_Free): Any literal is side effects free.
2004-02-18 Gary Dismukes <dismukes@gnat.com>
* layout.adb (Layout_Component_List): Revise generation of call to
discriminant-checking function to pass selections of all of the type's
discriminants rather than just the variant-controlling discriminant.
2004-02-18 Olivier Hainque <hainque@act-europe.fr>
* 5gmastop.adb (Pop_Frame): Do not call exc_unwind, which is bound to
fail in the current setup and triggers spurious system error messages.
Pretend it occurred and failed instead.
2004-02-18 Vincent Celier <celier@gnat.com>
* bld.adb: Mark FLDFLAGS as saved
(Process_Declarative_Items): Add Linker'Linker_Options to FLDFLAGS when
it is not the root project. Put each directory to be
extended between double quotes to prevent it to be expanded on Windows.
(Recursive_Process): Reset CFLAGS/CXXFLAGS to nothing before processing
the project file. Set them back to their initial values if they have not
been set in the project file.
* gprcmd.adb: (Gprdebug, Debug): New global variables
(Display_Command): New procedure
(Usage): Document new command "linkopts"
Call Display_Command when env var GPRDEBUG has the value "TRUE"
Implement new command "linkopts"
Remove quotes that may be around arguments for "extend"
Always call Normalize_Pathname with arguments formatted for the platform
* Makefile.generic: Link C/C++ mains with $(FLDFLAGS)
Change @echo to @$(display) in target clean to be able to clean silently
* Makefile.prolog: Save FLDFLAGS and give it an initial empty value
* prj-part.adb (Project_Path_Name_Of): Do not put final result in
canonical case.
* prj-part.adb (Parse_Single_Project): Always call with From_Extended
= Extending_All when current project is an extending all project.
* vms_conv.adb (Output_File_Expected): New Boolean global variable,
set to True only for LINK command, after Unix switch -o.
(Process_Arguments): Set Output_File_Expected to True for LINK command
after Unix switch -o. When Output_File_Expected is True, never add an
extension to a file name.
* 5vml-tgt.adb (Build_Dynamic_Library): Do not append "/OPTIONS" to the
option file name, only to the --for-linker= switch.
(Option_File_Name): If option file name do not end with ".opt", append
"/OPTIONS".
2004-02-18 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 5gmastop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gmastop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5gmastop.adb
--- 5gmastop.adb 5 Jan 2004 15:20:42 -0000 1.8
+++ 5gmastop.adb 18 Feb 2004 11:47:54 -0000
@@ -7,7 +7,7 @@
-- B o d y --
-- (Version for IRIX/MIPS) --
-- --
--- 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- --
@@ -301,7 +301,25 @@ package body System.Machine_State_Operat
-- Lock_Task is used in many other places.
Lock_Task.all;
- Exc_Unwind (Scp);
+
+ -- ??? Calling exc_unwind in the current setup does not work and
+ -- triggers the emission of system warning messages. Why it does
+ -- not work remains to be investigated. Part of the problem is
+ -- probably a section naming issue (e.g. .eh_frame/.debug_frame).
+
+ -- Instead of letting the call take place for nothing and emit
+ -- messages we don't expect, we just arrange things to pretend it
+ -- occurred and failed.
+
+ -- ??? Until this is fixed, we shall document that the backtrace
+ -- computation facility does not work.
+
+ if False then
+ Exc_Unwind (Scp);
+ else
+ Scp.SC_PC := 0;
+ end if;
+
Unlock_Task.all;
if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.4
diff -u -p -r1.4 5vml-tgt.adb
--- 5vml-tgt.adb 23 Jan 2004 10:30:03 -0000 1.4
+++ 5vml-tgt.adb 18 Feb 2004 11:47:54 -0000
@@ -209,7 +209,9 @@ package body MLib.Tgt is
if Symbol_Data.Symbol_File = No_Name then
return "symvec.opt";
else
- return Get_Name_String (Symbol_Data.Symbol_File);
+ Get_Name_String (Symbol_Data.Symbol_File);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ return Name_Buffer (1 .. Name_Len);
end if;
end Option_File_Name;
@@ -244,8 +246,7 @@ package body MLib.Tgt is
Opt_File_Name : constant String := Option_File_Name;
Version : constant String := Version_String;
- For_Linker_Opt : constant String_Access :=
- new String'("--for-linker=" & Opt_File_Name);
+ For_Linker_Opt : String_Access;
-- Start of processing for Build_Dynamic_Library
@@ -256,6 +257,19 @@ package body MLib.Tgt is
Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
else
Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
+ end if;
+
+ -- If option file name does not ends with ".opt", append "/OPTIONS"
+ -- to its specification for the VMS linker.
+
+ if Opt_File_Name'Length > 4
+ and then
+ Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
+ then
+ For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
+ else
+ For_Linker_Opt :=
+ new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
end if;
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.16
diff -u -p -r1.16 ali.adb
--- ali.adb 12 Feb 2004 13:28:08 -0000 1.16
+++ ali.adb 18 Feb 2004 11:47:55 -0000
@@ -601,6 +601,8 @@ package body ALI is
-- Start of processing for Scan_ALI
begin
+ First_Sdep_Entry := Sdep.Last + 1;
+
-- Acquire lines to be ignored
if Read_Xref then
Index: ali.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.ads,v
retrieving revision 1.14
diff -u -p -r1.14 ali.ads
--- ali.ads 9 Feb 2004 14:56:03 -0000 1.14
+++ ali.ads 18 Feb 2004 11:47:56 -0000
@@ -593,8 +593,10 @@ package ALI is
No_Sdep_Id : constant Sdep_Id := Sdep_Id'First;
-- Special value indicating no Sdep table entry
- First_Sdep_Entry : constant Sdep_Id := No_Sdep_Id + 1;
- -- Id of first actual entry in table
+ First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1;
+ -- Id of first Sdep entry for current ali file. This is initialized to
+ -- the first Sdep entry in the table, and then incremented appropriately
+ -- as successive ALI files are scanned.
type Sdep_Record is record
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.8
diff -u -p -r1.8 bld.adb
--- bld.adb 12 Feb 2004 13:28:09 -0000 1.8
+++ bld.adb 18 Feb 2004 11:47:56 -0000
@@ -222,6 +222,7 @@ package body Bld is
Deps_Projects_String : aliased String := "DEPS_PROJECT";
Exec_String : aliased String := "EXEC";
Exec_Dir_String : aliased String := "EXEC_DIR";
+ Fldflags_String : aliased String := "FLDFLAGS";
Gnatmake_String : aliased String := "GNATMAKE";
Languages_String : aliased String := "LANGUAGES";
Ld_Flags_String : aliased String := "LD_FLAGS";
@@ -251,6 +252,7 @@ package body Bld is
Deps_Projects_String'Access,
Exec_String 'Access,
Exec_Dir_String 'Access,
+ Fldflags_String 'Access,
Gnatmake_String 'Access,
Languages_String 'Access,
Ld_Flags_String 'Access,
@@ -1426,7 +1428,8 @@ package body Bld is
(Pkg = No_Name
or else Pkg = Snames.Name_Naming
or else Pkg = Snames.Name_Compiler
- or else Pkg = Name_Ide);
+ or else Pkg = Name_Ide
+ or else Pkg = Snames.Name_Linker);
if Put_Declaration then
-- Some attributes are converted into reserved variables
@@ -1508,7 +1511,7 @@ package body Bld is
Put_Attribute (Project, Pkg, Item_Name, No_Name);
Put ("),$(shell gprcmd extend $(");
Put (Project_Name);
- Put_Line (".base_dir) '$(name)'))");
+ Put_Line (".base_dir) '""$(name)""'))");
elsif Item_Name = Snames.Name_Source_Files then
@@ -1959,6 +1962,38 @@ package body Bld is
end if;
end if;
end;
+
+ else
+ -- Other attribute are of no interest; suppress
+ -- their declarations.
+
+ Put_Declaration := False;
+ end if;
+
+ elsif Pkg = Snames.Name_Linker then
+ if Item_Name = Snames.Name_Linker_Options then
+ -- Only add linker options if this is not the root
+ -- project.
+
+ Put ("ifeq ($(");
+ Put (Project_Name);
+ Put (".root),False)");
+ New_Line;
+
+ -- Add the linker options to FLDFLAGS, in reverse
+ -- order.
+
+ Put (" FLDFLAGS:=$(shell gprcmd linkopts $(");
+ Put (Project_Name);
+ Put (".base_dir) $(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, No_Name);
+ Put (")) $(FLDFLAGS)");
+ New_Line;
+
+ Put ("endif");
+ New_Line;
+
else
-- Other attribute are of no interest; suppress
-- their declarations.
@@ -2686,6 +2721,15 @@ package body Bld is
-- Set defaults to some variables
+ -- CFLAGS and CXXFLAGS are set by default to nothing.
+ -- Their initial values have been saved, If they are not set
+ -- by this project file, then they will be reset to their
+ -- initial values. This is to avoid "inheritance" of these
+ -- flags from an imported project file.
+
+ Put_Line ("CFLAGS:=");
+ Put_Line ("CXXFLAGS:=");
+
IO.Mark (Src_Files_Init);
Put_Line ("src_files.specified:=FALSE");
@@ -3344,6 +3388,19 @@ package body Bld is
end if;
end;
+
+ -- If CFLAGS/CXXFLAGS have not been set, set them back to
+ -- their initial values.
+
+ Put_Line ("ifeq ($(CFLAGS),)");
+ Put_Line (" CFLAGS:=$(CFLAGS.saved)");
+ Put_Line ("endif");
+ New_Line;
+
+ Put_Line ("ifeq ($(CXXFLAGS),)");
+ Put_Line (" CXXFLAGS:=$(CXXFLAGS.saved)");
+ Put_Line ("endif");
+ New_Line;
-- If this is the main Makefile, include Makefile.Generic
Index: debug.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/debug.adb,v
retrieving revision 1.9
diff -u -p -r1.9 debug.adb
--- debug.adb 9 Feb 2004 14:56:03 -0000 1.9
+++ debug.adb 18 Feb 2004 11:47:57 -0000
@@ -470,7 +470,7 @@ package body Debug is
-- testing high integrity mode.
-- d.x No exception handlers in generated code. This causes exception
- -- handles to be eliminated from the generated code. They are still
+ -- handlers to be eliminated from the generated code. They are still
-- fully compiled and analyzed, they just get eliminated from the
-- code generation step.
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.28
diff -u -p -r1.28 decl.c
--- decl.c 12 Feb 2004 13:28:09 -0000 1.28
+++ decl.c 18 Feb 2004 11:47:58 -0000
@@ -1048,6 +1048,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
+ /* If we have an address clause and we've made this indirect, it's
+ not enough to merely mark the type as volatile since volatile
+ references only conflict with other volatile references while this
+ reference must conflict with all other references. So ensure that
+ the dereferenced value has alias set 0. */
+ if (Present (Address_Clause (gnat_entity)) && used_by_ref)
+ DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
+
if (definition && DECL_SIZE (gnu_decl) != 0
&& gnu_block_stack != 0
&& TREE_VALUE (gnu_block_stack) != 0
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.20
diff -u -p -r1.20 exp_util.adb
--- exp_util.adb 12 Feb 2004 13:28:10 -0000 1.20
+++ exp_util.adb 18 Feb 2004 11:47:58 -0000
@@ -3348,6 +3348,15 @@ package body Exp_Util is
when N_Unchecked_Expression =>
return Side_Effect_Free (Expression (N));
+ -- A literal is side effect free
+
+ when N_Character_Literal |
+ N_Integer_Literal |
+ N_Real_Literal |
+ N_String_Literal
+ =>
+ return True;
+
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.8
diff -u -p -r1.8 gprcmd.adb
--- gprcmd.adb 12 Feb 2004 13:28:10 -0000 1.8
+++ gprcmd.adb 18 Feb 2004 11:47:58 -0000
@@ -58,6 +58,10 @@ procedure Gprcmd is
-- ??? comments are thin throughout this unit
+ Gprdebug : constant String := To_Lower (Getenv ("GPRDEBUG").all);
+ Debug : constant Boolean := Gprdebug = "true";
+ -- When Debug is True, gprcmd displays its arguments to Standard_Error.
+ -- This is to help to debug.
procedure Cat (File : String);
-- Print the contents of file on standard output.
@@ -82,6 +86,9 @@ procedure Gprcmd is
procedure Copy_Time_Stamp (From, To : String);
-- Copy file time stamp from file From to file To.
+ procedure Display_Command;
+ -- Display the invoked command to Standard_Error
+
---------
-- Cat --
---------
@@ -256,6 +263,19 @@ procedure Gprcmd is
Free (Buffer);
end Deps;
+ ---------------------
+ -- Display_Command --
+ ---------------------
+
+ procedure Display_Command is
+ begin
+ for J in 0 .. Argument_Count loop
+ Put (Standard_Error, Argument (J) & ' ');
+ end loop;
+
+ New_Line (Standard_Error);
+ end Display_Command;
+
------------
-- Extend --
------------
@@ -354,6 +374,8 @@ procedure Gprcmd is
"get the prefix of the GNAT installation");
Put_Line (Standard_Error, " path " &
"convert a directory list into a path list");
+ Put_Line (Standard_Error, " linkopts " &
+ "process attribute Linker'Linker_Options");
Put_Line (Standard_Error, " ignore " &
"do nothing");
OS_Exit (1);
@@ -362,6 +384,10 @@ procedure Gprcmd is
-- Start of processing for Gprcmd
begin
+ if Debug then
+ Display_Command;
+ end if;
+
Check_Args (Argument_Count > 0);
declare
@@ -408,8 +434,11 @@ begin
if Is_Absolute_Path (Argument (J)) then
Put (Format_Pathname (Argument (J), UNIX));
else
- Put (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
- UNIX));
+ Put (Format_Pathname
+ (Normalize_Pathname
+ (Format_Pathname (Argument (J)),
+ Format_Pathname (Dir)),
+ UNIX));
end if;
if J < Argument_Count then
@@ -426,17 +455,33 @@ begin
begin
for J in 3 .. Argument_Count loop
- if Is_Absolute_Path (Argument (J)) then
- Extend (Format_Pathname (Argument (J), UNIX));
- else
- Extend
- (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
- UNIX));
- end if;
- if J < Argument_Count then
- Put (' ');
- end if;
+ -- Remove quotes that may have been added around each argument
+
+ declare
+ Arg : constant String := Argument (J);
+ First : Natural := Arg'First;
+ Last : Natural := Arg'Last;
+ begin
+ if Arg (First) = '"' and then Arg (Last) = '"' then
+ First := First + 1;
+ Last := Last - 1;
+ end if;
+ if Is_Absolute_Path (Arg (First .. Last)) then
+ Extend (Format_Pathname (Arg (First .. Last), UNIX));
+ else
+ Extend
+ (Format_Pathname
+ (Normalize_Pathname
+ (Format_Pathname (Arg (First .. Last)),
+ Format_Pathname (Dir)),
+ UNIX));
+ end if;
+
+ if J < Argument_Count then
+ Put (' ');
+ end if;
+ end;
end loop;
end;
@@ -489,6 +534,70 @@ begin
Put (Argument (J));
Put (Path_Separator);
end loop;
+
+ -- Check the linker options for relative paths. Insert the project
+ -- base dir before relative paths.
+
+ elsif Cmd = "linkopts" then
+ Check_Args (Argument_Count >= 2);
+
+ -- First argument is the base directory of the project file
+
+ declare
+ Base_Dir : constant String := Argument (2) & '/';
+ begin
+ -- process the remainder of the arguments
+
+ for J in 3 .. Argument_Count loop
+ declare
+ Arg : constant String := Argument (J);
+ begin
+ -- If it is a switch other than a -L switch, just send back
+ -- the argument.
+
+ if Arg (Arg'First) = '-' and then
+ (Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
+ then
+ Put (Arg);
+
+ else
+ -- If it is a file, check if its path is relative, and
+ -- if it is relative, add <project base dir>/ in front.
+ -- Otherwise just send back the argument.
+
+ if Arg'Length <= 2
+ or else Arg (Arg'First .. Arg'First + 1) /= "-L"
+ then
+ if not Is_Absolute_Path (Arg) then
+ Put (Base_Dir);
+ end if;
+
+ Put (Arg);
+
+ -- For -L switches, check if the path is relative and
+ -- proceed similarly.
+
+ else
+ Put ("-L");
+
+ if
+ not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
+ then
+ Put (Base_Dir);
+ end if;
+
+ Put (Arg (Arg'First + 2 .. Arg'Last));
+ end if;
+ end if;
+ end;
+
+ -- Insert a space between each processed argument
+
+ if J /= Argument_Count then
+ Put (' ');
+ end if;
+ end loop;
+ end;
-- For "ignore" do nothing
Index: layout.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/layout.adb,v
retrieving revision 1.11
diff -u -p -r1.11 layout.adb
--- layout.adb 21 Oct 2003 13:42:09 -0000 1.11
+++ layout.adb 18 Feb 2004 11:47:59 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -1980,11 +1980,13 @@ package body Layout is
else
declare
- EsizV : SO_Ref;
- RM_SizV : Node_Id;
- Dchoice : Node_Id;
- Discrim : Node_Id;
- Dtest : Node_Id;
+ EsizV : SO_Ref;
+ RM_SizV : Node_Id;
+ Dchoice : Node_Id;
+ Discrim : Node_Id;
+ Dtest : Node_Id;
+ D_List : List_Id;
+ D_Entity : Entity_Id;
begin
RM_Siz_Expr := Empty;
@@ -2052,16 +2054,6 @@ package body Layout is
-- Otherwise construct the appropriate test
else
- -- Discriminant to be tested
-
- Discrim :=
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Chars => Vname),
- Selector_Name =>
- New_Occurrence_Of
- (Entity (Name (Vpart)), Loc));
-
-- The test to be used in general is a call to the
-- discriminant checking function. However, it is
-- definitely worth special casing the very common
@@ -2072,6 +2064,16 @@ package body Layout is
if No (Next (Dchoice))
and then Nkind (Dchoice) /= N_Range
then
+ -- Discriminant to be tested
+
+ Discrim :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars => Vname),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Entity (Name (Vpart)), Loc));
+
Dtest :=
Make_Op_Eq (Loc,
Left_Opnd => Discrim,
@@ -2083,6 +2085,25 @@ package body Layout is
-- False when the passed discriminant value matches.
else
+ -- The checking function takes all of the type's
+ -- discriminants as parameters, so a list of all
+ -- the selected discriminants must be constructed.
+
+ D_List := New_List;
+ D_Entity := First_Discriminant (E);
+ while Present (D_Entity) loop
+ Append (
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars => Vname),
+ Selector_Name =>
+ New_Occurrence_Of
+ (D_Entity, Loc)),
+ D_List);
+
+ D_Entity := Next_Discriminant (D_Entity);
+ end loop;
+
Dtest :=
Make_Op_Not (Loc,
Right_Opnd =>
@@ -2091,7 +2112,7 @@ package body Layout is
New_Occurrence_Of
(Dcheck_Function (Var), Loc),
Parameter_Associations =>
- New_List (Discrim)));
+ D_List));
end if;
RM_Siz_Expr :=
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.7
diff -u -p -r1.7 Makefile.generic
--- Makefile.generic 12 Feb 2004 13:28:10 -0000 1.7
+++ Makefile.generic 18 Feb 2004 11:47:59 -0000
@@ -349,8 +349,8 @@ else
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
- @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
- $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
+ @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
+ @$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
endif
endif
@@ -363,7 +363,7 @@ ifeq ($(strip $(filter-out c c++ ada,$(L
ifeq ($(MAIN),ada)
# Ada main
link: $(LINKER) archive-objects force
- @(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
@$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
@@ -376,15 +376,15 @@ else
# C/C++ main
link: $(LINKER) archive-objects force
- @(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
@$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
- -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
+ -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
internal-build: $(LINKER) archive-objects force
@$(display) $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
- -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
+ -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
endif
else
@@ -483,20 +483,20 @@ internal-c++ : $(CXX_OBJECTS)
.PHONY: force internal-clean internal-archive internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
internal-clean:
- @echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
+ @$(display) $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
@$(RM) $(OBJ_DIR)/*$(OBJ_EXT)
- @echo $(RM) $(OBJ_DIR)/*.ali
+ @$(display) $(RM) $(OBJ_DIR)/*.ali
@$(RM) $(OBJ_DIR)/*.ali
- @echo $(RM) $(OBJ_DIR)/b~*
+ @$(display) $(RM) $(OBJ_DIR)/b~*
@$(RM) $(OBJ_DIR)/b~*
- @echo $(RM) $(OBJ_DIR)/b_*
+ @$(display) $(RM) $(OBJ_DIR)/b_*
@$(RM) $(OBJ_DIR)/b_*
- @echo $(RM) $(OBJ_DIR)/*$(AR_EXT)
+ @$(display) $(RM) $(OBJ_DIR)/*$(AR_EXT)
@$(RM) $(OBJ_DIR)/*$(AR_EXT)
- @echo $(RM) $(OBJ_DIR)/*.d
+ @$(display) $(RM) $(OBJ_DIR)/*.d
@$(RM) $(OBJ_DIR)/*.d
ifneq ($(EXEC),)
- @echo $(RM) $(EXEC_DIR)/$(EXEC)
+ @$(display) $(RM) $(EXEC_DIR)/$(EXEC)
@$(RM) $(EXEC_DIR)/$(EXEC)
endif
Index: Makefile.prolog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.prolog,v
retrieving revision 1.3
diff -u -p -r1.3 Makefile.prolog
--- Makefile.prolog 12 Jan 2004 11:36:13 -0000 1.3
+++ Makefile.prolog 18 Feb 2004 11:47:59 -0000
@@ -40,6 +40,7 @@ GNATMAKE.saved:=$(GNATMAKE)
ADAFLAGS.saved:=$(ADAFLAGS)
CFLAGS.saved:=$(CFLAGS)
CXXFLAGS.saved:=$(CXXFLAGS)
+FLDFLAGS.saved:=$(FLDFLAGS)
LIBS.saved:=$(LIBS)
LDFLAGS.saved:=$(LDFLAGS)
ADA_SOURCES.saved:=$(ADA_SOURCES)
@@ -57,6 +58,7 @@ CXX_EXT:=.cc
AR_EXT=.a
OBJ_EXT=.o
CC=gcc
+FLDFLAGS:=
# Default target is to build (compile/bind/link)
# Target build is defined in Makefile.generic
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.74
diff -u -p -r1.74 Make-lang.in
--- Make-lang.in 18 Feb 2004 07:01:01 -0000 1.74
+++ Make-lang.in 18 Feb 2004 11:47:59 -0000
@@ -1369,8 +1369,8 @@ ada/bindgen.o : ada/ada.ads ada/a-except
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
ada/bindusg.o : ada/bindusg.ads ada/bindusg.adb ada/gnat.ads \
ada/g-os_lib.ads ada/g-string.ads ada/osint.ads ada/output.ads \
@@ -1406,19 +1406,19 @@ ada/checks.o : ada/ada.ads ada/a-except.
ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \
- ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
+ ada/sem.ads ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/comperr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/comperr.ads ada/comperr.adb \
@@ -1565,24 +1565,25 @@ ada/exp_aggr.o : ada/ada.ads ada/a-excep
ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \
ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_tss.ads \
ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \
- ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \
+ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \
+ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch3.ads \
+ ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
+ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imgenu.ads \
+ ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
@@ -1779,36 +1780,35 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except
ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
- ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
- ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads \
- ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads \
- ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_intr.ads \
- ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \
- ada/expander.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
- ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
- ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
+ ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
+ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch6.ads \
+ ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \
+ ada/exp_disp.ads ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \
+ ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \
+ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
- ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads \
- ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads \
- ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \
- ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
- ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads
+ ada/sem.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch6.ads \
+ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \
+ ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
+ ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
+ ada/widechar.ads
ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
@@ -2333,12 +2333,12 @@ ada/gnatbind.o : ada/ada.ads ada/a-excep
ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \
ada/switch.ads ada/switch-b.ads ada/system.ads ada/s-casuti.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \
- ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads
ada/gnatvsn.o : ada/gnatvsn.ads ada/gnatvsn.adb ada/system.ads \
@@ -3345,28 +3345,28 @@ ada/sem_elab.o : ada/ada.ads ada/a-excep
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
- ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
- ada/sem.ads ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads \
- ada/sem_elab.ads ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
- ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \
- ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
- ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/widechar.ads
+ ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \
+ ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
+ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_cat.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_elab.adb \
+ ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
+ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \
@@ -3464,33 +3464,34 @@ ada/sem_prag.o : ada/ada.ads ada/a-excep
ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
ada/erroutc.ads ada/eval_fat.ads ada/exp_ch7.ads ada/exp_dist.ads \
ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/g-speche.ads ada/g-string.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \
- ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \
- ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \
- ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
- ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads \
- ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \
- ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \
- ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads \
- ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \
- ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \
- ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \
- ada/s-exctab.adb ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
- ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
- ada/validsw.ads ada/widechar.ads
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-speche.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
+ ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-sort.adb ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \
+ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
+ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
+ ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \
+ ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \
+ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \
+ ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb \
+ ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \
+ ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \
+ ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \
+ ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \
+ ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \
+ ada/widechar.ads
ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
@@ -3498,29 +3499,30 @@ ada/sem_res.o : ada/ada.ads ada/a-except
ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \
ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads \
ada/exp_ch2.ads ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/exp_util.adb ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
- ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
- ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads \
- ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
- ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb \
- ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \
- ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
- ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \
+ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \
+ ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
+ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
+ ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch4.ads \
+ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \
+ ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
+ ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
+ ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
ada/validsw.ads ada/widechar.ads
@@ -3809,15 +3811,14 @@ ada/table.o : ada/debug.ads ada/gnat.ads
ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/targparm.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/csets.ads \
- ada/debug.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
- ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \
- ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/targparm.adb ada/tree_io.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \
+ ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/namet.adb \
+ ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/targparm.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads ada/widechar.ads
ada/tbuild.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
Index: prj-part.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.adb,v
retrieving revision 1.11
diff -u -p -r1.11 prj-part.adb
--- prj-part.adb 23 Jan 2004 10:30:04 -0000 1.11
+++ prj-part.adb 18 Feb 2004 11:47:59 -0000
@@ -840,6 +840,8 @@ package body Prj.Part is
Project_Scan_State : Saved_Project_Scan_State;
Source_Index : Source_File_Index;
+ Extending : Boolean := False;
+
Extended_Project : Project_Node_Id := Empty_Node;
A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
@@ -1051,6 +1053,27 @@ package body Prj.Part is
Scan;
end loop;
+ -- See if this is an extending project
+
+ if Token = Tok_Extends then
+
+ -- Make sure that gnatmake will use mapping files
+
+ Create_Mapping_File := True;
+
+ -- We are extending another project
+
+ Extending := True;
+
+ Scan; -- scan past EXTENDS
+
+ if Token = Tok_All then
+ Extends_All := True;
+ Set_Is_Extending_All (Project);
+ Scan; -- scan past ALL
+ end if;
+ end if;
+
-- If the name is well formed, Buffer_Last is > 0
if Buffer_Last > 0 then
@@ -1098,7 +1121,7 @@ package body Prj.Part is
begin
-- Extending_All is always propagated
- if From_Extended = Extending_All then
+ if From_Extended = Extending_All or else Extends_All then
From_Ext := Extending_All;
-- Otherwise, From_Extended is set to Extending_Single if the
@@ -1149,22 +1172,7 @@ package body Prj.Part is
end if;
- if Token = Tok_Extends then
-
- -- Make sure that gnatmake will use mapping files
-
- Create_Mapping_File := True;
-
- -- We are extending another project
-
- Scan; -- scan past EXTENDS
-
- if Token = Tok_All then
- Extends_All := True;
- Set_Is_Extending_All (Project);
- Scan; -- scan past ALL
- end if;
-
+ if Extending then
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
@@ -1205,11 +1213,11 @@ package body Prj.Part is
else
declare
- From_Extended : Extension_Origin := None;
+ From_Ext : Extension_Origin := None;
begin
- if Is_Extending_All (Project) then
- From_Extended := Extending_All;
+ if From_Extended = Extending_All or else Extends_All then
+ From_Ext := Extending_All;
end if;
Parse_Single_Project
@@ -1217,7 +1225,7 @@ package body Prj.Part is
Extends_All => Extends_All,
Path_Name => Extended_Project_Path_Name,
Extended => True,
- From_Extended => From_Extended);
+ From_Extended => From_Ext);
end;
-- A project that extends an extending-all project is also
@@ -1640,11 +1648,10 @@ package body Prj.Part is
else
declare
- Final_Result : String :=
+ Final_Result : constant String :=
GNAT.OS_Lib.Normalize_Pathname (Result.all);
begin
Free (Result);
- Canonical_Case_File_Name (Final_Result);
return Final_Result;
end;
end if;
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.5
diff -u -p -r1.5 vms_conv.adb
--- vms_conv.adb 26 Jan 2004 14:47:48 -0000 1.5
+++ vms_conv.adb 18 Feb 2004 11:48:00 -0000
@@ -58,6 +58,10 @@ package body VMS_Conv is
-- if a COMMANDS_TRANSLATION switch has been encountered while processing
-- a MAKE Command.
+ Output_File_Expected : Boolean := False;
+ -- True for GNAT LINK after -o switch, so that the ".ali" extension is
+ -- not added to the executable file name.
+
package Buffer is new Table.Table
(Table_Component_Type => Character,
Table_Index_Type => Integer,
@@ -1111,6 +1115,7 @@ package body VMS_Conv is
end if;
The_Command := Command.Command;
+ Output_File_Expected := False;
-- Give usage information if only command given
@@ -1277,6 +1282,7 @@ package body VMS_Conv is
elsif Arg.all = "/?" then
Display_Command := True;
+ Output_File_Expected := False;
-- Copy -switch unchanged
@@ -1284,6 +1290,11 @@ package body VMS_Conv is
Place (' ');
Place (Arg.all);
+ -- Set Output_File_Expected for the next argument
+
+ Output_File_Expected :=
+ Arg.all = "-o" and then The_Command = Link;
+
-- Copy quoted switch with quotes stripped
elsif Arg (Arg'First) = '"' then
@@ -1297,6 +1308,8 @@ package body VMS_Conv is
Place (Arg (Arg'First + 1 .. Arg'Last - 1));
end if;
+ Output_File_Expected := False;
+
-- Parameter Argument
elsif Arg (Arg'First) /= '/'
@@ -1357,8 +1370,12 @@ package body VMS_Conv is
Place (' ');
Place_Lower (Normal_File.all);
+ -- Add extension if not present, except after
+ -- switch -o.
+
if Is_Extensionless (Normal_File.all)
and then Command.Defext /= " "
+ and then not Output_File_Expected
then
Place ('.');
Place (Command.Defext);
@@ -1488,9 +1505,15 @@ package body VMS_Conv is
end case;
end if;
+ -- Reset Output_File_Expected, in case it was True
+
+ Output_File_Expected := False;
+
-- Qualifier argument
else
+ Output_File_Expected := False;
+
-- This code is too heavily nested, should be
-- separated out as separate subprogram ???
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-17 23:04 ` Rainer Orth
@ 2004-02-18 11:56 ` Arnaud Charlet
2004-02-18 18:36 ` Zack Weinberg
` (2 more replies)
2004-02-21 13:45 ` Rainer Orth
1 sibling, 3 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-18 11:56 UTC (permalink / raw)
To: Rainer Orth; +Cc: Arnaud Charlet, gcc-patches, Olivier Hainque
> This change broke Ada bootstrap on alpha-dec-osf*:
>
> /vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c: In function `__gnat_error_handler':
> /vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:486: warning: dereferencing type-punned pointer will break strict-aliasing rules
> make[2]: *** [ada/init.o] Error 1
>
> It cannot have been tested at all ;-(
It has been tested with mainline on x86-linux, and with gcc 3.2.3 on
alpha-tru64. Enabling addition warnings or changing warnings as error is
certainly 'expected' to generate lots of additional problems on various
platforms.
Addressing the warnings is easy in this case, I'll prepare a patch.
> only to fail later on with another error:
>
> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
> /vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
OK, I can't resist:
It cannot have been tested at all ;-)
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-02-12 14:44 Arnaud Charlet
@ 2004-02-17 23:04 ` Rainer Orth
2004-02-18 11:56 ` Arnaud Charlet
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Arnaud Charlet
1 sibling, 2 replies; 178+ messages in thread
From: Rainer Orth @ 2004-02-17 23:04 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches, Olivier Hainque
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
> Tested on x86-linux
> --
> 2004-02-12 Olivier Hainque <hainque@act-europe.fr>
[...]
> * init.c (__gnat_error_handler for alpha-tru64): Arrange to clear the
> sc_onstack context indication before raising the exception to which
> the signal is mapped. Allows better handling of later signals possibly
> triggered by the resumed user code if the exception is handled.
This change broke Ada bootstrap on alpha-dec-osf*:
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c: In function `__gnat_error_handler':
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:486: warning: dereferencing type-punned pointer will break strict-aliasing rules
make[2]: *** [ada/init.o] Error 1
It cannot have been tested at all ;-(
As a workaround, I've used this patch:
Tue Feb 17 23:17:29 2004 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
* config/alpha/t-osf4: Ignore ada/init.o warnings.
Index: t-osf4
===================================================================
RCS file: /cvs/gcc/gcc/gcc/config/alpha/t-osf4,v
retrieving revision 1.7
diff -u -p -r1.7 t-osf4
--- t-osf4 31 Jul 2003 12:01:06 -0000 1.7
+++ t-osf4 17 Feb 2004 22:17:13 -0000
@@ -24,3 +24,5 @@ SHLIB_LINK = $(GCC_FOR_TARGET) $(LIBGCC2
SHLIB_INSTALL = $(INSTALL_DATA) $(SHLIB_NAME) $$(DESTDIR)$$(slibdir)/$(SHLIB_SONAME); \
rm -f $$(DESTDIR)$$(slibdir)/$(SHLIB_NAME); \
$(LN_S) $(SHLIB_SONAME) $$(DESTDIR)$$(slibdir)/$(SHLIB_NAME)
+
+ada/init.o-warn = -Wno-error
It gets me past this error (although with two additional warnings):
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c: In function `__gnat_error_handler':
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:387: warning: variable 'exception' might be clobbered by `longjmp' or `vfork'
/vol/gnu/src/gcc/gcc-dist/gcc/ada/init.c:390: warning: variable 'msg' might be clobbered by `longjmp' or `vfork'
only to fail later on with another error:
/vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c: In function `sdbout_finish':
/vol/gnu/src/gcc/gcc-dist/gcc/sdbout.c:1465: warning: comparison between signed and unsigned
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Faculty of Technology, Bielefeld University
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-12 14:44 Arnaud Charlet
2004-02-17 23:04 ` Rainer Orth
2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 2 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-12 14:44 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-12 Olivier Hainque <hainque@act-europe.fr>
* decl.c (components_to_record): Don't claim that the internal fields
we make to hold the variant parts are semantically addressable, because
they are not.
* exp_pakd.adb (Create_Packed_Array_Type): Rename Esiz into PASize and
adjust the comment describing the modular type form when we can use it.
(Install_PAT): Account for the Esiz renaming.
* init.c (__gnat_error_handler for alpha-tru64): Arrange to clear the
sc_onstack context indication before raising the exception to which
the signal is mapped. Allows better handling of later signals possibly
triggered by the resumed user code if the exception is handled.
2004-02-12 Arnaud Charlet <charlet@act-europe.fr>
* 5zinit.adb: Removed, no longer used.
2004-02-12 Robert Dewar <dewar@gnat.com>
* ali.adb: Remove separating space between parameters on R line. Makes
format consistent with format used by the binder for Set_Globals call.
* atree.ads, atree.adb: Minor reformatting (new function header format)
* bindgen.adb: Add Run-Time Globals documentation section containing
detailed documentation of the globals passed from the binder file to
the run time.
* gnatls.adb: Minor reformatting
* init.c (__gnat_set_globals): Add note pointing to documentation in
bindgen.
* lib-writ.ads, lib-writ.adb: Remove separating space between
parameters on R line.
Makes format consistent with format used by the binder for Set_Globals
call.
* osint.ads: Add 2004 to copyright notice
Minor reformatting
* snames.ads: Correct capitalization of FIFO_Within_Priorities
Noticed during code reading, documentation issue only
* usage.adb: Remove junk line for obsolete C switch
Noticed during code reading
2004-02-12 Vincent Celier <celier@gnat.com>
* bld.adb (Process_Declarative_Items): For Source_Dirs call gprcmd
extend for each directory, so that multiple /** directories are
extended individually.
(Recursive_Process): Set the default for LANGUAGES to ada
* gprcmd.adb: Define new command "ignore", to do nothing.
Implement new comment "path".
* Makefile.generic: Suppress output when SILENT is set
Make sure that when compiler for C/C++ is gcc, the correct -x switch is
used, so that the correct compiler is invoked.
When compiler is gcc/g++, put search path in env vars C_INCLUDE_PATH/
CXX_INCLUDE_PATH, to avoid failure with too long command lines.
2004-02-12 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: Clean ups and remove obsolete targets.
2004-02-12 Ed Schonberg <schonberg@gnat.com>
* exp_ch5.adb: Remove Possible_Unligned_Slice, in favor of the similar
predicate declared in exp_util.
* exp_util.adb: Add comments.
* sem_ch10.adb (Analyze_Subunit): Remove ultimate parent unit from
visibility before compiling context of the subunit.
* sem_res.adb (Check_Parameterless_Call): If the context expects a
value but the name is a procedure, do not attempt to analyze as a call,
in order to obtain more telling diagnostics.
* sem_util.adb (Wrong_Type): Further enhancement to diagnose missing
'Access on parameterless function calls.
(Normalize_Actuals): For a parameterless function call with missing
actuals, defer diagnostic until resolution of enclosing call.
* sem_util.adb (Wrong_Type): If the context type is an access to
subprogram and the expression is a procedure name, suggest a missing
'attribute.
--
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.15
diff -u -p -r1.15 ali.adb
--- ali.adb 9 Feb 2004 14:56:03 -0000 1.15
+++ ali.adb 12 Feb 2004 13:26:31 -0000
@@ -991,10 +991,6 @@ package body ALI is
end case;
end loop;
- -- Skip separating space
-
- Checkc (' ');
-
-- Acquire information for parameter restrictions
for RP in All_Parameter_Restrictions loop
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.11
diff -u -p -r1.11 atree.adb
--- atree.adb 2 Feb 2004 12:31:47 -0000 1.11
+++ atree.adb 12 Feb 2004 13:26:31 -0000
@@ -1032,8 +1032,7 @@ package body Atree is
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty)
- return Node_Id
+ New_Scope : Entity_Id := Empty) return Node_Id
is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the
@@ -1053,8 +1052,7 @@ package body Atree is
-- Builds hash tables (number of elements >= threshold value)
function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id)
- return Elist_Id;
+ (Old_Elist : Elist_Id) return Elist_Id;
-- Called during second phase to copy element list doing replacements.
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
@@ -1167,8 +1165,7 @@ package body Atree is
---------------------------------
function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id)
- return Elist_Id
+ (Old_Elist : Elist_Id) return Elist_Id
is
M : Elmt_Id;
New_Elist : Elist_Id;
@@ -1243,8 +1240,7 @@ package body Atree is
--------------------------------
function Copy_List_With_Replacement
- (Old_List : List_Id)
- return List_Id
+ (Old_List : List_Id) return List_Id
is
New_List : List_Id;
E : Node_Id;
@@ -1270,14 +1266,12 @@ package body Atree is
--------------------------------
function Copy_Node_With_Replacement
- (Old_Node : Node_Id)
- return Node_Id
+ (Old_Node : Node_Id) return Node_Id
is
New_Node : Node_Id;
function Copy_Field_With_Replacement
- (Field : Union_Id)
- return Union_Id;
+ (Field : Union_Id) return Union_Id;
-- Given Field, which is a field of Old_Node, return a copy of it
-- if it is a syntactic field (i.e. its parent is Node), setting
-- the parent of the copy to poit to New_Node. Otherwise returns
@@ -1288,8 +1282,7 @@ package body Atree is
---------------------------------
function Copy_Field_With_Replacement
- (Field : Union_Id)
- return Union_Id
+ (Field : Union_Id) return Union_Id
is
begin
if Field = Union_Id (Empty) then
@@ -1829,8 +1822,7 @@ package body Atree is
function New_Entity
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Entity_Id
+ New_Sloc : Source_Ptr) return Entity_Id
is
Ent : Entity_Id;
@@ -1900,8 +1892,7 @@ package body Atree is
function New_Node
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Node_Id
+ New_Sloc : Source_Ptr) return Node_Id
is
Nod : Node_Id;
Index: atree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.ads,v
retrieving revision 1.7
diff -u -p -r1.7 atree.ads
--- atree.ads 2 Feb 2004 12:31:47 -0000 1.7
+++ atree.ads 12 Feb 2004 13:26:31 -0000
@@ -332,8 +332,7 @@ package Atree is
function New_Node
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Node_Id;
+ New_Sloc : Source_Ptr) return Node_Id;
-- Allocates a completely new node with the given node type and source
-- location values. All other fields are set to their standard defaults:
--
@@ -351,8 +350,7 @@ package Atree is
function New_Entity
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Entity_Id;
+ New_Sloc : Source_Ptr) return Entity_Id;
-- Similar to New_Node, except that it is used only for entity nodes
-- and returns an extended node.
@@ -427,8 +425,7 @@ package Atree is
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty)
- return Node_Id;
+ New_Scope : Entity_Id := Empty) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Tree copies the entire
-- syntactic subtree, including recursively any descendents whose parent
-- field references a copied node (descendents not linked to a copied node
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.20
diff -u -p -r1.20 bindgen.adb
--- bindgen.adb 4 Feb 2004 11:06:18 -0000 1.20
+++ bindgen.adb 12 Feb 2004 13:26:32 -0000
@@ -80,6 +80,88 @@ package body Bindgen is
Table_Increment => 200,
Table_Name => "IS_Pragma_Settings");
+ ----------------------
+ -- Run-Time Globals --
+ ----------------------
+
+ -- This section documents the global variables that are passed to the
+ -- run time from the generated binder file. The call that is made is
+ -- to the routine Set_Globals, which has the following spec:
+
+ -- procedure Set_Globals
+ -- (Main_Priority : Integer;
+ -- Time_Slice_Value : Integer;
+ -- WC_Encoding : Character;
+ -- Locking_Policy : Character;
+ -- Queuing_Policy : Character;
+ -- Task_Dispatching_Policy : Character;
+ -- Restrictions : System.Address;
+ -- Interrupt_States : System.Address;
+ -- Num_Interrupt_States : Integer;
+ -- Unreserve_All_Interrupts : Integer;
+ -- Exception_Tracebacks : Integer;
+ -- Zero_Cost_Exceptions : Integer);
+
+ -- Main_Priority is the priority value set by pragma Priority in the
+ -- main program. If no such pragma is present, the value is -1.
+
+ -- Time_Slice_Value is the time slice value set by pragma Time_Slice
+ -- in the main program, or by the use of a -Tnnn parameter for the
+ -- binder (if both are present, the binder value overrides). The
+ -- value is in milliseconds. A value of zero indicates that time
+ -- slicing should be suppressed. If no pragma is present, and no
+ -- -T switch was used, the value is -1.
+
+ -- WC_Encoding shows the wide character encoding method used for
+ -- the main program. This is one of the encoding letters defined
+ -- in System.WCh_Con.WC_Encoding_Letters.
+
+ -- Locking_Policy is a space if no locking policy was specified
+ -- for the partition. If a locking policy was specified, the value
+ -- is the upper case first character of the locking policy name,
+ -- for example, 'C' for Ceiling_Locking.
+
+ -- Queuing_Policy is a space if no queuing policy was specified
+ -- for the partition. If a queuing policy was specified, the value
+ -- is the upper case first character of the queuing policy name
+ -- for example, 'F' for FIFO_Queuing.
+
+ -- Task_Dispatching_Policy is a space if no task dispatching policy
+ -- was specified for the partition. If a task dispatching policy
+ -- was specified, the value is the upper case first character of
+ -- the policy name, e.g. 'F' for FIFO_Within_Priorities.
+
+ -- Restrictions is the address of a null-terminated string specifying the
+ -- restrictions information for the partition. The format is identical to
+ -- that of the parameter string found on R lines in ali files (see Lib.Writ
+ -- spec in lib-writ.ads for full details). The difference is that in this
+ -- context the values are the cumulative ones for the entire partition.
+
+ -- Interrupt_States is the address of a string used to specify the
+ -- cumulative results of Interrupt_State pragmas used in the partition.
+ -- The length of this string is determined by the last interrupt for which
+ -- such a pragma is given (the string will be a null string if no pragmas
+ -- were used). If pragma were present the entries apply to the interrupts
+ -- in sequence from the first interrupt, and are set to one of four
+ -- possible settings: 'n' for not specified, 'u' for user, 'r' for
+ -- run time, 's' for system, see description of Interrupt_State pragma
+ -- for further details.
+
+ -- Num_Interrupt_States is the length of the Interrupt_States string.
+ -- It will be set to zero if no Interrupt_State pragmas are present.
+
+ -- Unreserve_All_Interrupts is set to one if at least one unit in the
+ -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
+
+ -- Exception_Tracebacks is set to one if the -E parameter was present
+ -- in the bind and to zero otherwise. Note that on some targets exception
+ -- tracebacks are provided by default, so a value of zero for this
+ -- parameter does not necessarily mean no trace backs are available.
+
+ -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
+ -- this partition, and to zero if longjmp/setjmp exceptions are used.
+ -- the use of zero
+
-----------------------
-- Local Subprograms --
-----------------------
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.7
diff -u -p -r1.7 bld.adb
--- bld.adb 4 Feb 2004 11:06:18 -0000 1.7
+++ bld.adb 12 Feb 2004 13:26:32 -0000
@@ -1504,11 +1504,11 @@ package body Bld is
-- being an absolute directory name.
Put (Project_Name &
- ".src_dirs:=$(shell gprcmd extend $(");
- Put (Project_Name);
- Put (".base_dir) '$(");
+ ".src_dirs:=$(foreach name,$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")')");
+ Put ("),$(shell gprcmd extend $(");
+ Put (Project_Name);
+ Put_Line (".base_dir) '$(name)'))");
elsif Item_Name = Snames.Name_Source_Files then
@@ -2691,6 +2691,13 @@ package body Bld is
IO.Mark (Src_List_File_Init);
Put_Line ("src_list_file.specified:=FALSE");
+
+ -- Default language is Ada, but variable LANGUAGES may have
+ -- been changed by an imported Makefile. So, we set it
+ -- to "ada"; if attribute Languages is defined in the project
+ -- file, it will be redefined.
+
+ Put_Line ("LANGUAGES:=ada");
-- <PROJECT>.src_dirs is set by default to the project
-- directory.
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.27
diff -u -p -r1.27 decl.c
--- decl.c 2 Feb 2004 12:31:48 -0000 1.27
+++ decl.c 12 Feb 2004 13:26:32 -0000
@@ -5366,7 +5366,7 @@ components_to_record (tree gnu_record_ty
? TYPE_SIZE (gnu_record_type) : 0),
(all_rep_and_size
? bitsize_zero_node : 0),
- 1);
+ 0);
DECL_INTERNAL_P (gnu_field) = 1;
DECL_QUALIFIER (gnu_field) = gnu_qual;
@@ -5397,7 +5397,7 @@ components_to_record (tree gnu_record_ty
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
packed,
all_rep ? TYPE_SIZE (gnu_union_type) : 0,
- all_rep ? bitsize_zero_node : 0, 1);
+ all_rep ? bitsize_zero_node : 0, 0);
DECL_INTERNAL_P (gnu_union_field) = 1;
TREE_CHAIN (gnu_union_field) = gnu_field_list;
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_ch5.adb
--- exp_ch5.adb 2 Feb 2004 12:31:50 -0000 1.15
+++ exp_ch5.adb 12 Feb 2004 13:26:32 -0000
@@ -52,7 +52,6 @@ with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
@@ -181,16 +180,6 @@ package body Exp_Ch5 is
-- an object. Such objects can be aliased to parameters (unlike local
-- array references).
- function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean;
- -- Returns True if Arg (either the left or right hand side of the
- -- assignment) is a slice that could be unaligned wrt the array type.
- -- This is true if Arg is a component of a packed record, or is
- -- a record component to which a component clause applies. This
- -- is a little pessimistic, but the result of an unnecessary
- -- decision that something is possibly unaligned is only to
- -- generate a front end loop, which is not so terrible.
- -- It would really be better if backend handled this ???
-
-----------------------
-- Apply_Dereference --
-----------------------
@@ -242,60 +231,6 @@ package body Exp_Ch5 is
and then Is_Non_Local_Array (Prefix (Exp)));
end Is_Non_Local_Array;
- ------------------------------
- -- Possible_Unaligned_Slice --
- ------------------------------
-
- function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean is
- begin
- -- No issue if this is not a slice, or else strict alignment
- -- is not required in any case.
-
- if Nkind (Arg) /= N_Slice
- or else not Target_Strict_Alignment
- then
- return False;
- end if;
-
- -- No issue if the component type is a byte or byte aligned
-
- declare
- Array_Typ : constant Entity_Id := Etype (Arg);
- Comp_Typ : constant Entity_Id := Component_Type (Array_Typ);
- Pref : constant Node_Id := Prefix (Arg);
-
- begin
- if Known_Alignment (Array_Typ) then
- if Alignment (Array_Typ) = 1 then
- return False;
- end if;
-
- elsif Known_Component_Size (Array_Typ) then
- if Component_Size (Array_Typ) = 1 then
- return False;
- end if;
-
- elsif Known_Esize (Comp_Typ) then
- if Esize (Comp_Typ) <= System_Storage_Unit then
- return False;
- end if;
- end if;
-
- -- No issue if this is not a selected component
-
- if Nkind (Pref) /= N_Selected_Component then
- return False;
- end if;
-
- -- Else we test for a possibly unaligned component
-
- return
- Is_Packed (Etype (Pref))
- or else
- Present (Component_Clause (Entity (Selector_Name (Pref))));
- end;
- end Possible_Unaligned_Slice;
-
-- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
@@ -528,8 +463,8 @@ package body Exp_Ch5 is
elsif Is_Bit_Packed_Array (L_Type)
or else Is_Bit_Packed_Array (R_Type)
- or else Possible_Unaligned_Slice (Lhs)
- or else Possible_Unaligned_Slice (Rhs)
+ or else Is_Possibly_Unaligned_Slice (Lhs)
+ or else Is_Possibly_Unaligned_Slice (Rhs)
then
Loop_Required := True;
Index: exp_pakd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_pakd.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_pakd.adb
--- exp_pakd.adb 23 Jan 2004 10:30:03 -0000 1.10
+++ exp_pakd.adb 12 Feb 2004 13:26:32 -0000
@@ -700,7 +700,7 @@ package body Exp_Pakd is
Ancest : Entity_Id;
PB_Type : Entity_Id;
- Esiz : Uint;
+ PASize : Uint;
Decl : Node_Id;
PAT : Entity_Id;
Len_Dim : Node_Id;
@@ -770,10 +770,10 @@ package body Exp_Pakd is
-- Do not reset RM_Size if already set, as happens in the case
-- of a modular type.
- Set_Esize (PAT, Esiz);
+ Set_Esize (PAT, PASize);
if Unknown_RM_Size (PAT) then
- Set_RM_Size (PAT, Esiz);
+ Set_RM_Size (PAT, PASize);
end if;
-- Set remaining fields of packed array type
@@ -853,7 +853,7 @@ package body Exp_Pakd is
-- type, since this size clearly belongs to the packed array type. The
-- size of the conceptual unpacked type is always set to unknown.
- Esiz := Esize (Typ);
+ PASize := Esize (Typ);
-- Case of an array where at least one index is of an enumeration
-- type with a non-standard representation, but the component size
@@ -1099,7 +1099,8 @@ package body Exp_Pakd is
-- We can use the modular type, it has the form:
-- subtype tttPn is btyp
- -- range 0 .. 2 ** (Esize (Typ) * Csize) - 1;
+ -- range 0 .. 2 ** ((Typ'Length (1)
+ -- * ... * Typ'Length (n)) * Csize) - 1;
-- The bounds are statically known, and btyp is one
-- of the unsigned types, depending on the length. If the
@@ -1140,8 +1141,8 @@ package body Exp_Pakd is
Make_Integer_Literal (Loc, 0),
High_Bound => Lit))));
- if Esiz = Uint_0 then
- Esiz := Len_Bits;
+ if PASize = Uint_0 then
+ PASize := Len_Bits;
end if;
Install_PAT;
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.19
diff -u -p -r1.19 exp_util.adb
--- exp_util.adb 2 Feb 2004 12:31:51 -0000 1.19
+++ exp_util.adb 12 Feb 2004 13:26:32 -0000
@@ -2352,6 +2352,13 @@ package body Exp_Util is
function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
begin
+ -- ??? GCC3 will eventually handle strings with arbitrary alignments,
+ -- but for now the following check must be disabled.
+
+ -- if get_gcc_version >= 3 then
+ -- return False;
+ -- end if;
+
if Is_Entity_Name (P)
and then Is_Object (Entity (P))
and then Present (Renamed_Object (Entity (P)))
Index: gnatls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatls.adb,v
retrieving revision 1.13
diff -u -p -r1.13 gnatls.adb
--- gnatls.adb 9 Feb 2004 14:56:04 -0000 1.13
+++ gnatls.adb 12 Feb 2004 13:26:32 -0000
@@ -87,10 +87,10 @@ procedure Gnatls is
Print_Unit : Boolean := True;
Print_Source : Boolean := True;
Print_Object : Boolean := True;
- -- Flags controlling the form of the outpout
+ -- Flags controlling the form of the output
- Dependable : Boolean := False; -- flag -d
- Also_Predef : Boolean := False;
+ Dependable : Boolean := False; -- flag -d
+ Also_Predef : Boolean := False;
Unit_Start : Integer;
Unit_End : Integer;
@@ -132,14 +132,14 @@ procedure Gnatls is
-- updated to the full file name if available.
function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id;
- -- Give the Sdep entry corresponding to the unit U in ali record A.
+ -- Give the Sdep entry corresponding to the unit U in ali record A
procedure Output_Object (O : File_Name_Type);
-- Print out the name of the object when requested
procedure Output_Source (Sdep_I : Sdep_Id);
-- Print out the name and status of the source corresponding to this
- -- sdep entry
+ -- sdep entry.
procedure Output_Status (FS : File_Status; Verbose : Boolean);
-- Print out FS either in a coded form if verbose is false or in an
@@ -152,10 +152,10 @@ procedure Gnatls is
-- Reset Print flags properly when selective output is chosen
procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean);
- -- Scan and process lser specific arguments. Argv is a single argument.
+ -- Scan and process lser specific arguments. Argv is a single argument
procedure Usage;
- -- Print usage message.
+ -- Print usage message
-----------------
-- Add_Lib_Dir --
@@ -279,10 +279,12 @@ procedure Gnatls is
-- Verify is output is not wider than maximum number of columns
- Too_Long := Verbose_Mode or else
- (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
+ Too_Long :=
+ Verbose_Mode
+ or else
+ (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
- -- Set start and end of columns.
+ -- Set start and end of columns
Object_Start := 1;
Object_End := Object_Start - 1;
@@ -817,10 +819,9 @@ begin
Namet.Initialize;
Csets.Initialize;
- -- Use low level argument routines to avoid dragging in the secondary stack
+ -- Loop to scan out arguments
Next_Arg := 1;
-
Scan_Args : while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
@@ -956,6 +957,7 @@ begin
end loop;
Find_General_Layout;
+
for Id in ALIs.First .. ALIs.Last loop
declare
Last_U : Unit_Id;
@@ -993,7 +995,7 @@ begin
end if;
end loop;
- -- Print out list of dependable units
+ -- Print out list of units on which this unit depends (D lines)
if Dependable and then Print_Source then
if Verbose_Mode then
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.7
diff -u -p -r1.7 gprcmd.adb
--- gprcmd.adb 4 Feb 2004 11:06:18 -0000 1.7
+++ gprcmd.adb 12 Feb 2004 13:26:32 -0000
@@ -38,6 +38,9 @@
-- deps post process dependency makefiles
-- stamp copy file time stamp from file1 to file2
-- prefix get the prefix of the GNAT installation
+-- path convert a list of directories to a path list, inserting a
+-- path separator after each directory, including the last one
+-- ignore do nothing
with Gnatvsn;
with Osint; use Osint;
@@ -349,6 +352,10 @@ procedure Gprcmd is
"copy file time stamp from file1 to file2");
Put_Line (Standard_Error, " prefix " &
"get the prefix of the GNAT installation");
+ Put_Line (Standard_Error, " path " &
+ "convert a directory list into a path list");
+ Put_Line (Standard_Error, " ignore " &
+ "do nothing");
OS_Exit (1);
end Usage;
@@ -363,7 +370,8 @@ begin
begin
if Cmd = "-v" then
- -- Should this be on Standard_Error ???
+ -- Output on standard error, because only returned values should
+ -- go to standard output.
Put (Standard_Error, "GPRCMD ");
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
@@ -473,6 +481,19 @@ begin
end if;
end if;
end;
+
+ -- For "path" just add path separator after each directory argument
+
+ elsif Cmd = "path" then
+ for J in 2 .. Argument_Count loop
+ Put (Argument (J));
+ Put (Path_Separator);
+ end loop;
+
+ -- For "ignore" do nothing
+
+ elsif Cmd = "ignore" then
+ null;
-- Unknown command
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.23
diff -u -p -r1.23 init.c
--- init.c 2 Feb 2004 12:31:53 -0000 1.23
+++ init.c 12 Feb 2004 13:26:32 -0000
@@ -39,6 +39,10 @@
installed by this file are used to handle resulting signals that come
from these probes failing (i.e. touching protected pages) */
+/* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, and
+ 5zinit.adb. All these files implement the required functionality for
+ different targets. */
+
/* The following include is here to meet the published VxWorks requirement
that the __vxworks header appear before any other include. */
#ifdef __vxworks
@@ -154,6 +158,9 @@ __gnat_get_interrupt_state (int intrup)
binder file is not in the shared library. Global references across library
boundaries like this are not handled correctly in all systems. */
+/* For detailed description of the parameters to this routine, see the
+ section titled Run-Time Globals in package Bindgen (bindgen.adb) */
+
void
__gnat_set_globals (int main_priority,
int time_slice_val,
@@ -363,6 +370,7 @@ __gnat_initialize (void)
exclude this case in the above test. */
#include <signal.h>
+#include <setjmp.h>
#include <sys/siginfo.h>
static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *);
@@ -440,7 +448,48 @@ __gnat_error_handler (int sig, siginfo_t
if (mstate != 0)
*mstate = *context;
- Raise_From_Signal_Handler (exception, (char *) msg);
+ /* We are now going to raise the exception corresponding to the signal we
+ caught, which may eventually end up resuming the application code if the
+ exception is handled.
+
+ When the exception is handled, merely arranging for the *exception*
+ handler's context (stack pointer, program counter, other registers, ...)
+ to be installed is *not* enough to let the kernel think we've left the
+ *signal* handler. This has annoying implications if an alternate stack
+ has been setup for this *signal* handler, because the kernel thinks we
+ are still running on that alternate stack even after the jump, which
+ causes trouble at least as soon as another signal is raised.
+
+ We deal with this by forcing a "local" longjmp within the signal handler
+ below, forcing the "on alternate stack" indication to be reset (kernel
+ wise) on the way. If no alternate stack has been setup, this should be a
+ neutral operation. Otherwise, we will be in a delicate situation for a
+ short while because we are going to run the exception propagation code
+ within the alternate stack area (that is, with the stack pointer inside
+ the alternate stack bounds), but with the corresponding flag off from the
+ kernel's standpoint. We expect this to be ok as long as the propagation
+ code does not trigger a signal itself, which is expected.
+
+ ??? A better approach would be to at least delay this operation until the
+ last second, that is, until just before we jump to the exception handler,
+ if any. */
+ {
+ jmp_buf handler_jmpbuf;
+
+ if (setjmp (handler_jmpbuf) != 0)
+ Raise_From_Signal_Handler (exception, (char *) msg);
+ else
+ {
+ /* Arrange for the "on alternate stack" flag to be reset. See the
+ comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
+ struct sigcontext * handler_context
+ = (struct sigcontext *) & handler_jmpbuf;
+
+ handler_context->sc_onstack = 0;
+
+ longjmp (handler_jmpbuf, 1);
+ }
+ }
}
void
@@ -461,11 +510,12 @@ __gnat_install_handler (void)
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. */
+ /* 8K is a mininum to be able to propagate an exception using the GCC/ZCX
+ scheme. */
struct sigaltstack ss;
- ss.ss_sp = (void *) & sig_stack;
+ ss.ss_sp = (void *) sig_stack;
ss.ss_size = sizeof (sig_stack);
ss.ss_flags = 0;
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.15
diff -u -p -r1.15 lib-writ.adb
--- lib-writ.adb 9 Feb 2004 14:56:04 -0000 1.15
+++ lib-writ.adb 12 Feb 2004 13:26:32 -0000
@@ -940,10 +940,6 @@ package body Lib.Writ is
end if;
end loop;
- -- A separating space
-
- Write_Info_Char (' ');
-
-- And now the information for the parameter restrictions
for RP in All_Parameter_Restrictions loop
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.12
diff -u -p -r1.12 lib-writ.ads
--- lib-writ.ads 9 Feb 2004 14:56:04 -0000 1.12
+++ lib-writ.ads 12 Feb 2004 13:26:32 -0000
@@ -256,7 +256,7 @@ package Lib.Writ is
-- has been able to determine with respect to restrictions violations.
-- The format is:
- -- R <<restriction-characters>> space <<restriction-param-id-entries>>
+ -- R <<restriction-characters>> <<restriction-param-id-entries>>
-- The first parameter is a string of characters that records
-- information regarding restrictions that do not take parameter
@@ -283,8 +283,9 @@ package Lib.Writ is
-- has "v", which is not permitted, since these restrictions
-- are partition-wide.
- -- Following a space, the second parameter refers to restriction
- -- identifiers for which a parameter is given.
+ -- The second parameter, which immediately follows the first (with
+ -- no separating space) gives restriction information for identifiers
+ -- for which a parameter is given.
-- The parameter is a string of entries, one for each value in
-- Restrict.All_Parameter_Restrictions. Each entry has two
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.6
diff -u -p -r1.6 Makefile.generic
--- Makefile.generic 26 Jan 2004 14:47:48 -0000 1.6
+++ Makefile.generic 12 Feb 2004 13:26:32 -0000
@@ -9,12 +9,12 @@
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
-
+
# GCC is distributed in the hope that it will be useful,
# but WITHOUT 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
# along with GCC; see the file COPYING. If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330,
@@ -64,7 +64,7 @@
# CXX name of the C++ compiler (optional, default to gcc)
# AR_CMD command to create an archive (optional, default to "ar rc")
# AR_EXT file extension of an archive (optional, default to ".a")
-# RANLIB command to generate an index (optional, default to "ranlib")
+# RANLIB command to generate an index (optional, default to "ranlib")
# GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
# CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
@@ -78,6 +78,9 @@
# PROJECT_FILE name of the project file, without the .gpr extension
# DEPS_PROJECTS list of project dependencies (optional)
+# SILENT (optional) when defined, make -s will not output anything
+# when all commands are successful.
+
# Set the source search path for C and C++ if needed
ifndef MAIN
@@ -124,7 +127,7 @@ ifndef RANLIB
endif
ifndef GNATMAKE
- GNATMAKE=gnatmake
+ GNATMAKE:=gnatmake
endif
ifndef ARCHIVE
@@ -135,6 +138,39 @@ ifeq ($(EXEC_DIR),)
EXEC_DIR=$(OBJ_DIR)
endif
+# Define display to echo only when SILENT is not defined
+
+ifdef SILENT
+define display
+ @gprcmd ignore
+endef
+
+else
+define display
+ @echo
+endef
+endif
+
+# Make sure gnatmake is called silently when SILENT is set
+ifdef SILENT
+ GNATMAKE:=$(GNATMAKE) -q
+endif
+
+# If C/C++ compiler is gcc, make sure gcc is called with the switch indicating
+# the language, in case the extension is not standard.
+
+ifeq ($(strip $(filter-out %gcc,$(CC))),)
+ C_Compiler=$(CC) -x c
+else
+ C_Compiler=$(CC)
+endif
+
+ifeq ($(strip $(filter-out %gcc %g++,$(CXX))),)
+ CXX_Compiler=$(CXX) -x c++
+else
+ CXX_Compiler=$(CXX)
+endif
+
# Set the object search path
vpath %$(OBJ_EXT) $(OBJ_DIR)
@@ -222,8 +258,8 @@ else
endif
C_INCLUDES := $(foreach name,$(SRC_DIRS),-I$(name))
-ALL_CFLAGS = $(CFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
-ALL_CXXFLAGS = $(CXXFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
+ALL_CFLAGS = $(CFLAGS) $(DEP_CFLAGS)
+ALL_CXXFLAGS = $(CXXFLAGS) $(DEP_CFLAGS)
LDFLAGS := $(LIBS) $(LDFLAGS)
# Compute list of objects based on languages
@@ -276,7 +312,7 @@ else
internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
- @echo creating archive file for $(PROJECT_BASE)
+ @$(display) creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
-$(RANLIB) $(OBJ_DIR)/$@
@@ -313,7 +349,7 @@ else
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
- @echo $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
+ @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
endif
endif
@@ -327,11 +363,12 @@ ifeq ($(strip $(filter-out c c++ ada,$(L
ifeq ($(MAIN),ada)
# Ada main
link: $(LINKER) archive-objects force
- $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ @(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(display) $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
@@ -339,11 +376,12 @@ else
# C/C++ main
link: $(LINKER) archive-objects force
- $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ @(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(display) $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
@@ -360,7 +398,12 @@ endif
# Automatic handling of dependencies
ifeq ($(strip $(filter-out %gcc %g++,$(CC) $(CXX))),)
-# Compiler is GCC, take avantage of the preprocessor option -MD
+# Compiler is GCC, take avantage of the preprocessor option -MD and
+# C*_INCLUDE_PATH environment variables
+
+export C_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(C_INCLUDE_PATH)
+export CXX_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(CXX_INCLUDE_PATH)
+
DEP_CFLAGS = -Wp,-MD,$(OBJ_DIR)/$(*F).d
define post-compile
@@ -375,6 +418,9 @@ $(OBJ_DIR)/%.d:
else
# Compiler unknown, use a more general approach based on the output of $(CC) -M
+ALL_CFLAGS := $(ALL_CFLAGS) $(C_INCLUDES)
+ALL_CXXFLAGS := $(ALL_CXXFLAGS) $(C_INCLUDES)
+
DEP_FLAGS = -M
DEP_CFLAGS =
@@ -400,17 +446,17 @@ endif
# Compile C files individually
%$(OBJ_EXT) : %$(C_EXT)
- @echo $(CC) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(display) $(C_Compiler) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
ifndef FAKE_COMPILE
- @$(CC) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(C_Compiler) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
@$(post-compile)
endif
# Compile C++ files individually
%$(OBJ_EXT) : %$(CXX_EXT)
- @echo $(CXX) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(display) $(CXX_Compiler) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
ifndef FAKE_COMPILE
- @$(CXX) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(CXX_Compiler) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
@$(post-compile)
endif
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.71
diff -u -p -r1.71 Makefile.in
--- Makefile.in 2 Feb 2004 16:26:37 -0000 1.71
+++ Makefile.in 12 Feb 2004 13:26:33 -0000
@@ -1861,27 +1861,18 @@ rts-zfp: force
RTS_NAME=zfp RTS_SRCS="$(HIE_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
- -$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
+ $(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
$(CHMOD) a-wx rts-zfp/adalib/libgnat.a
-rts-none: force
- $(MAKE) $(FLAGS_TO_PASS) prepare-rts \
- RTS_NAME=none RTS_SRCS="$(HIE_SOURCES)" \
- RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
- COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
- -$(GNATMAKE) -Prts-none/none.gpr --GCC="../../../xgcc -B../../../"
- $(RM) rts-none/adalib/*.o
- $(CHMOD) a-wx rts-none/adalib/*.ali
-
rts-ravenscar: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
- -$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
+ $(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
cd rts-ravenscar/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-ravenscar/adalib/*.o
Index: osint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.ads,v
retrieving revision 1.11
diff -u -p -r1.11 osint.ads
--- osint.ads 5 Jan 2004 15:20:45 -0000 1.11
+++ osint.ads 12 Feb 2004 13:26:33 -0000
@@ -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- --
@@ -52,9 +52,8 @@ package Osint is
type File_Type is (Source, Library, Config, Definition, Preprocessing_Data);
function Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type;
-- Finds a source, library or config file depending on the value
-- of T following the directory search order rules unless N is the
-- name of the file just read with Next_Main_File and already
@@ -155,8 +154,7 @@ package Osint is
function To_Canonical_File_List
(Wildcard_Host_File : String;
- Only_Dirs : Boolean)
- return String_Access_List_Access;
+ Only_Dirs : Boolean) return String_Access_List_Access;
-- Expand a wildcard host syntax file or directory specification (e.g. on
-- a VMS host, any file or directory spec that contains:
-- "*", or "%", or "...")
@@ -165,8 +163,7 @@ package Osint is
function To_Canonical_Dir_Spec
(Host_Dir : String;
- Prefix_Style : Boolean)
- return String_Access;
+ Prefix_Style : Boolean) return String_Access;
-- Convert a host syntax directory specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir").
-- If Prefix_Style then make it a valid file specification prefix.
@@ -176,30 +173,26 @@ package Osint is
-- this simply means the spec has a trailing slash ("/").
function To_Canonical_File_Spec
- (Host_File : String)
- return String_Access;
+ (Host_File : String) return String_Access;
-- Convert a host syntax file specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g.
-- "/sys$device/dir/file.ext.69").
function To_Canonical_Path_Spec
- (Host_Path : String)
- return String_Access;
+ (Host_Path : String) return String_Access;
-- Convert a host syntax Path specification (e.g. on a VMS host:
-- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g.
-- "/sys$device/foo:disk$user/foo").
function To_Host_Dir_Spec
(Canonical_Dir : String;
- Prefix_Style : Boolean)
- return String_Access;
+ Prefix_Style : Boolean) return String_Access;
-- Convert a canonical syntax directory specification to host syntax.
-- The Prefix_Style flag is currently ignored but should be set to
-- False.
function To_Host_File_Spec
- (Canonical_File : String)
- return String_Access;
+ (Canonical_File : String) return String_Access;
-- Convert a canonical syntax file specification to host syntax.
function Relocate_Path
@@ -209,9 +202,8 @@ package Osint is
-- replace the Prefix substring with the root installation directory.
-- By default, try to compute the root installation directory by looking
-- at the executable name as it was typed on the command line and, if
- -- needed, use the PATH environment variable.
- -- If the above computation fails, return Path.
- -- This function assumes that Prefix'First = Path'First
+ -- needed, use the PATH environment variable. If the above computation
+ -- fails, return Path. This function assumes Prefix'First = Path'First.
function Shared_Lib (Name : String) return String;
-- Returns the runtime shared library in the form -l<name>-<version> where
@@ -244,8 +236,7 @@ package Osint is
procedure Get_Next_Dir_In_Path_Init
(Search_Path : String_Access);
function Get_Next_Dir_In_Path
- (Search_Path : String_Access)
- return String_Access;
+ (Search_Path : String_Access) return String_Access;
-- These subprograms are used to parse out the directory names in a
-- search path specified by a Search_Path argument. The procedure
-- initializes an internal pointer to point to the initial directory
@@ -292,8 +283,7 @@ package Osint is
function Get_RTS_Search_Dir
(Search_Dir : String;
- File_Type : Search_File_Type)
- return String_Ptr;
+ File_Type : Search_File_Type) return String_Ptr;
-- This function retrieves the paths to the search (resp. lib) dirs and
-- return them. The search dir can be absolute or relative. If the search
-- dir contains Include_Search_File (resp. Object_Search_File), then this
@@ -382,9 +372,8 @@ package Osint is
-- called Source_File_Data (Cache => True). See below.
function Matching_Full_Source_Name
- (N : File_Name_Type;
- T : Time_Stamp_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : Time_Stamp_Type) return File_Name_Type;
-- Same semantics than Full_Source_Name but will search on the source
-- path until a source file with time stamp matching T is found. If
-- none is found returns No_File.
@@ -440,8 +429,7 @@ package Osint is
function Read_Library_Info
(Lib_File : File_Name_Type;
- Fatal_Err : Boolean := False)
- return Text_Buffer_Ptr;
+ Fatal_Err : Boolean := False) return Text_Buffer_Ptr;
-- Allocates a Text_Buffer of appropriate length and reads in the entire
-- source of the library information from the library information file
-- whose name is given by the parameter Name.
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_ch10.adb
--- sem_ch10.adb 2 Feb 2004 12:31:56 -0000 1.15
+++ sem_ch10.adb 12 Feb 2004 13:26:33 -0000
@@ -1475,8 +1475,12 @@ package body Sem_Ch10 is
end if;
end if;
+ Set_Is_Immediately_Visible (Par_Unit, False);
+
Analyze_Subunit_Context;
+
Re_Install_Parents (Lib_Unit, Par_Unit);
+ Set_Is_Immediately_Visible (Par_Unit);
-- If the context includes a child unit of the parent of the
-- subunit, the parent will have been removed from visibility,
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.21
diff -u -p -r1.21 sem_res.adb
--- sem_res.adb 2 Feb 2004 12:31:59 -0000 1.21
+++ sem_res.adb 12 Feb 2004 13:26:33 -0000
@@ -801,6 +801,22 @@ package body Sem_Res is
Require_Entity (N);
end if;
+ -- If the context expects a value, and the name is a procedure,
+ -- this is most likely a missing 'Access. Do not try to resolve
+ -- the parameterless call, error will be caught when the outer
+ -- call is analyzed.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Procedure
+ and then not Is_Overloaded (N)
+ and then
+ (Nkind (Parent (N)) = N_Parameter_Association
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ then
+ return;
+ end if;
+
-- Rewrite as call if overloadable entity that is (or could be, in
-- the overloaded case) a function call. If we know for sure that
-- the entity is an enumeration literal, we do not rewrite it.
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_util.adb
--- sem_util.adb 13 Jan 2004 11:51:34 -0000 1.20
+++ sem_util.adb 12 Feb 2004 13:26:33 -0000
@@ -4881,17 +4881,28 @@ package body Sem_Util is
or else Sloc (S) = Standard_Location)
and then Is_Overloadable (S)
then
- Error_Msg_Name_1 := Chars (S);
- Error_Msg_Sloc := Sloc (S);
- Error_Msg_NE
- ("missing argument for parameter & " &
- "in call to % declared #", N, Formal);
+ if No (Actuals)
+ and then
+ (Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) = N_Function_Call
+ or else
+ Nkind (Parent (N)) = N_Parameter_Association))
+ then
+ Set_Etype (N, Etype (S));
+ else
+ Error_Msg_Name_1 := Chars (S);
+ Error_Msg_Sloc := Sloc (S);
+ Error_Msg_NE
+ ("missing argument for parameter & " &
+ "in call to % declared #", N, Formal);
+ end if;
elsif Is_Overloadable (S) then
Error_Msg_Name_1 := Chars (S);
- -- Point to type derivation that
- -- generated the operation.
+ -- Point to type derivation that generated the
+ -- operation.
Error_Msg_Sloc := Sloc (Parent (S));
@@ -6358,7 +6369,22 @@ package body Sem_Util is
or else
Ekind (Entity (Expr)) = E_Generic_Procedure)
then
- Error_Msg_N ("found procedure name instead of function!", Expr);
+ if Ekind (Expec_Type) = E_Access_Subprogram_Type then
+ Error_Msg_N
+ ("found procedure name, possibly missing Access attribute!",
+ Expr);
+ else
+ Error_Msg_N ("found procedure name instead of function!", Expr);
+ end if;
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Expec_Type) = E_Access_Subprogram_Type
+ and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
+ and then No (Parameter_Associations (Expr))
+ then
+ Error_Msg_N
+ ("found function name, possibly missing Access attribute!",
+ Expr);
-- catch common error: a prefix or infix operator which is not
-- directly visible because the type isn't.
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.18
diff -u -p -r1.18 snames.ads
--- snames.ads 9 Feb 2004 14:56:04 -0000 1.18
+++ snames.ads 12 Feb 2004 13:26:33 -0000
@@ -751,7 +751,7 @@ package Snames is
-- are added, the first character must be distinct.
First_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 440;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 440;
Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
-- Names of recognized checks for pragma Suppress
Index: usage.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/usage.adb,v
retrieving revision 1.14
diff -u -p -r1.14 usage.adb
--- usage.adb 9 Feb 2004 14:56:05 -0000 1.14
+++ usage.adb 12 Feb 2004 13:26:33 -0000
@@ -134,9 +134,6 @@ begin
Write_Switch_Char ("c");
Write_Line ("Check syntax and semantics only (no code generation)");
- Write_Switch_Char ("C");
- Write_Line ("Compress names in external names and debug info tables");
-
-- Line for -gnatd switch
Write_Switch_Char ("d?");
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-09 12:31 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-09 12:31 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-09 Albert Lee <lee@gnat.com>
* errno.c: define _SGI_MP_SOURCE for task-safe errno on IRIX
2004-02-09 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Build_Slice_Assignment): Handle properly case of null
slices.
* exp_ch6.adb (Expand_Call): Do not inline a call when the subprogram
is nested in an instance that is not frozen yet, to avoid
order-of-elaboration problems in gigi.
* sem_attr.adb (Analyze_Attribute, case 'Access): Within an inlined
body the attribute is legal.
2004-02-09 Robert Dewar <dewar@gnat.com>
* s-rident.ads: Minor comment correction
* targparm.adb: Remove dependence on uintp completely. There was
always a bug in Make in that it called Targparm before initializing
the Uint package. The old code appeared to get away with this, but
the new code did not! This caused an assertion error in gnatmake.
* targparm.ads: Fix bad comment, restriction pragmas with parameters
are indeed fully supported.
--
Index: errno.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/errno.c,v
retrieving revision 1.6
diff -u -p -r1.6 errno.c
--- errno.c 4 Nov 2003 12:51:45 -0000 1.6
+++ errno.c 6 Feb 2004 09:52:38 -0000
@@ -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- *
@@ -39,6 +39,7 @@
#define _REENTRANT
#define _THREAD_SAFE
+#define _SGI_MP_SOURCE
#include <errno.h>
int
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.16
diff -u -p -r1.16 exp_ch3.adb
--- exp_ch3.adb 2 Feb 2004 12:31:50 -0000 1.16
+++ exp_ch3.adb 6 Feb 2004 09:52:39 -0000
@@ -2505,16 +2505,20 @@ package body Exp_Ch3 is
-- end if;
-- loop
+ -- if Rev then
+ -- exit when Li1 < Left_Lo;
+ -- else
+ -- exit when Li1 > Left_Hi;
+ -- end if;
+
-- Target (Li1) := Source (Ri1);
-- if Rev then
- -- exit when Li2 = Left_Lo;
- -- Li2 := Index'pred (Li2);
- -- Ri2 := Index'pred (Ri2);
+ -- Li1 := Index'pred (Li1);
+ -- Ri1 := Index'pred (Ri1);
-- else
- -- exit when Li2 = Left_Hi;
- -- Li2 := Index'succ (Li2);
- -- Ri2 := Index'succ (Ri2);
+ -- Li1 := Index'succ (Li1);
+ -- Ri1 := Index'succ (Ri1);
-- end if;
-- end loop;
-- end Assign;
@@ -2561,7 +2565,6 @@ package body Exp_Ch3 is
Stats : List_Id;
begin
-
-- Build declarations for indices
Decls := New_List;
@@ -2630,7 +2633,7 @@ package body Exp_Ch3 is
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
End_Label => Empty);
- -- Build the increment/decrement statements
+ -- Build exit condition.
declare
F_Ass : constant List_Id := New_List;
@@ -2640,17 +2643,31 @@ package body Exp_Ch3 is
Append_To (F_Ass,
Make_Exit_Statement (Loc,
Condition =>
- Make_Op_Eq (Loc,
+ Make_Op_Gt (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
Append_To (B_Ass,
Make_Exit_Statement (Loc,
Condition =>
- Make_Op_Eq (Loc,
+ Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
+ Prepend_To (Statements (Loops),
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Ass,
+ Else_Statements => F_Ass));
+ end;
+
+ -- Build the increment/decrement statements
+
+ declare
+ F_Ass : constant List_Id := New_List;
+ B_Ass : constant List_Id := New_List;
+
+ begin
Append_To (F_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.19
diff -u -p -r1.19 exp_ch6.adb
--- exp_ch6.adb 2 Feb 2004 12:31:50 -0000 1.19
+++ exp_ch6.adb 6 Feb 2004 09:52:39 -0000
@@ -1915,12 +1915,43 @@ package body Exp_Ch6 is
then
if Is_Inlined (Subp) then
- declare
+ Inlined_Subprogram : declare
Bod : Node_Id;
Must_Inline : Boolean := False;
Spec : constant Node_Id := Unit_Declaration_Node (Subp);
Scop : constant Entity_Id := Scope (Subp);
+ function In_Unfrozen_Instance return Boolean;
+ -- If the subprogram comes from an instance in the same
+ -- unit, and the instance is not yet frozen, inlining might
+ -- trigger order-of-elaboration problems in gigi.
+
+ --------------------------
+ -- In_Unfrozen_Instance --
+ --------------------------
+
+ function In_Unfrozen_Instance return Boolean is
+ S : Entity_Id := Scop;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S)
+ and then Present (Freeze_Node (S))
+ and then not Analyzed (Freeze_Node (S))
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Unfrozen_Instance;
+
+ -- Start of processing for Inlined_Subprogram
+
begin
-- Verify that the body to inline has already been seen,
-- and that if the body is in the current unit the inlining
@@ -1943,14 +1974,7 @@ package body Exp_Ch6 is
then
Must_Inline := False;
- -- If the subprogram comes from an instance in the same
- -- unit, and the instance is not yet frozen, inlining might
- -- trigger order-of-elaboration problems in gigi.
-
- elsif Is_Generic_Instance (Scop)
- and then Present (Freeze_Node (Scop))
- and then not Analyzed (Freeze_Node (Scop))
- then
+ elsif In_Unfrozen_Instance then
Must_Inline := False;
else
@@ -1998,7 +2022,7 @@ package body Exp_Ch6 is
N, Subp);
end if;
end if;
- end;
+ end Inlined_Subprogram;
end if;
end if;
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_attr.adb
--- sem_attr.adb 2 Feb 2004 12:31:56 -0000 1.20
+++ sem_attr.adb 6 Feb 2004 09:52:39 -0000
@@ -605,10 +605,14 @@ package body Sem_Attr is
-- prefix may have been a tagged formal object, which is
-- defined to be aliased even when the actual might not be
-- (other instance cases will have been caught in the generic).
+ -- Similarly, within an inlined body we know that the attribute
+ -- is legal in the original subprogram, and therefore legal in
+ -- the expansion.
if Aname /= Name_Unrestricted_Access
and then not Is_Aliased_View (P)
and then not In_Instance
+ and then not In_Inlined_Body
then
Error_Attr ("prefix of % attribute must be aliased", P);
end if;
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.4
diff -u -p -r1.4 s-rident.ads
--- s-rident.ads 4 Feb 2004 11:06:19 -0000 1.4
+++ s-rident.ads 6 Feb 2004 09:52:39 -0000
@@ -155,7 +155,6 @@ package System.Rident is
-- Synonyms permitted for historical purposes of compatibility
-- No_Requeue synonym for No_Requeue_Statements
- -- No_Tasking synonym for Max_Tasks => 0
-- No_Task_Attributes synonym for No_Task_Attributes_Package
subtype All_Restrictions is Restriction_Id range
Index: targparm.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.adb,v
retrieving revision 1.8
diff -u -p -r1.8 targparm.adb
--- targparm.adb 2 Feb 2004 12:32:01 -0000 1.8
+++ targparm.adb 6 Feb 2004 09:52:39 -0000
@@ -29,7 +29,6 @@ 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;
@@ -193,7 +192,7 @@ package body Targparm is
Source_Last : Source_Ptr)
is
P : Source_Ptr;
- V : Uint;
+ -- Scans source buffer containing source of system.ads
Fatal : Boolean := False;
-- Set True if a fatal error is detected
@@ -221,7 +220,7 @@ package body Targparm is
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
- Rloop : for K in Partition_Boolean_Restrictions loop
+ Rloop : for K in All_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
@@ -249,6 +248,9 @@ package body Targparm is
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
+ V : Natural;
+ -- Accumulates value
+
begin
for J in Rname'Range loop
if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
@@ -262,22 +264,36 @@ package body Targparm is
" => "
then
P := P + Rname'Length + 4;
- V := Uint_0;
+ V := 0;
loop
if System_Text (P) in '0' .. '9' then
- V := 10 * V + Character'Pos (System_Text (P)) - 48;
+ declare
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ -- Accumulate next digit
+
+ V := 10 * V +
+ Character'Pos (System_Text (P)) -
+ Character'Pos ('0');
+
+ exception
+ -- On overflow, we just ignore the pragma since
+ -- that is the standard handling in this case.
+
+ when Constraint_Error =>
+ goto Line_Loop_Continue;
+ end;
+
elsif System_Text (P) = '_' then
null;
+
elsif System_Text (P) = ')' then
- 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;
+ Restrictions_On_Target.Value (K) := V;
+ Restrictions_On_Target.Set (K) := True;
+ goto Line_Loop_Continue;
+
else
exit Ploop;
end if;
Index: targparm.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.ads,v
retrieving revision 1.8
diff -u -p -r1.8 targparm.ads
--- targparm.ads 2 Feb 2004 12:32:01 -0000 1.8
+++ targparm.ads 6 Feb 2004 09:52:39 -0000
@@ -104,9 +104,10 @@ package Targparm is
-- if a pragma Suppress_Exception_Locations appears, then the flag
-- Opt.Exception_Locations_Suppressed is set to True.
- -- 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.Restriction_Info).
+ -- The only other pragma allowed is a pragma Restrictions that specifies
+ -- a restriction that will be imposed on all units in the partition. Note
+ -- that in this context, only one restriction can be specified in a single
+ -- pragma, and the pragma must appear on its own on a single source line.
Restrictions_On_Target : Restrictions_Info;
-- Records restrictions specified by system.ads. Only the Set and Value
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-04 11:07 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-04 11:07 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-02-04 Robert Dewar <dewar@gnat.com>
* 5gtasinf.adb, 5gtasinf.ads, 5gtaprop.adb, ali.adb,
ali.ads, gprcmd.adb: Minor reformatting
* bindgen.adb: Output restrictions string for new style restrictions
handling
* impunit.adb: Add s-rident.ads (System.Rident) and
s-restri (System.Restrictions)
* lib-writ.adb: Fix bug in writing restrictions string (last few
entries wrong)
* s-restri.ads, s-restri.adb: Change name Restrictions to
Run_Time_Restrictions to avoid conflict with package name.
Add circuit to read and acquire run time restrictions.
2004-02-04 Jose Ruiz <ruiz@act-europe.fr>
* restrict.ads, restrict.adb: Use the new restriction
No_Task_Attributes_Package instead of the old No_Task_Attributes.
* sem_prag.adb: No_Task_Attributes is a synonym of
No_Task_Attributes_Package.
* snames.ads, snames.adb: New entry for proper handling of
No_Task_Attributes.
* s-rident.ads: Adding restriction No_Task_Attributes_Package
(AI-00249) that supersedes the GNAT specific restriction
No_Task_Attributes.
2004-02-04 Ed Schonberg <schonberg@gnat.com>
* sem_prag.adb:
(Analyze_Pragma, case Warnings): In an inlined body, as in an instance
body, an identifier may be wrapped in an unchecked conversion.
2004-02-04 Vincent Celier <celier@gnat.com>
* lib-writ.ads: Comment update for the W lines
* bld.adb: (Expression): An empty string list is static
* fname-uf.adb: Minor comment update
* fname-uf.ads: (Get_File_Name): Document new parameter May_Fail
* gnatbind.adb:
Initialize Cumulative_Restrictions with the restrictions on the target
--
Index: 5gtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtaprop.adb,v
retrieving revision 1.9
diff -u -p -r1.9 5gtaprop.adb
--- 5gtaprop.adb 26 Jan 2004 21:56:05 -0000 1.9
+++ 5gtaprop.adb 4 Feb 2004 09:48:40 -0000
@@ -141,7 +141,6 @@ package body System.Task_Primitives.Oper
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
@@ -251,7 +250,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -259,7 +257,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -271,10 +268,8 @@ package body System.Task_Primitives.Oper
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_lock (L);
-
Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
pragma Assert (Result /= FUNC_ERR);
end Write_Lock;
@@ -283,7 +278,6 @@ package body System.Task_Primitives.Oper
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -293,7 +287,6 @@ package body System.Task_Primitives.Oper
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -316,7 +309,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
@@ -324,7 +316,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -334,7 +325,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -543,7 +533,6 @@ package body System.Task_Primitives.Oper
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
@@ -813,10 +802,8 @@ package body System.Task_Primitives.Oper
procedure Exit_Task is
Result : Interfaces.C.int;
-
begin
Result := pthread_set_ada_tcb (pthread_self, System.Null_Address);
-
pragma Assert (Result = 0);
end Exit_Task;
@@ -826,7 +813,6 @@ package body System.Task_Primitives.Oper
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result :=
pthread_kill (T.Common.LL.Thread,
@@ -854,7 +840,6 @@ package body System.Task_Primitives.Oper
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
@@ -961,8 +946,9 @@ package body System.Task_Primitives.Oper
if Result = FUNC_ERR then
raise Storage_Error; -- Insufficient resources.
end if;
-
end Initialize_Athread_Library;
+
+-- Package initialization
begin
Initialize_Athread_Library;
Index: 5gtasinf.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtasinf.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5gtasinf.adb
--- 5gtasinf.adb 26 Jan 2004 21:56:05 -0000 1.6
+++ 5gtasinf.adb 4 Feb 2004 09:48:40 -0000
@@ -77,16 +77,14 @@ package body System.Task_Info is
---------
function "+" (R : Resource_T) return Resource_Vector_T is
- Result : Resource_Vector_T := NO_RESOURCES;
-
+ Result : Resource_Vector_T := NO_RESOURCES;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
end "+";
function "+" (R1, R2 : Resource_T) return Resource_Vector_T is
- Result : Resource_Vector_T := NO_RESOURCES;
-
+ Result : Resource_Vector_T := NO_RESOURCES;
begin
Result (Resource_T'Pos (R1)) := True;
Result (Resource_T'Pos (R2)) := True;
@@ -94,44 +92,37 @@ package body System.Task_Info is
end "+";
function "+"
- (R : Resource_T;
- S : Resource_Vector_T)
- return Resource_Vector_T
+ (R : Resource_T;
+ S : Resource_Vector_T) return Resource_Vector_T
is
- Result : Resource_Vector_T := S;
-
+ Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
end "+";
function "+"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T
is
- Result : Resource_Vector_T := S;
-
+ Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
end "+";
function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is
- Result : Resource_Vector_T;
-
+ Result : Resource_Vector_T;
begin
Result := S1 or S2;
return Result;
end "+";
function "-"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T
is
- Result : Resource_Vector_T := S;
-
+ Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := False;
return Result;
@@ -177,21 +168,23 @@ package body System.Task_Info is
end if;
if Attr.NDPRI /= NDP_NONE then
--- ??? why is that comment out, should it be removed ?
+
+-- ??? why is this commented out, should it be removed ?
-- if Geteuid /= 0 then
-- raise Permission_Error;
-- end if;
- Status := sproc_attr_setprio
- (Sproc_Attr'Unrestricted_Access,
- int (Attr.NDPRI));
+ Status :=
+ sproc_attr_setprio
+ (Sproc_Attr'Unrestricted_Access, int (Attr.NDPRI));
end if;
- Status := sproc_create
- (Sproc'Unrestricted_Access,
- Sproc_Attr'Unrestricted_Access,
- null,
- System.Null_Address);
+ Status :=
+ sproc_create
+ (Sproc'Unrestricted_Access,
+ Sproc_Attr'Unrestricted_Access,
+ null,
+ System.Null_Address);
if Status /= 0 then
Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
@@ -199,7 +192,6 @@ package body System.Task_Info is
end if;
Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
-
end if;
if Status /= 0 then
@@ -217,12 +209,10 @@ package body System.Task_Info is
(Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
- NDPRI : Non_Degrading_Priority := NDP_NONE)
- return sproc_t
+ NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t
is
Attr : constant Sproc_Attributes :=
- (Sproc_Resources, CPU, Resident, NDPRI);
-
+ (Sproc_Resources, CPU, Resident, NDPRI);
begin
return New_Sproc (Attr);
end New_Sproc;
@@ -233,8 +223,7 @@ package body System.Task_Info is
function Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
- Thread_Timeslice : Duration := 0.0)
- return Thread_Attributes
+ Thread_Timeslice : Duration := 0.0) return Thread_Attributes
is
begin
return (False, Thread_Resources, Thread_Timeslice);
@@ -265,11 +254,10 @@ package body System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Thread_Attributes
+ return Thread_Attributes
is
Sproc : constant sproc_t := New_Sproc
- (Sproc_Resources, CPU, Resident, NDPRI);
-
+ (Sproc_Resources, CPU, Resident, NDPRI);
begin
return (True, Thread_Resources, Thread_Timeslice, Sproc);
end Bound_Thread_Attributes;
@@ -280,8 +268,7 @@ package body System.Task_Info is
function New_Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
- Thread_Timeslice : Duration := 0.0)
- return Task_Info_Type
+ Thread_Timeslice : Duration := 0.0) return Task_Info_Type
is
begin
return new Thread_Attributes'
@@ -295,8 +282,7 @@ package body System.Task_Info is
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
- Sproc : sproc_t)
- return Task_Info_Type
+ Sproc : sproc_t) return Task_Info_Type
is
begin
return new Thread_Attributes'
@@ -314,11 +300,10 @@ package body System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Task_Info_Type
+ return Task_Info_Type
is
Sproc : constant sproc_t := New_Sproc
- (Sproc_Resources, CPU, Resident, NDPRI);
-
+ (Sproc_Resources, CPU, Resident, NDPRI);
begin
return new Thread_Attributes'
(True, Thread_Resources, Thread_Timeslice, Sproc);
Index: 5gtasinf.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtasinf.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5gtasinf.ads
--- 5gtasinf.ads 21 Oct 2003 13:41:51 -0000 1.6
+++ 5gtasinf.ads 4 Feb 2004 09:48:40 -0000
@@ -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- --
@@ -63,14 +63,14 @@ package System.Task_Info is
-- Each thread has a number of attributes that dictate it's scheduling.
-- These attributes are:
- --
+
-- Bound_To_Sproc: whether the thread is bound to a specific sproc
-- for its entire lifetime.
- --
+
-- Timeslice: Amount of time that a thread is allowed to execute
-- before the system yeilds control to another thread
-- of equal priority.
- --
+
-- Resource_Vector: A bitmask used to control the binding of threads
-- to sprocs.
--
@@ -113,33 +113,27 @@ package System.Task_Info is
package Resource_Vector_Functions is
function "+"
- (R : Resource_T)
- return Resource_Vector_T;
+ (R : Resource_T) return Resource_Vector_T;
function "+"
- (R1 : Resource_T;
- R2 : Resource_T)
- return Resource_Vector_T;
+ (R1 : Resource_T;
+ R2 : Resource_T) return Resource_Vector_T;
function "+"
- (R : Resource_T;
- S : Resource_Vector_T)
- return Resource_Vector_T;
+ (R : Resource_T;
+ S : Resource_Vector_T) return Resource_Vector_T;
function "+"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T;
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T;
function "+"
- (S1 : Resource_Vector_T;
- S2 : Resource_Vector_T)
- return Resource_Vector_T;
+ (S1 : Resource_Vector_T;
+ S2 : Resource_Vector_T) return Resource_Vector_T;
function "-"
- (S : Resource_Vector_T;
- R : Resource_T)
- return Resource_Vector_T;
+ (S : Resource_Vector_T;
+ R : Resource_T) return Resource_Vector_T;
end Resource_Vector_Functions;
----------------------
@@ -208,8 +202,7 @@ package System.Task_Info is
(Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
- NDPRI : Non_Degrading_Priority := NDP_NONE)
- return sproc_t;
+ NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t;
-- Allocates a sproc_t control structure and creates the
-- corresponding sproc.
@@ -239,14 +232,12 @@ package System.Task_Info is
function Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
- Thread_Timeslice : Duration := 0.0)
- return Thread_Attributes;
+ Thread_Timeslice : Duration := 0.0) return Thread_Attributes;
function Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
- Sproc : sproc_t)
- return Thread_Attributes;
+ Sproc : sproc_t) return Thread_Attributes;
function Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
@@ -255,20 +246,19 @@ package System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Thread_Attributes;
+ return Thread_Attributes;
type Task_Info_Type is access all Thread_Attributes;
function New_Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0)
- return Task_Info_Type;
+ return Task_Info_Type;
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
- Sproc : sproc_t)
- return Task_Info_Type;
+ Sproc : sproc_t) return Task_Info_Type;
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
@@ -277,7 +267,7 @@ package System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
- return Task_Info_Type;
+ return Task_Info_Type;
Unspecified_Task_Info : constant Task_Info_Type := null;
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.13
diff -u -p -r1.13 ali.adb
--- ali.adb 2 Feb 2004 12:31:47 -0000 1.13
+++ ali.adb 4 Feb 2004 09:48:40 -0000
@@ -24,13 +24,13 @@
-- --
------------------------------------------------------------------------------
-with Butil; use Butil;
-with Debug; use Debug;
-with Fname; use Fname;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
+with Butil; use Butil;
+with Debug; use Debug;
+with Fname; use Fname;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
package body ALI is
@@ -105,8 +105,7 @@ package body ALI is
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
- Ignore_Lines : String := "X")
- return ALI_Id
+ Ignore_Lines : String := "X") return ALI_Id
is
P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
@@ -328,8 +327,10 @@ package body ALI is
-- Get_Name --
--------------
- function Get_Name (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id is
+ function Get_Name
+ (Lower : Boolean := False;
+ Ignore_Spaces : Boolean := False) return Name_Id
+ is
begin
Name_Len := 0;
Skip_Space;
Index: ali.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.ads,v
retrieving revision 1.12
diff -u -p -r1.12 ali.ads
--- ali.ads 2 Feb 2004 12:31:47 -0000 1.12
+++ ali.ads 4 Feb 2004 09:48:40 -0000
@@ -814,8 +814,7 @@ package ALI is
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
- Ignore_Lines : String := "X")
- return ALI_Id;
+ Ignore_Lines : String := "X") return ALI_Id;
-- Given the text, T, of an ALI file, F, scan and store the information
-- from the file, and return the Id of the resulting entry in the ALI
-- table. Switch settings may be modified as described above in the
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.19
diff -u -p -r1.19 bindgen.adb
--- bindgen.adb 2 Feb 2004 12:31:47 -0000 1.19
+++ bindgen.adb 4 Feb 2004 09:48:40 -0000
@@ -141,6 +141,16 @@ package body Bindgen is
procedure Gen_Output_File_C (Filename : String);
-- Generate output file (C code case)
+ procedure Gen_Restrictions_String_1;
+ -- Generate first restrictions string, which consists of the parameters
+ -- the first R line, as described in lib-writ.ads, with the restrictions
+ -- being those for the entire partition (from Cumulative_Restrictions).
+
+ procedure Gen_Restrictions_String_2;
+ -- Generate first restrictions string, which consists of the parameters
+ -- the second R line, as described in lib-writ.ads, with the restrictions
+ -- being those for the entire partition (from Cumulative_Restrictions).
+
procedure Gen_Versions_Ada;
-- Output series of definitions for unit versions (Ada code case)
@@ -358,13 +368,15 @@ package body Bindgen is
Set_String (" Restrictions : constant String :=");
Write_Statement_Buffer;
- Set_String (" """);
- for J in All_Restrictions loop
- null;
- end loop;
+ Set_String (" """);
+ Gen_Restrictions_String_1;
+ Set_String (""" &");
+ Write_Statement_Buffer;
- Set_String (""";");
+ Set_String (" """);
+ Gen_Restrictions_String_2;
+ Set_String (""" & ASCII.Nul;");
Write_Statement_Buffer;
WBI ("");
@@ -606,11 +618,8 @@ package body Bindgen is
-- Generate definition for restrictions string
Set_String (" const char *restrictions = """);
-
- for J in All_Restrictions loop
- null;
- end loop;
-
+ Gen_Restrictions_String_1;
+ Gen_Restrictions_String_2;
Set_String (""";");
Write_Statement_Buffer;
@@ -2452,6 +2461,52 @@ package body Bindgen is
Close_Binder_Output;
end Gen_Output_File_C;
+
+ -------------------------------
+ -- Gen_Restrictions_String_1 --
+ -------------------------------
+
+ procedure Gen_Restrictions_String_1 is
+ begin
+ for R in All_Boolean_Restrictions loop
+ if Cumulative_Restrictions.Set (R) then
+ Set_Char ('r');
+ elsif Cumulative_Restrictions.Violated (R) then
+ Set_Char ('v');
+ else
+ Set_Char ('n');
+ end if;
+ end loop;
+ end Gen_Restrictions_String_1;
+
+ -------------------------------
+ -- Gen_Restrictions_String_2 --
+ -------------------------------
+
+ procedure Gen_Restrictions_String_2 is
+ begin
+ for RP in All_Parameter_Restrictions loop
+ if Cumulative_Restrictions.Set (RP) then
+ Set_Char ('r');
+ Set_Int (Int (Cumulative_Restrictions.Value (RP)));
+ else
+ Set_Char ('n');
+ end if;
+
+ if not Cumulative_Restrictions.Violated (RP)
+ or else RP not in Checked_Parameter_Restrictions
+ then
+ Set_Char ('n');
+ else
+ Set_Char ('v');
+ Set_Int (Int (Cumulative_Restrictions.Count (RP)));
+
+ if Cumulative_Restrictions.Unknown (RP) then
+ Set_Char ('+');
+ end if;
+ end if;
+ end loop;
+ end Gen_Restrictions_String_2;
----------------------
-- Gen_Versions_Ada --
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.6
diff -u -p -r1.6 bld.adb
--- bld.adb 12 Jan 2004 11:36:12 -0000 1.6
+++ bld.adb 4 Feb 2004 09:48:40 -0000
@@ -525,11 +525,16 @@ package body Bld is
First_Expression_In_List (Current_Term);
begin
- if String_Node /= Empty_Node then
+ if String_Node = Empty_Node then
-- If String_Node is nil, it is an empty list,
- -- there is nothing to do
+ -- set Expression_Kind if it is still Undecided
+ if Expression_Kind = Undecided then
+ Expression_Kind := Static_String;
+ end if;
+
+ else
Expression
(Project => Project,
First_Term => Tree.First_Term (String_Node),
Index: fname-uf.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.adb,v
retrieving revision 1.10
diff -u -p -r1.10 fname-uf.adb
--- fname-uf.adb 2 Feb 2004 12:31:51 -0000 1.10
+++ fname-uf.adb 4 Feb 2004 09:48:40 -0000
@@ -123,8 +123,8 @@ package body Fname.UF is
-------------------
function Get_File_Name
- (Uname : Unit_Name_Type;
- Subunit : Boolean;
+ (Uname : Unit_Name_Type;
+ Subunit : Boolean;
May_Fail : Boolean := False) return File_Name_Type
is
Unit_Char : Character;
@@ -387,12 +387,12 @@ package body Fname.UF is
-- If we are in the second search of the table, we accept
-- the file name without checking, because we know that
- -- the file does not exist.
+ -- the file does not exist, except when May_Fail is True,
+ -- in which case we return No_File.
if No_File_Check then
if May_Fail then
return No_File;
-
else
return Fnam;
end if;
Index: fname-uf.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.ads,v
retrieving revision 1.6
diff -u -p -r1.6 fname-uf.ads
--- fname-uf.ads 2 Feb 2004 12:31:51 -0000 1.6
+++ fname-uf.ads 4 Feb 2004 09:48:40 -0000
@@ -44,14 +44,18 @@ package Fname.UF is
-----------------
function Get_File_Name
- (Uname : Unit_Name_Type;
- Subunit : Boolean;
+ (Uname : Unit_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
-- ensuring that the unit name meets the requirements given in package
-- Uname and described above.
+ -- When May_Fail is True, if the file cannot be found, this function
+ -- returns No_File. When it is False, if the file cannot be found,
+ -- a file name compatible with one pattern Source_File_Name pragma is
+ -- returned.
procedure Initialize;
-- Initialize internal tables. This is called automatically when the
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnatbind.adb
--- gnatbind.adb 2 Feb 2004 12:31:52 -0000 1.10
+++ gnatbind.adb 4 Feb 2004 09:48:40 -0000
@@ -447,6 +447,12 @@ begin
Targparm.Get_Target_Parameters;
+ -- Initialize Cumulative_Restrictions with the restrictions on the target
+ -- scanned from the system.ads file. Then as we read ALI files, we will
+ -- accumulate additional restrictions specified in other files.
+
+ Cumulative_Restrictions := Targparm.Restrictions_On_Target;
+
-- On OpenVMS, when -L is used, all external names used in pragmas Export
-- are in upper case. The reason is that on OpenVMS, the macro-assembler
-- MACASM-32, used to build Stand-Alone Libraries, only understands
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.6
diff -u -p -r1.6 gprcmd.adb
--- gprcmd.adb 2 Feb 2004 12:31:53 -0000 1.6
+++ gprcmd.adb 4 Feb 2004 09:48:40 -0000
@@ -113,6 +113,7 @@ procedure Gprcmd is
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;
@@ -473,9 +474,9 @@ begin
end if;
end;
- else
- -- Uknown command
+ -- Unknown command
+ else
Check_Args (False);
end if;
end;
Index: impunit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/impunit.adb,v
retrieving revision 1.10
diff -u -p -r1.10 impunit.adb
--- impunit.adb 12 Jan 2004 11:45:24 -0000 1.10
+++ impunit.adb 4 Feb 2004 09:48:40 -0000
@@ -297,6 +297,8 @@ package body Impunit is
"s-assert", -- System.Assertions
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
+ "s-restri", -- System.Restrictions
+ "s-rident", -- System.Rident
"s-tasinf", -- System.Task_Info
"s-wchcnv", -- System.Wch_Cnv
"s-wchcon"); -- System.Wch_Con
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.13
diff -u -p -r1.13 lib-writ.adb
--- lib-writ.adb 2 Feb 2004 12:31:53 -0000 1.13
+++ lib-writ.adb 4 Feb 2004 09:48:40 -0000
@@ -691,7 +691,7 @@ package body Lib.Writ is
end loop;
end Write_With_Lines;
- -- Start of processing for Writ_ALI
+ -- Start of processing for Write_ALI
begin
-- We never write an ALI file if the original operating mode was
@@ -919,7 +919,6 @@ package body Lib.Writ is
then
if not Has_No_Elaboration_Code (Cunit (Unit)) then
Main_Restrictions.Violated (No_Elaboration_Code) := True;
- Main_Restrictions.Count (No_Elaboration_Code) := -1;
end if;
end if;
end loop;
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.10
diff -u -p -r1.10 lib-writ.ads
--- lib-writ.ads 2 Feb 2004 12:31:54 -0000 1.10
+++ lib-writ.ads 4 Feb 2004 09:48:40 -0000
@@ -406,11 +406,13 @@ package Lib.Writ is
-- One of these lines is present for each unit that is mentioned in
-- an explicit with clause by the current unit. The first parameter
-- is the unit name in internal format. The second parameter is the
- -- file name of the file that must be compiled to compile this unit
- -- (which is usually the file for the body, except for packages
- -- which have no body). The third parameter is the file name of the
- -- library information file that contains the results of compiling
- -- this unit. The optional modifiers are used as follows:
+ -- file name of the file that must be compiled to compile this unit.
+ -- It is usually the file for the body, except for packages
+ -- which have no body; for units that need a body, if the source file
+ -- for the body cannot be found, the file name of the spec is used
+ -- instead. The third parameter is the file name of the library
+ -- information file that contains the results of compiling this unit.
+ -- The optional modifiers are used as follows:
--
-- E pragma Elaborate applies to this unit
--
Index: restrict.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.adb,v
retrieving revision 1.9
diff -u -p -r1.9 restrict.adb
--- restrict.adb 2 Feb 2004 12:31:55 -0000 1.9
+++ restrict.adb 4 Feb 2004 09:48:40 -0000
@@ -372,7 +372,7 @@ package body Restrict is
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 (No_Task_Attributes_Package)
and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
and then Restrictions.Set (Max_Task_Entries)
and then Restrictions.Set (Max_Protected_Entries)
@@ -472,7 +472,7 @@ package body Restrict is
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_Restriction (No_Task_Attributes_Package, N);
-- Set parameter restrictions
Index: restrict.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.ads,v
retrieving revision 1.7
diff -u -p -r1.7 restrict.ads
--- restrict.ads 2 Feb 2004 12:31:56 -0000 1.7
+++ restrict.ads 4 Feb 2004 09:48:40 -0000
@@ -77,27 +77,27 @@ package Restrict is
end record;
Unit_Array : constant array (Positive range <>) of Unit_Entry := (
- (No_Asynchronous_Control, "a-astaco"),
- (No_Calendar, "a-calend"),
- (No_Calendar, "calendar"),
- (No_Delay, "a-calend"),
- (No_Delay, "calendar"),
- (No_Dynamic_Priorities, "a-dynpri"),
- (No_Finalization, "a-finali"),
- (No_IO, "a-direio"),
- (No_IO, "directio"),
- (No_IO, "a-sequio"),
- (No_IO, "sequenio"),
- (No_IO, "a-ststio"),
- (No_IO, "a-textio"),
- (No_IO, "text_io "),
- (No_IO, "a-witeio"),
- (No_Task_Attributes, "a-tasatt"),
- (No_Streams, "a-stream"),
- (No_Unchecked_Conversion, "a-unccon"),
- (No_Unchecked_Conversion, "unchconv"),
- (No_Unchecked_Deallocation, "a-uncdea"),
- (No_Unchecked_Deallocation, "unchdeal"));
+ (No_Asynchronous_Control, "a-astaco"),
+ (No_Calendar, "a-calend"),
+ (No_Calendar, "calendar"),
+ (No_Delay, "a-calend"),
+ (No_Delay, "calendar"),
+ (No_Dynamic_Priorities, "a-dynpri"),
+ (No_Finalization, "a-finali"),
+ (No_IO, "a-direio"),
+ (No_IO, "directio"),
+ (No_IO, "a-sequio"),
+ (No_IO, "sequenio"),
+ (No_IO, "a-ststio"),
+ (No_IO, "a-textio"),
+ (No_IO, "text_io "),
+ (No_IO, "a-witeio"),
+ (No_Task_Attributes_Package, "a-tasatt"),
+ (No_Streams, "a-stream"),
+ (No_Unchecked_Conversion, "a-unccon"),
+ (No_Unchecked_Conversion, "unchconv"),
+ (No_Unchecked_Deallocation, "a-uncdea"),
+ (No_Unchecked_Deallocation, "unchdeal"));
-- The following map has True for all GNAT pragmas. It is used to
-- implement pragma Restrictions (No_Implementation_Restrictions)
@@ -123,7 +123,7 @@ package Restrict is
No_Select_Statements => True,
No_Standard_Storage_Pools => True,
No_Streams => True,
- No_Task_Attributes => True,
+ No_Task_Attributes_Package => True,
No_Task_Termination => True,
No_Wide_Characters => True,
Static_Priorities => True,
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.18
diff -u -p -r1.18 sem_prag.adb
--- sem_prag.adb 2 Feb 2004 12:31:58 -0000 1.18
+++ sem_prag.adb 4 Feb 2004 09:48:41 -0000
@@ -3280,6 +3280,15 @@ package body Sem_Prag is
Set_Restriction (No_Requeue_Statements, N);
Set_Warning (No_Requeue_Statements);
+ -- No_Task_Attributes is a synonym for
+ -- No_Task_Attributes_Package
+
+ elsif Chars (Expr) = Name_No_Task_Attributes then
+ Check_Restriction
+ (No_Implementation_Restrictions, Arg);
+ Set_Restriction (No_Task_Attributes_Package, N);
+ Set_Warning (No_Task_Attributes_Package);
+
-- Normal processing for all other cases
else
@@ -9648,7 +9657,8 @@ package body Sem_Prag is
-- the formal may be wrapped in a conversion if the actual
-- is a conversion. Retrieve the real entity name.
- if In_Instance_Body
+ if (In_Instance_Body
+ or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.16
diff -u -p -r1.16 snames.adb
--- snames.adb 2 Feb 2004 12:32:00 -0000 1.16
+++ snames.adb 4 Feb 2004 09:48:41 -0000
@@ -335,6 +335,7 @@ package body Snames is
"parameter_types#" &
"reference#" &
"no_requeue#" &
+ "no_task_attributes#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.16
diff -u -p -r1.16 snames.ads
--- snames.ads 2 Feb 2004 12:32:00 -0000 1.16
+++ snames.ads 4 Feb 2004 09:48:41 -0000
@@ -524,33 +524,34 @@ package Snames is
Name_Parameter_Types : constant Name_Id := N + 275;
Name_Reference : constant Name_Id := N + 276;
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;
+ Name_No_Task_Attributes : constant Name_Id := N + 278;
+ Name_Restricted : constant Name_Id := N + 279;
+ Name_Result_Mechanism : constant Name_Id := N + 280;
+ Name_Result_Type : constant Name_Id := N + 281;
+ Name_Runtime : constant Name_Id := N + 282;
+ Name_SB : constant Name_Id := N + 283;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 284;
+ Name_Section : constant Name_Id := N + 285;
+ Name_Semaphore : constant Name_Id := N + 286;
+ Name_Spec_File_Name : constant Name_Id := N + 287;
+ Name_Static : constant Name_Id := N + 288;
+ Name_Stack_Size : constant Name_Id := N + 289;
+ Name_Subunit_File_Name : constant Name_Id := N + 290;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 291;
+ Name_Task_Type : constant Name_Id := N + 292;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 293;
+ Name_Top_Guard : constant Name_Id := N + 294;
+ Name_UBA : constant Name_Id := N + 295;
+ Name_UBS : constant Name_Id := N + 296;
+ Name_UBSB : constant Name_Id := N + 297;
+ Name_Unit_Name : constant Name_Id := N + 298;
+ Name_Unknown : constant Name_Id := N + 299;
+ Name_Unrestricted : constant Name_Id := N + 300;
+ Name_Uppercase : constant Name_Id := N + 301;
+ Name_User : constant Name_Id := N + 302;
+ Name_VAX_Float : constant Name_Id := N + 303;
+ Name_VMS : constant Name_Id := N + 304;
+ Name_Working_Storage : constant Name_Id := N + 305;
-- 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
@@ -564,158 +565,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 + 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
+ First_Attribute_Name : constant Name_Id := N + 306;
+ Name_Abort_Signal : constant Name_Id := N + 306; -- GNAT
+ Name_Access : constant Name_Id := N + 307;
+ Name_Address : constant Name_Id := N + 308;
+ Name_Address_Size : constant Name_Id := N + 309; -- GNAT
+ Name_Aft : constant Name_Id := N + 310;
+ Name_Alignment : constant Name_Id := N + 311;
+ Name_Asm_Input : constant Name_Id := N + 312; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 313; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 314; -- VMS
+ Name_Bit : constant Name_Id := N + 315; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 316;
+ Name_Bit_Position : constant Name_Id := N + 317; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 318;
+ Name_Callable : constant Name_Id := N + 319;
+ Name_Caller : constant Name_Id := N + 320;
+ Name_Code_Address : constant Name_Id := N + 321; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 322;
+ Name_Compose : constant Name_Id := N + 323;
+ Name_Constrained : constant Name_Id := N + 324;
+ Name_Count : constant Name_Id := N + 325;
+ Name_Default_Bit_Order : constant Name_Id := N + 326; -- GNAT
+ Name_Definite : constant Name_Id := N + 327;
+ Name_Delta : constant Name_Id := N + 328;
+ Name_Denorm : constant Name_Id := N + 329;
+ Name_Digits : constant Name_Id := N + 330;
+ Name_Elaborated : constant Name_Id := N + 331; -- GNAT
+ Name_Emax : constant Name_Id := N + 332; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 333; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 334; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 335;
+ Name_External_Tag : constant Name_Id := N + 336;
+ Name_First : constant Name_Id := N + 337;
+ Name_First_Bit : constant Name_Id := N + 338;
+ Name_Fixed_Value : constant Name_Id := N + 339; -- GNAT
+ Name_Fore : constant Name_Id := N + 340;
+ Name_Has_Discriminants : constant Name_Id := N + 341; -- GNAT
+ Name_Identity : constant Name_Id := N + 342;
+ Name_Img : constant Name_Id := N + 343; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 344; -- GNAT
+ Name_Large : constant Name_Id := N + 345; -- Ada 83
+ Name_Last : constant Name_Id := N + 346;
+ Name_Last_Bit : constant Name_Id := N + 347;
+ Name_Leading_Part : constant Name_Id := N + 348;
+ Name_Length : constant Name_Id := N + 349;
+ Name_Machine_Emax : constant Name_Id := N + 350;
+ Name_Machine_Emin : constant Name_Id := N + 351;
+ Name_Machine_Mantissa : constant Name_Id := N + 352;
+ Name_Machine_Overflows : constant Name_Id := N + 353;
+ Name_Machine_Radix : constant Name_Id := N + 354;
+ Name_Machine_Rounds : constant Name_Id := N + 355;
+ Name_Machine_Size : constant Name_Id := N + 356; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 357; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 358;
+ Name_Maximum_Alignment : constant Name_Id := N + 359; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 360; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 361;
+ Name_Model_Epsilon : constant Name_Id := N + 362;
+ Name_Model_Mantissa : constant Name_Id := N + 363;
+ Name_Model_Small : constant Name_Id := N + 364;
+ Name_Modulus : constant Name_Id := N + 365;
+ Name_Null_Parameter : constant Name_Id := N + 366; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 367; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 368;
+ Name_Passed_By_Reference : constant Name_Id := N + 369; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 370;
+ Name_Pos : constant Name_Id := N + 371;
+ Name_Position : constant Name_Id := N + 372;
+ Name_Range : constant Name_Id := N + 373;
+ Name_Range_Length : constant Name_Id := N + 374; -- GNAT
+ Name_Round : constant Name_Id := N + 375;
+ Name_Safe_Emax : constant Name_Id := N + 376; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 377;
+ Name_Safe_Large : constant Name_Id := N + 378; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 379;
+ Name_Safe_Small : constant Name_Id := N + 380; -- Ada 83
+ Name_Scale : constant Name_Id := N + 381;
+ Name_Scaling : constant Name_Id := N + 382;
+ Name_Signed_Zeros : constant Name_Id := N + 383;
+ Name_Size : constant Name_Id := N + 384;
+ Name_Small : constant Name_Id := N + 385;
+ Name_Storage_Size : constant Name_Id := N + 386;
+ Name_Storage_Unit : constant Name_Id := N + 387; -- GNAT
+ Name_Tag : constant Name_Id := N + 388;
+ Name_Target_Name : constant Name_Id := N + 389; -- GNAT
+ Name_Terminated : constant Name_Id := N + 390;
+ Name_To_Address : constant Name_Id := N + 391; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 392; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 393; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 394;
+ Name_Unchecked_Access : constant Name_Id := N + 395;
+ Name_Unconstrained_Array : constant Name_Id := N + 396;
+ Name_Universal_Literal_String : constant Name_Id := N + 397; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 398; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 399; -- GNAT
+ Name_Val : constant Name_Id := N + 400;
+ Name_Valid : constant Name_Id := N + 401;
+ Name_Value_Size : constant Name_Id := N + 402; -- GNAT
+ Name_Version : constant Name_Id := N + 403;
+ Name_Wchar_T_Size : constant Name_Id := N + 404; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 405;
+ Name_Width : constant Name_Id := N + 406;
+ Name_Word_Size : constant Name_Id := N + 407; -- 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 + 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;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 408;
+ Name_Adjacent : constant Name_Id := N + 408;
+ Name_Ceiling : constant Name_Id := N + 409;
+ Name_Copy_Sign : constant Name_Id := N + 410;
+ Name_Floor : constant Name_Id := N + 411;
+ Name_Fraction : constant Name_Id := N + 412;
+ Name_Image : constant Name_Id := N + 413;
+ Name_Input : constant Name_Id := N + 414;
+ Name_Machine : constant Name_Id := N + 415;
+ Name_Max : constant Name_Id := N + 416;
+ Name_Min : constant Name_Id := N + 417;
+ Name_Model : constant Name_Id := N + 418;
+ Name_Pred : constant Name_Id := N + 419;
+ Name_Remainder : constant Name_Id := N + 420;
+ Name_Rounding : constant Name_Id := N + 421;
+ Name_Succ : constant Name_Id := N + 422;
+ Name_Truncation : constant Name_Id := N + 423;
+ Name_Value : constant Name_Id := N + 424;
+ Name_Wide_Image : constant Name_Id := N + 425;
+ Name_Wide_Value : constant Name_Id := N + 426;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 426;
-- Attributes that designate procedures
- 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;
+ First_Procedure_Attribute : constant Name_Id := N + 427;
+ Name_Output : constant Name_Id := N + 427;
+ Name_Read : constant Name_Id := N + 428;
+ Name_Write : constant Name_Id := N + 429;
+ Last_Procedure_Attribute : constant Name_Id := N + 429;
-- Remaining attributes are ones that return entities
- 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;
+ First_Entity_Attribute_Name : constant Name_Id := N + 430;
+ Name_Elab_Body : constant Name_Id := N + 430; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 431; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 432;
-- These attributes are the ones that return types
- 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;
+ First_Type_Attribute_Name : constant Name_Id := N + 433;
+ Name_Base : constant Name_Id := N + 433;
+ Name_Class : constant Name_Id := N + 434;
+ Last_Type_Attribute_Name : constant Name_Id := N + 434;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 434;
+ Last_Attribute_Name : constant Name_Id := N + 434;
-- Names of recognized locking policy identifiers
@@ -723,10 +724,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 + 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;
+ First_Locking_Policy_Name : constant Name_Id := N + 435;
+ Name_Ceiling_Locking : constant Name_Id := N + 435;
+ Name_Inheritance_Locking : constant Name_Id := N + 436;
+ Last_Locking_Policy_Name : constant Name_Id := N + 436;
-- Names of recognized queuing policy identifiers.
@@ -734,10 +735,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 + 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;
+ First_Queuing_Policy_Name : constant Name_Id := N + 437;
+ Name_FIFO_Queuing : constant Name_Id := N + 437;
+ Name_Priority_Queuing : constant Name_Id := N + 438;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 438;
-- Names of recognized task dispatching policy identifiers
@@ -745,193 +746,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 + 438;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 438;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 438;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 439;
+ Name_Fifo_Within_Priorities : constant Name_Id := N + 439;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 439;
-- Names of recognized checks for pragma Suppress
- 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;
+ First_Check_Name : constant Name_Id := N + 440;
+ Name_Access_Check : constant Name_Id := N + 440;
+ Name_Accessibility_Check : constant Name_Id := N + 441;
+ Name_Discriminant_Check : constant Name_Id := N + 442;
+ Name_Division_Check : constant Name_Id := N + 443;
+ Name_Elaboration_Check : constant Name_Id := N + 444;
+ Name_Index_Check : constant Name_Id := N + 445;
+ Name_Length_Check : constant Name_Id := N + 446;
+ Name_Overflow_Check : constant Name_Id := N + 447;
+ Name_Range_Check : constant Name_Id := N + 448;
+ Name_Storage_Check : constant Name_Id := N + 449;
+ Name_Tag_Check : constant Name_Id := N + 450;
+ Name_All_Checks : constant Name_Id := N + 451;
+ Last_Check_Name : constant Name_Id := N + 451;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- 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;
+ Name_Abort : constant Name_Id := N + 452;
+ Name_Abs : constant Name_Id := N + 453;
+ Name_Accept : constant Name_Id := N + 454;
+ Name_And : constant Name_Id := N + 455;
+ Name_All : constant Name_Id := N + 456;
+ Name_Array : constant Name_Id := N + 457;
+ Name_At : constant Name_Id := N + 458;
+ Name_Begin : constant Name_Id := N + 459;
+ Name_Body : constant Name_Id := N + 460;
+ Name_Case : constant Name_Id := N + 461;
+ Name_Constant : constant Name_Id := N + 462;
+ Name_Declare : constant Name_Id := N + 463;
+ Name_Delay : constant Name_Id := N + 464;
+ Name_Do : constant Name_Id := N + 465;
+ Name_Else : constant Name_Id := N + 466;
+ Name_Elsif : constant Name_Id := N + 467;
+ Name_End : constant Name_Id := N + 468;
+ Name_Entry : constant Name_Id := N + 469;
+ Name_Exception : constant Name_Id := N + 470;
+ Name_Exit : constant Name_Id := N + 471;
+ Name_For : constant Name_Id := N + 472;
+ Name_Function : constant Name_Id := N + 473;
+ Name_Generic : constant Name_Id := N + 474;
+ Name_Goto : constant Name_Id := N + 475;
+ Name_If : constant Name_Id := N + 476;
+ Name_In : constant Name_Id := N + 477;
+ Name_Is : constant Name_Id := N + 478;
+ Name_Limited : constant Name_Id := N + 479;
+ Name_Loop : constant Name_Id := N + 480;
+ Name_Mod : constant Name_Id := N + 481;
+ Name_New : constant Name_Id := N + 482;
+ Name_Not : constant Name_Id := N + 483;
+ Name_Null : constant Name_Id := N + 484;
+ Name_Of : constant Name_Id := N + 485;
+ Name_Or : constant Name_Id := N + 486;
+ Name_Others : constant Name_Id := N + 487;
+ Name_Out : constant Name_Id := N + 488;
+ Name_Package : constant Name_Id := N + 489;
+ Name_Pragma : constant Name_Id := N + 490;
+ Name_Private : constant Name_Id := N + 491;
+ Name_Procedure : constant Name_Id := N + 492;
+ Name_Raise : constant Name_Id := N + 493;
+ Name_Record : constant Name_Id := N + 494;
+ Name_Rem : constant Name_Id := N + 495;
+ Name_Renames : constant Name_Id := N + 496;
+ Name_Return : constant Name_Id := N + 497;
+ Name_Reverse : constant Name_Id := N + 498;
+ Name_Select : constant Name_Id := N + 499;
+ Name_Separate : constant Name_Id := N + 500;
+ Name_Subtype : constant Name_Id := N + 501;
+ Name_Task : constant Name_Id := N + 502;
+ Name_Terminate : constant Name_Id := N + 503;
+ Name_Then : constant Name_Id := N + 504;
+ Name_Type : constant Name_Id := N + 505;
+ Name_Use : constant Name_Id := N + 506;
+ Name_When : constant Name_Id := N + 507;
+ Name_While : constant Name_Id := N + 508;
+ Name_With : constant Name_Id := N + 509;
+ Name_Xor : constant Name_Id := N + 510;
-- 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 + 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;
+ First_Intrinsic_Name : constant Name_Id := N + 511;
+ Name_Divide : constant Name_Id := N + 511;
+ Name_Enclosing_Entity : constant Name_Id := N + 512;
+ Name_Exception_Information : constant Name_Id := N + 513;
+ Name_Exception_Message : constant Name_Id := N + 514;
+ Name_Exception_Name : constant Name_Id := N + 515;
+ Name_File : constant Name_Id := N + 516;
+ Name_Import_Address : constant Name_Id := N + 517;
+ Name_Import_Largest_Value : constant Name_Id := N + 518;
+ Name_Import_Value : constant Name_Id := N + 519;
+ Name_Is_Negative : constant Name_Id := N + 520;
+ Name_Line : constant Name_Id := N + 521;
+ Name_Rotate_Left : constant Name_Id := N + 522;
+ Name_Rotate_Right : constant Name_Id := N + 523;
+ Name_Shift_Left : constant Name_Id := N + 524;
+ Name_Shift_Right : constant Name_Id := N + 525;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 526;
+ Name_Source_Location : constant Name_Id := N + 527;
+ Name_Unchecked_Conversion : constant Name_Id := N + 528;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 529;
+ Name_To_Pointer : constant Name_Id := N + 530;
+ Last_Intrinsic_Name : constant Name_Id := N + 530;
-- Reserved words used only in Ada 95
- 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;
+ First_95_Reserved_Word : constant Name_Id := N + 531;
+ Name_Abstract : constant Name_Id := N + 531;
+ Name_Aliased : constant Name_Id := N + 532;
+ Name_Protected : constant Name_Id := N + 533;
+ Name_Until : constant Name_Id := N + 534;
+ Name_Requeue : constant Name_Id := N + 535;
+ Name_Tagged : constant Name_Id := N + 536;
+ Last_95_Reserved_Word : constant Name_Id := N + 536;
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 + 536;
+ Name_Raise_Exception : constant Name_Id := N + 537;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- 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;
+ Name_Binder : constant Name_Id := N + 538;
+ Name_Body_Suffix : constant Name_Id := N + 539;
+ Name_Builder : constant Name_Id := N + 540;
+ Name_Compiler : constant Name_Id := N + 541;
+ Name_Cross_Reference : constant Name_Id := N + 542;
+ Name_Default_Switches : constant Name_Id := N + 543;
+ Name_Exec_Dir : constant Name_Id := N + 544;
+ Name_Executable : constant Name_Id := N + 545;
+ Name_Executable_Suffix : constant Name_Id := N + 546;
+ Name_Extends : constant Name_Id := N + 547;
+ Name_Finder : constant Name_Id := N + 548;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 549;
+ Name_Gnatls : constant Name_Id := N + 550;
+ Name_Gnatstub : constant Name_Id := N + 551;
+ Name_Implementation : constant Name_Id := N + 552;
+ Name_Implementation_Exceptions : constant Name_Id := N + 553;
+ Name_Implementation_Suffix : constant Name_Id := N + 554;
+ Name_Languages : constant Name_Id := N + 555;
+ Name_Library_Dir : constant Name_Id := N + 556;
+ Name_Library_Auto_Init : constant Name_Id := N + 557;
+ Name_Library_GCC : constant Name_Id := N + 558;
+ Name_Library_Interface : constant Name_Id := N + 559;
+ Name_Library_Kind : constant Name_Id := N + 560;
+ Name_Library_Name : constant Name_Id := N + 561;
+ Name_Library_Options : constant Name_Id := N + 562;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 563;
+ Name_Library_Src_Dir : constant Name_Id := N + 564;
+ Name_Library_Symbol_File : constant Name_Id := N + 565;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 566;
+ Name_Library_Version : constant Name_Id := N + 567;
+ Name_Linker : constant Name_Id := N + 568;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 569;
+ Name_Locally_Removed_Files : constant Name_Id := N + 570;
+ Name_Naming : constant Name_Id := N + 571;
+ Name_Object_Dir : constant Name_Id := N + 572;
+ Name_Pretty_Printer : constant Name_Id := N + 573;
+ Name_Project : constant Name_Id := N + 574;
+ Name_Separate_Suffix : constant Name_Id := N + 575;
+ Name_Source_Dirs : constant Name_Id := N + 576;
+ Name_Source_Files : constant Name_Id := N + 577;
+ Name_Source_List_File : constant Name_Id := N + 578;
+ Name_Spec : constant Name_Id := N + 579;
+ Name_Spec_Suffix : constant Name_Id := N + 580;
+ Name_Specification : constant Name_Id := N + 581;
+ Name_Specification_Exceptions : constant Name_Id := N + 582;
+ Name_Specification_Suffix : constant Name_Id := N + 583;
+ Name_Switches : constant Name_Id := N + 584;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 584;
+ Name_Unaligned_Valid : constant Name_Id := N + 585;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 584;
+ Last_Predefined_Name : constant Name_Id := N + 585;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Index: s-restri.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-restri.ads,v
retrieving revision 1.1
diff -u -p -r1.1 s-restri.ads
--- s-restri.ads 2 Feb 2004 12:32:00 -0000 1.1
+++ s-restri.ads 4 Feb 2004 09:48:41 -0000
@@ -39,7 +39,7 @@ package System.Restrictions is
pragma Discard_Names;
package Rident is new System.Rident;
- Restrictions : Rident.Restrictions_Info;
+ Run_Time_Restrictions : Rident.Restrictions_Info;
------------------
-- Subprograms --
Index: s-restri.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-restri.adb,v
retrieving revision 1.1
diff -u -p -r1.1 s-restri.adb
--- s-restri.adb 2 Feb 2004 12:32:00 -0000 1.1
+++ s-restri.adb 4 Feb 2004 09:48:41 -0000
@@ -40,9 +40,9 @@ package body System.Restrictions is
function Abort_Allowed return Boolean is
begin
- return Restrictions.Violated (No_Abort_Statements)
+ return Run_Time_Restrictions.Violated (No_Abort_Statements)
or else
- Restrictions.Violated (Max_Asynchronous_Select_Nesting);
+ Run_Time_Restrictions.Violated (Max_Asynchronous_Select_Nesting);
end Abort_Allowed;
---------------------
@@ -51,12 +51,98 @@ package body System.Restrictions is
function Tasking_Allowed return Boolean is
begin
- return Restrictions.Violated (Max_Tasks)
+ return Run_Time_Restrictions.Violated (Max_Tasks)
or else
- Restrictions.Violated (No_Tasking);
+ Run_Time_Restrictions.Violated (No_Tasking);
end Tasking_Allowed;
+-- Package elaboration code (acquire restrictions)
+
begin
- null;
+ Acquire_Restrictions : declare
+
+ subtype Big_String is String (Positive);
+ type Big_String_Ptr is access all Big_String;
+
+ RString : Big_String_Ptr;
+ pragma Import (C, RString, "__gl_restrictions");
+
+ P : Natural := 1;
+ -- Pointer to scan string
+
+ C : Character;
+ -- Next character from string
+
+ function Get_Char return Character;
+ -- Get next character from string
+
+ function Get_Natural return Natural;
+ -- Scan out natural value known to be in range, updating P past it
+
+ --------------
+ -- Get_Char --
+ --------------
+
+ function Get_Char return Character is
+ begin
+ P := P + 1;
+ return RString (P - 1);
+ end Get_Char;
+
+ -----------------
+ -- Get_Natural --
+ -----------------
+
+ function Get_Natural return Natural is
+ N : Natural := 0;
+
+ begin
+ while RString (P) in '0' .. '9' loop
+ N := N * 10 + (Character'Pos (Get_Char) - Character'Pos ('0'));
+ end loop;
+
+ return N;
+ end Get_Natural;
+
+ -- Start of processing for Acquire_Restrictions
+
+ begin
+ -- Acquire data corresponding to first R line
+
+ for R in All_Boolean_Restrictions loop
+ C := Get_Char;
+
+ if C = 'v' then
+ Run_Time_Restrictions.Violated (R) := True;
+
+ elsif C = 'r' then
+ Run_Time_Restrictions.Set (R) := True;
+ end if;
+ end loop;
+
+ -- Acquire data corresponding to second R line
+
+ for RP in All_Parameter_Restrictions loop
+
+ -- Acquire restrictions pragma information
+
+ if Get_Char = 'r' then
+ Run_Time_Restrictions.Set (RP) := True;
+ Run_Time_Restrictions.Value (RP) := Get_Natural;
+ end if;
+
+ -- Acquire restrictions violations information
+
+ if Get_Char = 'v' then
+ Run_Time_Restrictions.Violated (RP) := True;
+ Run_Time_Restrictions.Count (RP) := Get_Natural;
+
+ if RString (P) = '+' then
+ Run_Time_Restrictions.Unknown (RP) := True;
+ P := P + 1;
+ end if;
+ end if;
+ end loop;
+ end Acquire_Restrictions;
end System.Restrictions;
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.3
diff -u -p -r1.3 s-rident.ads
--- s-rident.ads 2 Feb 2004 12:32:01 -0000 1.3
+++ s-rident.ads 4 Feb 2004 09:48:41 -0000
@@ -97,7 +97,7 @@ package System.Rident is
No_Standard_Storage_Pools, -- GNAT
No_Streams, -- GNAT
No_Task_Allocators, -- (RM D.7(7))
- No_Task_Attributes, -- GNAT
+ No_Task_Attributes_Package, -- GNAT
No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
No_Task_Termination, -- GNAT (Ravenscar)
No_Tasking, -- GNAT
@@ -154,8 +154,9 @@ package System.Rident is
-- Synonyms permitted for historical purposes of compatibility
- -- No_Requeue synonym for No_Requeue_Statements
- -- No_Tasking synonym for Max_Tasks => 0
+ -- No_Requeue synonym for No_Requeue_Statements
+ -- No_Tasking synonym for Max_Tasks => 0
+ -- No_Task_Attributes synonym for No_Task_Attributes_Package
subtype All_Restrictions is Restriction_Id range
Boolean_Entry_Barriers .. Max_Storage_At_Blocking;
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-02-02 12:36 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-02-02 12:36 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
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.
--
Index: 5staprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5staprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5staprop.adb
--- 5staprop.adb 5 Jan 2004 15:20:43 -0000 1.8
+++ 5staprop.adb 2 Feb 2004 11:46:51 -0000
@@ -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.Oper
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.Oper
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.Oper
-----------------
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.Oper
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.Oper
------------------
function Check_Unlock (L : Lock_Ptr) return Boolean is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
Index: 6vcstrea.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/6vcstrea.adb,v
retrieving revision 1.9
diff -u -p -r1.9 6vcstrea.adb
--- 6vcstrea.adb 5 Jan 2004 15:20:43 -0000 1.9
+++ 6vcstrea.adb 2 Feb 2004 11:46:51 -0000
@@ -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.???
-
- -- 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.???
+ -- As the functions fread, fwrite and setvbuf are too big to be inlined,
+ -- they are just wrappers to the following implementation functions.
+
+ 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;
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.12
diff -u -p -r1.12 ali.adb
--- ali.adb 5 Jan 2004 15:20:43 -0000 1.12
+++ ali.adb 2 Feb 2004 11:46:51 -0000
@@ -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;
@@ -840,6 +845,109 @@ package body ALI is
end if;
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
Index: ali.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.ads,v
retrieving revision 1.11
diff -u -p -r1.11 ali.ads
--- ali.ads 21 Oct 2003 13:41:58 -0000 1.11
+++ ali.ads 2 Feb 2004 11:46:51 -0000
@@ -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
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.10
diff -u -p -r1.10 atree.adb
--- atree.adb 21 Nov 2003 10:46:37 -0000 1.10
+++ atree.adb 2 Feb 2004 11:46:51 -0000
@@ -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 --
@@ -1925,8 +1925,6 @@ package body Atree is
Write_Eol;
end if;
end New_Node_Debugging_Output;
-
- pragma Inline (New_Node_Debugging_Output);
-- Start of processing for New_Node
Index: atree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.ads,v
retrieving revision 1.6
diff -u -p -r1.6 atree.ads
--- atree.ads 21 Oct 2003 13:41:58 -0000 1.6
+++ atree.ads 2 Feb 2004 11:46:51 -0000
@@ -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);
Index: bcheck.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bcheck.adb,v
retrieving revision 1.8
diff -u -p -r1.8 bcheck.adb
--- bcheck.adb 21 Oct 2003 13:41:58 -0000 1.8
+++ bcheck.adb 2 Feb 2004 11:46:51 -0000
@@ -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,148 +362,6 @@ 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
-
- No_Recursion => True,
- -- Not checkable at compile time
-
- No_Reentrancy => True,
- -- Not checkable at compile time
-
- 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.
-
- R : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id);
- -- Record the first unit specifying each compilation unit restriction
-
- 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.
-
- Additional_Restrictions_Listed : Boolean := False;
- -- Set True if we have listed header for restrictions
-
- begin
- -- Loop to find restrictions
-
- 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;
-
- -- Loop to find violations
-
- 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
-
- V (J) := A;
-
- -- 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.
-
- if R (J) /= No_ALI_Id
- and then J in Partition_Restrictions
- then
- declare
- M1 : constant String := "% has Restriction (";
- S : constant String := Restriction_Id'Image (J);
- M2 : String (1 .. M1'Length + S'Length + 1);
-
- begin
- Name_Buffer (1 .. S'Length) := S;
- Name_Len := S'Length;
- Set_Casing
- (Units.Table (ALIs.Table (R (J)).First_Unit).Icasing);
-
- M2 (M1'Range) := M1;
- M2 (M1'Length + 1 .. M2'Last - 1) :=
- Name_Buffer (1 .. S'Length);
- M2 (M2'Last) := ')';
-
- Error_Msg_Name_1 := ALIs.Table (R (J)).Sfile;
- Consistency_Error_Msg (M2);
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
- Consistency_Error_Msg
- ("but file % violates this restriction");
- end;
- end if;
- end if;
- end loop;
- end loop;
-
- -- List applicable restrictions if option set
-
- if List_Restrictions then
-
- -- List any restrictions which were not violated and not specified
-
- 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;
-
- Write_Str ("pragma Restrictions (");
-
- declare
- S : constant String := Restriction_Id'Image (J);
- begin
- Name_Len := S'Length;
- Name_Buffer (1 .. Name_Len) := S;
- end;
-
- 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;
-
-------------------------------------
-- Check_Consistent_Queuing_Policy --
-------------------------------------
@@ -540,6 +398,135 @@ package body Bcheck is
end if;
end loop Find_Policy;
end Check_Consistent_Queuing_Policy;
+
+ -----------------------------------
+ -- Check_Consistent_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.
+
+ procedure Check_Consistent_Restrictions is
+ Restriction_File_Output : Boolean;
+ -- Shows if we have output header messages for restriction violation
+
+ procedure Print_Restriction_File (R : All_Restrictions);
+ -- Print header line for R if not printed yet
+
+ ----------------------------
+ -- Print_Restriction_File --
+ ----------------------------
+
+ procedure Print_Restriction_File (R : All_Restrictions) is
+ begin
+ if not Restriction_File_Output then
+ Restriction_File_Output := True;
+
+ -- Find the ali file specifying the restriction
+
+ 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 (R);
+ M2 : String (1 .. 200); -- big enough!
+ P : Integer;
+
+ begin
+ Name_Buffer (1 .. S'Length) := S;
+ Name_Len := S'Length;
+ Set_Casing (Mixed_Case);
+
+ M2 (M1'Range) := M1;
+ 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 (A).Sfile;
+ Consistency_Error_Msg (M2 (1 .. P - 1));
+ Consistency_Error_Msg
+ ("but the following files violate this restriction:");
+ end;
+ end if;
+ end loop;
+ end if;
+ end Print_Restriction_File;
+
+ -- Start of processing for Check_Consistent_Restrictions
+
+ begin
+ -- Loop through all restriction violations
+
+ for R in All_Restrictions loop
+
+ -- Check for violation of this restriction
+
+ 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;
+
+ -- Loop through files looking for violators
+
+ for A2 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A2).Restrictions.Violated (R) then
+
+ -- 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.
+
+ if not Is_Internal_File_Name (ALIs.Table (A2).Sfile) then
+ Print_Restriction_File (R);
+
+ Error_Msg_Name_1 := ALIs.Table (A2).Sfile;
+
+ if R in All_Boolean_Restrictions then
+ Consistency_Error_Msg (" %");
+
+ 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));
+
+ 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;
+ end Check_Consistent_Restrictions;
---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling --
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.18
diff -u -p -r1.18 bindgen.adb
--- bindgen.adb 5 Jan 2004 15:20:43 -0000 1.18
+++ bindgen.adb 2 Feb 2004 11:46:51 -0000
@@ -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;
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.15
diff -u -p -r1.15 checks.adb
--- checks.adb 5 Jan 2004 15:20:43 -0000 1.15
+++ checks.adb 2 Feb 2004 11:46:52 -0000
@@ -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 =>
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.16
diff -u -p -r1.16 cstand.adb
--- cstand.adb 13 Jan 2004 11:51:31 -0000 1.16
+++ cstand.adb 2 Feb 2004 11:46:52 -0000
@@ -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);
@@ -1503,7 +1505,6 @@ package body CStand is
Write_Str (IEEES_First'Universal_Literal_String);
Write_Str (" .. ");
Write_Str (IEEES_Last'Universal_Literal_String);
-
elsif Digs = IEEEL_Digits then
Write_Str (IEEEL_First'Universal_Literal_String);
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.26
diff -u -p -r1.26 decl.c
--- decl.c 23 Jan 2004 10:30:03 -0000 1.26
+++ decl.c 2 Feb 2004 11:46:52 -0000
@@ -1315,6 +1315,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
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_entit
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));
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_aggr.adb
--- exp_aggr.adb 23 Jan 2004 10:30:03 -0000 1.15
+++ exp_aggr.adb 2 Feb 2004 11:46:52 -0000
@@ -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
Index: exp_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_attr.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_attr.adb
--- exp_attr.adb 3 Dec 2003 11:47:52 -0000 1.8
+++ exp_attr.adb 2 Feb 2004 11:46:52 -0000
@@ -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);
Index: exp_ch11.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch11.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_ch11.adb
--- exp_ch11.adb 5 Jan 2004 15:20:43 -0000 1.8
+++ exp_ch11.adb 2 Feb 2004 11:46:52 -0000
@@ -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;
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_ch3.adb
--- exp_ch3.adb 26 Jan 2004 14:47:47 -0000 1.15
+++ exp_ch3.adb 2 Feb 2004 11:46:52 -0000
@@ -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
-
- Decls : List_Id;
- Loops : Node_Id;
- Stats : List_Id;
+ 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;
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))
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch5.adb
--- exp_ch5.adb 26 Jan 2004 14:47:47 -0000 1.14
+++ exp_ch5.adb 2 Feb 2004 11:46:53 -0000
@@ -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,
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.18
diff -u -p -r1.18 exp_ch6.adb
--- exp_ch6.adb 19 Jan 2004 10:37:59 -0000 1.18
+++ exp_ch6.adb 2 Feb 2004 11:46:53 -0000
@@ -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
Index: exp_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch7.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch7.adb
--- exp_ch7.adb 5 Jan 2004 15:20:43 -0000 1.11
+++ exp_ch7.adb 2 Feb 2004 11:46:53 -0000
@@ -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);
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch9.adb
--- exp_ch9.adb 23 Jan 2004 10:30:03 -0000 1.14
+++ exp_ch9.adb 2 Feb 2004 11:46:53 -0000
@@ -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));
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.18
diff -u -p -r1.18 exp_util.adb
--- exp_util.adb 12 Jan 2004 11:45:23 -0000 1.18
+++ exp_util.adb 2 Feb 2004 11:46:53 -0000
@@ -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'));
Index: fname-uf.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.adb,v
retrieving revision 1.9
diff -u -p -r1.9 fname-uf.adb
--- fname-uf.adb 21 Oct 2003 13:42:00 -0000 1.9
+++ fname-uf.adb 2 Feb 2004 11:46:54 -0000
@@ -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
Index: fname-uf.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fname-uf.ads,v
retrieving revision 1.5
diff -u -p -r1.5 fname-uf.ads
--- fname-uf.ads 21 Oct 2003 13:42:00 -0000 1.5
+++ fname-uf.ads 2 Feb 2004 11:46:54 -0000
@@ -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
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.11
diff -u -p -r1.11 freeze.adb
--- freeze.adb 5 Jan 2004 15:20:44 -0000 1.11
+++ freeze.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: g-crc32.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-crc32.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-crc32.ads
--- g-crc32.ads 21 Oct 2003 13:42:00 -0000 1.4
+++ g-crc32.ads 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: g-md5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-md5.adb,v
retrieving revision 1.4
diff -u -p -r1.4 g-md5.adb
--- g-md5.adb 21 Oct 2003 13:42:03 -0000 1.4
+++ g-md5.adb 2 Feb 2004 11:46:54 -0000
@@ -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
Index: g-md5.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-md5.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-md5.ads
--- g-md5.ads 21 Oct 2003 13:42:03 -0000 1.4
+++ g-md5.ads 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: gnat1drv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat1drv.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnat1drv.adb
--- gnat1drv.adb 5 Jan 2004 15:20:44 -0000 1.10
+++ gnat1drv.adb 2 Feb 2004 11:46:54 -0000
@@ -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
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.9
diff -u -p -r1.9 gnatbind.adb
--- gnatbind.adb 5 Jan 2004 15:20:44 -0000 1.9
+++ gnatbind.adb 2 Feb 2004 11:46:54 -0000
@@ -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.
-
- for J in Partition_Restrictions loop
- if Restrictions (J) = 'r' then
- Restrictions_On_Target (J) := True;
- end if;
- end loop;
+ -- List restrictions that could be applied to this partition
+
+ if List_Restrictions then
+ List_Applicable_Restrictions;
+ end if;
-- Complete bind if no errors
Index: gnatcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatcmd.adb,v
retrieving revision 1.15
diff -u -p -r1.15 gnatcmd.adb
--- gnatcmd.adb 26 Jan 2004 14:47:48 -0000 1.15
+++ gnatcmd.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.14
diff -u -p -r1.14 gnatlink.adb
--- gnatlink.adb 26 Jan 2004 14:47:48 -0000 1.14
+++ gnatlink.adb 2 Feb 2004 11:46:54 -0000
@@ -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);
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.5
diff -u -p -r1.5 gprcmd.adb
--- gprcmd.adb 5 Jan 2004 15:20:44 -0000 1.5
+++ gprcmd.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: i-cobol.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/i-cobol.ads,v
retrieving revision 1.4
diff -u -p -r1.4 i-cobol.ads
--- i-cobol.ads 24 Apr 2003 17:54:05 -0000 1.4
+++ i-cobol.ads 2 Feb 2004 11:46:54 -0000
@@ -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);
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.22
diff -u -p -r1.22 init.c
--- init.c 11 Dec 2003 16:21:39 -0000 1.22
+++ init.c 2 Feb 2004 11:46:54 -0000
@@ -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- *
@@ -447,6 +447,29 @@ void
__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
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.9
diff -u -p -r1.9 lib.ads
--- lib.ads 8 Dec 2003 10:33:15 -0000 1.9
+++ lib.ads 2 Feb 2004 11:46:54 -0000
@@ -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.
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.12
diff -u -p -r1.12 lib-writ.adb
--- lib-writ.adb 5 Jan 2004 15:20:44 -0000 1.12
+++ lib-writ.adb 2 Feb 2004 11:46:54 -0000
@@ -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,23 +918,53 @@ 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');
+ end if;
+ end loop;
+
+ 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;
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.9
diff -u -p -r1.9 lib-writ.ads
--- lib-writ.ads 5 Jan 2004 15:20:44 -0000 1.9
+++ lib-writ.ads 2 Feb 2004 11:46:54 -0000
@@ -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
@@ -230,6 +235,58 @@ package Lib.Writ is
-- i.e. to detect cases where one unit has "r" and another unit
-- 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 --
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.69
diff -u -p -r1.69 Makefile.in
--- Makefile.in 26 Jan 2004 21:56:05 -0000 1.69
+++ Makefile.in 2 Feb 2004 11:46:54 -0000
@@ -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 sol
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%,$(
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 hpux
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%,$(ma
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 os
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% min
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
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
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.5
diff -u -p -r1.5 Makefile.rtl
--- Makefile.rtl 5 Jan 2004 15:20:45 -0000 1.5
+++ Makefile.rtl 2 Feb 2004 11:46:54 -0000
@@ -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) \
Index: par-ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch3.adb,v
retrieving revision 1.10
diff -u -p -r1.10 par-ch3.adb
--- par-ch3.adb 12 Jan 2004 11:45:24 -0000 1.10
+++ par-ch3.adb 2 Feb 2004 11:46:54 -0000
@@ -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;
Index: restrict.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.adb,v
retrieving revision 1.8
diff -u -p -r1.8 restrict.adb
--- restrict.adb 21 Oct 2003 13:42:13 -0000 1.8
+++ restrict.adb 2 Feb 2004 11:46:54 -0000
@@ -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).
+
+ procedure Update_Restrictions (Info : in out Restrictions_Info);
+ -- Update violation information in Info.Violated and Info.Count
+
+ -------------------------
+ -- Update_Restrictions --
+ -------------------------
+
+ procedure Update_Restrictions (Info : in out Restrictions_Info) is
+ begin
+ -- If not violated, set as violated now
+
+ 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;
- 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
+ -- Otherwise if violated already and a parameter restriction,
+ -- update count by maximizing or summing depending on restriction.
- if not Restrictions (R) then
- Restriction_Msg
- ("?violation of restriction %", Rimage, N);
+ elsif R in All_Parameter_Restrictions then
- -- If this is a real restriction violation, then generate
- -- a non-serious message with appropriate location.
+ -- If new value is unknown, result is unknown
- else
- Error_Msg_Sloc := Restrictions_Loc (R);
+ 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;
+ Restrictions.Set (R) := True;
+
+ -- Set location, but preserve location of system
+ -- restriction for nice error msg with run time name
- if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
- Restriction_Parameters (Max_Protected_Entries) := Uint_1;
+ 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;
Index: restrict.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.ads,v
retrieving revision 1.6
diff -u -p -r1.6 restrict.ads
--- restrict.ads 21 Oct 2003 13:42:13 -0000 1.6
+++ restrict.ads 2 Feb 2004 11:46:54 -0000
@@ -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 : 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 (Restriction_Id) of Source_Ptr :=
+ 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.
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.19
diff -u -p -r1.19 sem_attr.adb
--- sem_attr.adb 19 Jan 2004 10:37:59 -0000 1.19
+++ sem_attr.adb 2 Feb 2004 11:46:55 -0000
@@ -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;
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_ch10.adb
--- sem_ch10.adb 5 Jan 2004 15:20:45 -0000 1.14
+++ sem_ch10.adb 2 Feb 2004 11:46:55 -0000
@@ -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
Index: sem_ch11.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch11.adb,v
retrieving revision 1.6
diff -u -p -r1.6 sem_ch11.adb
--- sem_ch11.adb 21 Oct 2003 13:42:19 -0000 1.6
+++ sem_ch11.adb 2 Feb 2004 11:46:55 -0000
@@ -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;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.31
diff -u -p -r1.31 sem_ch12.adb
--- sem_ch12.adb 12 Jan 2004 11:38:15 -0000 1.31
+++ sem_ch12.adb 2 Feb 2004 11:46:55 -0000
@@ -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
Index: sem_ch2.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch2.adb,v
retrieving revision 1.5
diff -u -p -r1.5 sem_ch2.adb
--- sem_ch2.adb 24 Apr 2003 17:54:16 -0000 1.5
+++ sem_ch2.adb 2 Feb 2004 11:46:55 -0000
@@ -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;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.29
diff -u -p -r1.29 sem_ch3.adb
--- sem_ch3.adb 21 Jan 2004 10:35:17 -0000 1.29
+++ sem_ch3.adb 2 Feb 2004 11:46:56 -0000
@@ -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
- Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+ if not Extensions_Allowed then
+
+ -- 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
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_ch4.adb
--- sem_ch4.adb 5 Jan 2004 15:20:46 -0000 1.11
+++ sem_ch4.adb 2 Feb 2004 11:46:56 -0000
@@ -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
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_ch8.adb
--- sem_ch8.adb 5 Jan 2004 15:20:46 -0000 1.15
+++ sem_ch8.adb 2 Feb 2004 11:46:56 -0000
@@ -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);
Index: sem_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch9.adb,v
retrieving revision 1.8
diff -u -p -r1.8 sem_ch9.adb
--- sem_ch9.adb 21 Jan 2004 10:35:17 -0000 1.8
+++ sem_ch9.adb 2 Feb 2004 11:46:56 -0000
@@ -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;
Index: sem_elab.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elab.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sem_elab.adb
--- sem_elab.adb 5 Jan 2004 15:20:46 -0000 1.12
+++ sem_elab.adb 2 Feb 2004 11:46:56 -0000
@@ -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.
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_prag.adb
--- sem_prag.adb 12 Jan 2004 11:45:25 -0000 1.17
+++ sem_prag.adb 2 Feb 2004 11:46:56 -0000
@@ -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 --
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_res.adb
--- sem_res.adb 19 Jan 2004 10:37:59 -0000 1.20
+++ sem_res.adb 2 Feb 2004 11:46:57 -0000
@@ -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
Index: sem_type.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_type.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_type.adb
--- sem_type.adb 20 Nov 2003 09:54:01 -0000 1.10
+++ sem_type.adb 2 Feb 2004 11:46:57 -0000
@@ -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
@@ -1468,6 +1468,23 @@ package body Sem_Type is
return T;
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
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sinfo.adb
--- sinfo.adb 12 Jan 2004 11:45:25 -0000 1.12
+++ sinfo.adb 2 Feb 2004 11:46:57 -0000
@@ -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
@@ -2564,6 +2573,15 @@ package body Sinfo is
or else NT (N).Nkind = N_Accept_Alternative);
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
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.18
diff -u -p -r1.18 sinfo.ads
--- sinfo.ads 12 Jan 2004 11:45:25 -0000 1.18
+++ sinfo.ads 2 Feb 2004 11:46:57 -0000
@@ -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);
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.15
diff -u -p -r1.15 snames.adb
--- snames.adb 26 Jan 2004 14:47:48 -0000 1.15
+++ snames.adb 2 Feb 2004 11:46:57 -0000
@@ -334,6 +334,7 @@ package body Snames is
"on#" &
"parameter_types#" &
"reference#" &
+ "no_requeue#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.15
diff -u -p -r1.15 snames.ads
--- snames.ads 20 Nov 2003 09:54:02 -0000 1.15
+++ snames.ads 2 Feb 2004 11:46:57 -0000
@@ -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;
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sprint.adb
--- sprint.adb 13 Jan 2004 11:51:34 -0000 1.15
+++ sprint.adb 2 Feb 2004 11:46:57 -0000
@@ -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 ");
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.2
diff -u -p -r1.2 s-rident.ads
--- s-rident.ads 27 Nov 2003 11:40:45 -0000 1.2
+++ s-rident.ads 2 Feb 2004 11:46:57 -0000
@@ -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;
-
- -- 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);
+ -- 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.
+
+ 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;
Index: s-stoele.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-stoele.ads,v
retrieving revision 1.4
diff -u -p -r1.4 s-stoele.ads
--- s-stoele.ads 21 Oct 2003 13:42:14 -0000 1.4
+++ s-stoele.ads 2 Feb 2004 11:46:57 -0000
@@ -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, "-");
Index: s-thread.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.ads,v
retrieving revision 1.4
diff -u -p -r1.4 s-thread.ads
--- s-thread.ads 24 Nov 2003 14:27:57 -0000 1.4
+++ s-thread.ads 2 Feb 2004 11:46:57 -0000
@@ -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);
Index: style.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/style.ads,v
retrieving revision 1.5
diff -u -p -r1.5 style.ads
--- style.ads 21 Oct 2003 13:42:22 -0000 1.5
+++ style.ads 2 Feb 2004 11:46:57 -0000
@@ -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.
Index: targparm.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.adb,v
retrieving revision 1.7
diff -u -p -r1.7 targparm.adb
--- targparm.adb 23 Jan 2004 09:53:05 -0000 1.7
+++ targparm.adb 2 Feb 2004 11:46:57 -0000
@@ -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
Index: targparm.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.ads,v
retrieving revision 1.7
diff -u -p -r1.7 targparm.ads
--- targparm.ads 8 Dec 2003 10:33:16 -0000 1.7
+++ targparm.ads 2 Feb 2004 11:46:57 -0000
@@ -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).
+ -- required (see definition of Rident.Restriction_Info).
- 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.
+ 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 --
Index: tbuild.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/tbuild.adb,v
retrieving revision 1.6
diff -u -p -r1.6 tbuild.adb
--- tbuild.adb 21 Oct 2003 13:42:23 -0000 1.6
+++ tbuild.adb 2 Feb 2004 11:46:57 -0000
@@ -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;
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.41
diff -u -p -r1.41 utils.c
--- utils.c 19 Jan 2004 10:37:59 -0000 1.41
+++ utils.c 2 Feb 2004 11:46:58 -0000
@@ -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 ();
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-26 15:03 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-26 15:03 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux, committed on HEAD.
--
2004-01-26 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Build_Slice_Assignment): New TSS procedure for
one-dimensional array an slice assignments, when component type is
controlled.
* exp_ch5.adb (Expand_Assign_Array): If array is one-dimensional,
component type is controlled, and control_actions are in effect, use
TSS procedure rather than generating inline code.
* exp_tss.ads (TSS_Slice_Assign): New TSS procedure for one-dimensional
arrays with controlled components.
2004-01-26 Vincent Celier <celier@gnat.com>
* gnatcmd.adb (GNATCmd): Add specification of argument file on the
command line for the non VMS case.
* gnatlink.adb (Process_Binder_File): When building object file, if
GNU linker is used, put all object paths between quotes, to prevent ld
error when there are unusual characters (such as '!') in the paths.
* Makefile.generic: When there are sources in Ada and the main is in
C/C++, invoke gnatmake with -B, instead of -z.
* vms_conv.adb (Preprocess_Command_Data): New procedure, extracted
from VMS_Conversion.
(Process_Argument): New procedure, extracted from VMS_Conversion. Add
specification of argument file on the command line.
2004-01-26 Bernard Banner <banner@gnat.com>
* Makefile.in: Enable GMEM_LIB and SYMLIB for x86_64
2004-01-26 Ed Schonberg <schonberg@gnat.com>
* snames.adb: Update copyright notice.
Add info on slice assignment for controlled arrays.
--
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch3.adb
--- exp_ch3.adb 13 Jan 2004 11:51:31 -0000 1.14
+++ exp_ch3.adb 26 Jan 2004 11:56:11 -0000
@@ -114,6 +114,12 @@ package body Exp_Ch3 is
-- Build record initialization procedure. N is the type declaration
-- node, and Pe is the corresponding entity for the record type.
+ procedure Build_Slice_Assignment (Typ : Entity_Id);
+ -- Build assignment procedure for one-dimensional arrays of controlled
+ -- types. Other array and slice assignments are expanded in-line, but
+ -- the code expansion for controlled components (when control actions
+ -- are active) can lead to very large blocks that GCC3 handles poorly.
+
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
-- Create An Equality function for the non-tagged variant record 'Typ'
-- and attach it to the TSS list
@@ -2474,6 +2480,287 @@ package body Exp_Ch3 is
end if;
end Build_Record_Init_Proc;
+ ----------------------------
+ -- Build_Slice_Assignment --
+ ----------------------------
+
+ -- Generates the following subprogram:
+ -- procedure Assign
+ -- (Source, Target : Array_Type,
+ -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
+ -- Rev : Boolean)
+ -- is
+ -- Li1 : Index;
+ -- Ri1 : Index;
+ -- begin
+ -- if Rev then
+ -- Li1 := Left_Hi;
+ -- Ri1 := Right_Hi;
+ -- else
+ -- 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);
+ -- Ri2 := Index'pred (Ri2);
+ -- else
+ -- exit when Li2 = Left_Hi;
+ -- Li2 := Index'succ (Li2);
+ -- Ri2 := Index'succ (Ri2);
+ -- end if;
+ -- end loop;
+ -- end Assign;
+
+ procedure Build_Slice_Assignment (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
+
+ -- Build formal parameters of procedure
+
+ Larray : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('A'));
+ Rarray : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('R'));
+ Left_Lo : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('L'));
+ Left_Hi : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('L'));
+ Right_Lo : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('R'));
+ Right_Hi : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('R'));
+ Rev : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('D'));
+ Proc_Name : constant Entity_Id :=
+ 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
+
+ Decls : List_Id;
+ Loops : Node_Id;
+ Stats : List_Id;
+
+ begin
+
+ -- Build declarations for indices.
+
+ Decls := New_List;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Lnn,
+ Object_Definition =>
+ New_Occurrence_Of (Index, Loc)));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Rnn,
+ Object_Definition =>
+ New_Occurrence_Of (Index, Loc)));
+
+ Stats := New_List;
+
+ -- Build initializations for indices.
+
+ declare
+ F_Init : constant List_Id := New_List;
+ B_Init : constant List_Id := New_List;
+
+ begin
+ Append_To (F_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression => New_Occurrence_Of (Left_Lo, Loc)));
+
+ Append_To (F_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression => New_Occurrence_Of (Right_Lo, Loc)));
+
+ Append_To (B_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression => New_Occurrence_Of (Left_Hi, Loc)));
+
+ Append_To (B_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression => New_Occurrence_Of (Right_Hi, Loc)));
+
+ Append_To (Stats,
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Init,
+ Else_Statements => F_Init));
+ end;
+
+ -- Now construct the assignment statement
+
+ Loops :=
+ Make_Loop_Statement (Loc,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Larray, Loc),
+ Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
+ Expression =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Rarray, Loc),
+ Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
+ End_Label => Empty);
+
+ -- Build the increment/decrement statements.
+
+ declare
+ F_Ass : constant List_Id := New_List;
+ B_Ass : constant List_Id := New_List;
+
+ begin
+ Append_To (F_Ass,
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
+
+ Append_To (B_Ass,
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
+
+ Append_To (F_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Lnn, Loc)))));
+
+ Append_To (F_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Rnn, Loc)))));
+
+ Append_To (B_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Pred,
+ Expressions => New_List (
+ New_Occurrence_Of (Lnn, Loc)))));
+
+ Append_To (B_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Pred,
+ Expressions => New_List (
+ New_Occurrence_Of (Rnn, Loc)))));
+
+ Append_To (Statements (Loops),
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Ass,
+ Else_Statements => F_Ass));
+ end;
+
+ Append_To (Stats, Loops);
+
+ declare
+ Spec : Node_Id;
+ Formals : List_Id := New_List;
+
+ begin
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Larray,
+ Out_Present => True,
+ Parameter_Type =>
+ New_Reference_To (Base_Type (Typ), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Rarray,
+ Parameter_Type =>
+ New_Reference_To (Base_Type (Typ), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Left_Lo,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Left_Hi,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Right_Lo,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Right_Hi,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)));
+
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Rev,
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc)));
+
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Name,
+ Parameter_Specifications => Formals);
+
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stats)));
+ end;
+
+ Set_TSS (Typ, Proc_Name);
+ Set_Is_Pure (Proc_Name);
+ end Build_Slice_Assignment;
+
------------------------------------
-- Build_Variant_Record_Equality --
------------------------------------
@@ -3483,6 +3770,12 @@ package body Exp_Ch3 is
if Typ = Base and then Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base);
+
+ if not Is_Limited_Type (Component_Type (Typ))
+ and then Number_Dimensions (Typ) = 1
+ then
+ Build_Slice_Assignment (Typ);
+ end if;
end if;
-- For packed case, there is a default initialization, except
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_ch5.adb
--- exp_ch5.adb 5 Jan 2004 15:20:43 -0000 1.13
+++ exp_ch5.adb 26 Jan 2004 11:56:12 -0000
@@ -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- --
@@ -32,6 +32,7 @@ with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Pakd; use Exp_Pakd;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
@@ -160,6 +161,10 @@ package body Exp_Ch5 is
-- This switch is set to True if the array move must be done using
-- an explicit front end generated loop.
+ procedure Apply_Dereference (Arg : in out Node_Id);
+ -- If the argument is an access to an array, and the assignment is
+ -- converted into a procedure call, apply explicit dereference.
+
function Has_Address_Clause (Exp : Node_Id) return Boolean;
-- Test if Exp is a reference to an array whose declaration has
-- an address clause, or it is a slice of such an array.
@@ -185,6 +190,20 @@ package body Exp_Ch5 is
-- generate a front end loop, which is not so terrible.
-- It would really be better if backend handled this ???
+ -----------------------
+ -- Apply_Dereference --
+ -----------------------
+
+ procedure Apply_Dereference (Arg : in out Node_Id) is
+ Typ : constant Entity_Id := Etype (Arg);
+ begin
+ if Is_Access_Type (Typ) then
+ Rewrite (Arg, Make_Explicit_Dereference (Loc,
+ Prefix => Relocate_Node (Arg)));
+ Analyze_And_Resolve (Arg, Designated_Type (Typ));
+ end if;
+ end Apply_Dereference;
+
------------------------
-- Has_Address_Clause --
------------------------
@@ -704,10 +723,47 @@ package body Exp_Ch5 is
-- Cases where either Forwards_OK or Backwards_OK is true
if Forwards_OK (N) or else Backwards_OK (N) then
- Rewrite (N,
- Expand_Assign_Array_Loop
- (N, Larray, Rarray, L_Type, R_Type, Ndim,
- Rev => not Forwards_OK (N)));
+ if Controlled_Type (Component_Type (L_Type))
+ and then Base_Type (L_Type) = Base_Type (R_Type)
+ and then Ndim = 1
+ and then not No_Ctrl_Actions (N)
+ then
+ declare
+ Proc : constant Entity_Id :=
+ TSS (Base_Type (L_Type), TSS_Slice_Assign);
+ Actuals : List_Id;
+
+ begin
+ Apply_Dereference (Larray);
+ Apply_Dereference (Rarray);
+ Actuals := New_List (
+ Duplicate_Subexpr (Larray, Name_Req => True),
+ Duplicate_Subexpr (Rarray, Name_Req => True),
+ Duplicate_Subexpr (Left_Lo, Name_Req => True),
+ Duplicate_Subexpr (Left_Hi, Name_Req => True),
+ Duplicate_Subexpr (Right_Lo, Name_Req => True),
+ Duplicate_Subexpr (Right_Hi, Name_Req => True));
+
+ if Forwards_OK (N) then
+ Append_To (Actuals,
+ New_Occurrence_Of (Standard_False, Loc));
+ else
+ Append_To (Actuals,
+ New_Occurrence_Of (Standard_True, Loc));
+ end if;
+
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Proc, Loc),
+ Parameter_Associations => Actuals));
+ end;
+
+ else
+ Rewrite (N,
+ Expand_Assign_Array_Loop
+ (N, Larray, Rarray, L_Type, R_Type, Ndim,
+ Rev => not Forwards_OK (N)));
+ end if;
-- Case of both are false with No_Implicit_Conditionals
@@ -806,19 +862,53 @@ package body Exp_Ch5 is
Right_Opnd => Cright_Lo);
end if;
- Rewrite (N,
- Make_Implicit_If_Statement (N,
- Condition => Condition,
+ if Controlled_Type (Component_Type (L_Type))
+ and then Base_Type (L_Type) = Base_Type (R_Type)
+ and then Ndim = 1
+ and then not No_Ctrl_Actions (N)
+ then
- Then_Statements => New_List (
- Expand_Assign_Array_Loop
- (N, Larray, Rarray, L_Type, R_Type, Ndim,
- Rev => False)),
+ -- Call TSS procedure for array assignment, passing the
+ -- the explicit bounds of right- and left-hand side.
- Else_Statements => New_List (
- Expand_Assign_Array_Loop
- (N, Larray, Rarray, L_Type, R_Type, Ndim,
- Rev => True))));
+ declare
+ Proc : constant Node_Id :=
+ TSS (Base_Type (L_Type), TSS_Slice_Assign);
+ Actuals : List_Id;
+
+ begin
+ Apply_Dereference (Larray);
+ Apply_Dereference (Rarray);
+ Actuals := New_List (
+ Duplicate_Subexpr (Larray, Name_Req => True),
+ Duplicate_Subexpr (Rarray, Name_Req => True),
+ Duplicate_Subexpr (Left_Lo, Name_Req => True),
+ Duplicate_Subexpr (Left_Hi, Name_Req => True),
+ Duplicate_Subexpr (Right_Lo, Name_Req => True),
+ Duplicate_Subexpr (Right_Hi, Name_Req => True));
+ Append_To (Actuals, Condition);
+
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Proc, Loc),
+ Parameter_Associations => Actuals));
+ end;
+
+ else
+ Rewrite (N,
+ Make_Implicit_If_Statement (N,
+ Condition => Condition,
+
+ Then_Statements => New_List (
+ Expand_Assign_Array_Loop
+ (N, Larray, Rarray, L_Type, R_Type, Ndim,
+ Rev => False)),
+
+ Else_Statements => New_List (
+ Expand_Assign_Array_Loop
+ (N, Larray, Rarray, L_Type, R_Type, Ndim,
+ Rev => True))));
+ end if;
end if;
Analyze (N, Suppress => All_Checks);
Index: exp_tss.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_tss.ads,v
retrieving revision 1.5
diff -u -p -r1.5 exp_tss.ads
--- exp_tss.ads 21 Oct 2003 13:41:59 -0000 1.5
+++ exp_tss.ads 26 Jan 2004 11:56:12 -0000
@@ -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- --
@@ -81,6 +81,7 @@ package Exp_Tss is
TSS_RAS_Access : constant TNT := "RA"; -- RAs type access
TSS_RAS_Dereference : constant TNT := "RD"; -- RAs type deference
TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion
+ TSS_Slice_Assign : constant TNT := "SA"; -- Slice assignment
TSS_Stream_Input : constant TNT := "SI"; -- Stream Input attribute
TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute
TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute
@@ -95,6 +96,7 @@ package Exp_Tss is
TSS_RAS_Access,
TSS_RAS_Dereference,
TSS_Rep_To_Pos,
+ TSS_Slice_Assign,
TSS_Stream_Input,
TSS_Stream_Output,
TSS_Stream_Read,
Index: gnatcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatcmd.adb,v
retrieving revision 1.14
diff -u -p -r1.14 gnatcmd.adb
--- gnatcmd.adb 21 Oct 2003 13:42:07 -0000 1.14
+++ gnatcmd.adb 26 Jan 2004 11:56:12 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -493,10 +493,66 @@ begin
end;
end;
+ -- Get the arguments from the command line and from the eventual
+ -- argument file(s) specified on the command line.
+
for Arg in Command_Arg + 1 .. Argument_Count loop
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'(Argument (Arg));
+ declare
+ The_Arg : constant String := Argument (Arg);
+ begin
+ -- Check if an argument file is specified
+
+ if The_Arg (The_Arg'First) = '@' then
+ declare
+ Arg_File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 256);
+ Last : Natural;
+
+ begin
+ -- Open the file. Fail if the file cannot be found.
+
+ begin
+ Open
+ (Arg_File, In_File,
+ The_Arg (The_Arg'First + 1 .. The_Arg'Last));
+
+ exception
+ when others =>
+ Put
+ (Standard_Error, "Cannot open argument file """);
+ Put
+ (Standard_Error,
+ The_Arg (The_Arg'First + 1 .. The_Arg'Last));
+
+ Put_Line (Standard_Error, """");
+ raise Error_Exit;
+ end;
+
+ -- Read line by line and put the content of each
+ -- non empty line in the Last_Switches table.
+
+ while not End_Of_File (Arg_File) loop
+ Get_Line (Arg_File, Line, Last);
+
+ if Last /= 0 then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Line (1 .. Last));
+ end if;
+ end loop;
+
+ Close (Arg_File);
+ end;
+
+ else
+ -- It is not an argument file; just put the argument in
+ -- the Last_Switches table.
+
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(The_Arg);
+ end if;
+ end;
end loop;
end if;
end if;
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.13
diff -u -p -r1.13 gnatlink.adb
--- gnatlink.adb 13 Jan 2004 11:51:32 -0000 1.13
+++ gnatlink.adb 26 Jan 2004 11:56:12 -0000
@@ -673,6 +673,11 @@ procedure Gnatlink is
-- Predicate indicating whether this target uses the GNU linker. In
-- this case we must output a GNU linker compatible response file.
+ Opening : aliased constant String := """";
+ Closing : aliased constant String := '"' & ASCII.LF;
+ -- Needed to quote object paths in object list files when GNU linker
+ -- is used.
+
procedure Get_Next_Line;
-- Read the next line from the binder file without the line
-- terminator.
@@ -883,6 +888,8 @@ procedure Gnatlink is
-- If target is using the GNU linker we must add a special header
-- and footer in the response file.
-- The syntax is : INPUT (object1.o object2.o ... )
+ -- Because the GNU linker does not like name with characters such
+ -- as '!', we must put the object paths between double quotes.
if Using_GNU_Linker then
declare
@@ -895,9 +902,22 @@ 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;
+
Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address,
- Linker_Objects.Table (J).all'Length);
- Status := Write (Tname_FD, ASCII.LF'Address, 1);
+ Linker_Objects.Table (J).all'Length);
+
+ -- Closing quote for GNU linker
+
+ if Using_GNU_Linker then
+ Status := Write (Tname_FD, Closing'Address, 2);
+
+ else
+ Status := Write (Tname_FD, ASCII.LF'Address, 1);
+ end if;
Response_File_Objects.Increment_Last;
Response_File_Objects.Table (Response_File_Objects.Last) :=
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.5
diff -u -p -r1.5 Makefile.generic
--- Makefile.generic 12 Jan 2004 11:36:13 -0000 1.5
+++ Makefile.generic 26 Jan 2004 11:56:12 -0000
@@ -337,21 +337,16 @@ internal-build: $(LINKER) archive-object
else
# C/C++ main
-# The trick here is to force gnatmake to bind/link, even if there is no
-# Ada main program. To achieve this effect, we use the -z switch, which is
-# close enough to our needs, and the usual -n gnatbind switch and --LINK=
-# gnatlink switch.
link: $(LINKER) archive-objects force
- $(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
- -bargs -n -largs $(LARGS) $(LDFLAGS)
+ $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
- @$(GNATMAKE) $(EXEC_RULE) -z \
- -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
- -bargs -n \
- -largs $(LARGS) $(LDFLAGS)
+ @echo $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(GNATMAKE) $(EXEC_RULE) \
+ -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
+ -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
endif
else
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.67
diff -u -p -r1.67 Makefile.in
--- Makefile.in 23 Jan 2004 10:30:04 -0000 1.67
+++ Makefile.in 26 Jan 2004 11:56:12 -0000
@@ -1287,11 +1287,13 @@ ifeq ($(strip $(filter-out %x86_64 linux
system.ads<5nsystem.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb
- MISCLIB=
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
+ GMEM_LIB = gmemlib
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
+
endif
# The runtime library for gnat comprises two directories. One contains the
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.14
diff -u -p -r1.14 snames.adb
--- snames.adb 20 Nov 2003 09:54:02 -0000 1.14
+++ snames.adb 26 Jan 2004 11:56:12 -0000
@@ -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- --
@@ -690,6 +690,7 @@ package body Snames is
-- xxxRA RAs type access routine for type xxx (Exp_TSS)
-- xxxRD RAs type dereference routine for type xxx (Exp_TSS)
-- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
+ -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
-- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
-- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
-- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.4
diff -u -p -r1.4 vms_conv.adb
--- vms_conv.adb 21 Jan 2004 10:35:18 -0000 1.4
+++ vms_conv.adb 26 Jan 2004 11:56:12 -0000
@@ -40,6 +40,9 @@ package body VMS_Conv is
Arg_Num : Natural;
-- Argument number
+ Arg_File : Ada.Text_IO.File_Type;
+ -- A file where arguments are read from
+
Commands : Item_Ptr;
-- Pointer to head of list of command items, one for each command, with
-- the end of the list marked by a null pointer.
@@ -119,6 +122,14 @@ package body VMS_Conv is
-- updating Ptr appropriatelly. Note that in the case of use of ! the
-- result may be to remove a previously placed switch.
+ procedure Preprocess_Command_Data;
+ -- Preprocess the string form of the command and options list into the
+ -- internal form.
+
+ procedure Process_Argument (The_Command : in out Command_Type);
+ -- Process one argument from the command line, or one line from
+ -- from a command line file. For the first call, set The_Command.
+
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr);
-- Check that N is a valid command or option name, i.e. that it is of the
-- form of an Ada identifier with upper case letters and underscores.
@@ -736,61 +747,12 @@ package body VMS_Conv is
end loop;
end Place_Unix_Switches;
- --------------------------------
- -- Validate_Command_Or_Option --
- --------------------------------
-
- procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
- begin
- pragma Assert (N'Length > 0);
-
- for J in N'Range loop
- if N (J) = '_' then
- pragma Assert (N (J - 1) /= '_');
- null;
- else
- pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
- null;
- end if;
- end loop;
- end Validate_Command_Or_Option;
-
- --------------------------
- -- Validate_Unix_Switch --
- --------------------------
-
- procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
- begin
- if S (S'First) = '`' then
- return;
- end if;
-
- pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
-
- for J in S'First + 1 .. S'Last loop
- pragma Assert (S (J) /= ' ');
-
- if S (J) = '!' then
- pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
- null;
- end if;
- end loop;
- end Validate_Unix_Switch;
+ -----------------------------
+ -- Preprocess_Command_Data --
+ -----------------------------
- --------------------
- -- VMS_Conversion --
- --------------------
-
- -- This function is *far* too long and *far* too heavily nested, it
- -- needs procedural abstraction ???
-
- procedure VMS_Conversion (The_Command : out Command_Type) is
+ procedure Preprocess_Command_Data is
begin
- Buffer.Init;
-
- -- First we must preprocess the string form of the command and options
- -- list into the internal form that we use.
-
for C in Real_Command_Type loop
declare
Command : constant Item_Ptr := new Command_Item;
@@ -1016,288 +978,475 @@ package body VMS_Conv is
end loop;
end;
end loop;
+ end Preprocess_Command_Data;
- -- If no parameters, give complete list of commands
-
- if Argument_Count = 0 then
- Output_Version;
- New_Line;
- Put_Line ("List of available commands");
- New_Line;
+ ----------------------
+ -- Process_Argument --
+ ----------------------
- while Commands /= null loop
- Put (Commands.Usage.all);
- Set_Col (53);
- Put_Line (Commands.Unix_String.all);
- Commands := Commands.Next;
+ procedure Process_Argument (The_Command : in out Command_Type) is
+ Argv : String_Access;
+ Arg_Idx : Integer;
+
+ function Get_Arg_End
+ (Argv : String;
+ Arg_Idx : Integer) return Integer;
+ -- Begins looking at Arg_Idx + 1 and returns the index of the
+ -- last character before a slash or else the index of the last
+ -- character in the string Argv.
+
+ -----------------
+ -- Get_Arg_End --
+ -----------------
+
+ function Get_Arg_End
+ (Argv : String;
+ Arg_Idx : Integer) return Integer
+ is
+ begin
+ for J in Arg_Idx + 1 .. Argv'Last loop
+ if Argv (J) = '/' then
+ return J - 1;
+ end if;
end loop;
- raise Normal_Exit;
- end if;
+ return Argv'Last;
+ end Get_Arg_End;
- Arg_Num := 1;
+ -- Start of processing for Process_Argument
- -- Loop through arguments
+ begin
+ -- If an argument file is open, read the next non empty line
- while Arg_Num <= Argument_Count loop
+ if Is_Open (Arg_File) then
+ declare
+ Line : String (1 .. 256);
+ Last : Natural;
+ begin
+ loop
+ Get_Line (Arg_File, Line, Last);
+ exit when Last /= 0 or else End_Of_File (Arg_File);
+ end loop;
- Process_Argument : declare
- Argv : String_Access;
- Arg_Idx : Integer;
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer) return Integer;
- -- Begins looking at Arg_Idx + 1 and returns the index of the
- -- last character before a slash or else the index of the last
- -- character in the string Argv.
-
- -----------------
- -- Get_Arg_End --
- -----------------
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer) return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Argv'Last loop
- if Argv (J) = '/' then
- return J - 1;
- end if;
- end loop;
+ -- If the end of the argument file has been reached, close it
- return Argv'Last;
- end Get_Arg_End;
+ if End_Of_File (Arg_File) then
+ Close (Arg_File);
- -- Start of processing for Process_Argument
+ -- If the last line was empty, return after increasing Arg_Num
+ -- to go to the next argument on the comment line.
- begin
- Argv := new String'(Argument (Arg_Num));
- Arg_Idx := Argv'First;
+ if Last = 0 then
+ Arg_Num := Arg_Num + 1;
+ return;
+ end if;
+ end if;
- <<Tryagain_After_Coalesce>>
- loop
- declare
- Next_Arg_Idx : Integer;
- Arg : String_Access;
+ Argv := new String'(Line (1 .. Last));
+ Arg_Idx := 1;
- begin
- Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
+ if Argv (1) = '@' then
+ Put_Line (Standard_Error, "argument file cannot contain @cmd");
+ raise Error_Exit;
+ end if;
+ end;
- -- The first one must be a command name
+ else
+ -- No argument file is open, get the argument on the command line
- if Arg_Num = 1 and then Arg_Idx = Argv'First then
- Command := Matching_Name (Arg.all, Commands);
+ Argv := new String'(Argument (Arg_Num));
+ Arg_Idx := Argv'First;
- if Command = null then
- raise Error_Exit;
- end if;
+ -- Check if this is the specification of an argument file
- The_Command := Command.Command;
+ if Argv (Arg_Idx) = '@' then
+ -- The first argument on the command line cannot be an argument
+ -- file.
+
+ if Arg_Num = 1 then
+ Put_Line
+ (Standard_Error,
+ "Cannot specify argument line before command");
+ raise Error_Exit;
+ end if;
- -- Give usage information if only command given
+ -- Open the file, after conversion of the name to canonical form.
+ -- Fail if file is not found.
- if Argument_Count = 1
- and then Next_Arg_Idx = Argv'Last
- then
- Output_Version;
- New_Line;
- Put_Line
- ("List of available qualifiers and options");
- New_Line;
-
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
+ declare
+ Canonical_File_Name : String_Access :=
+ To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last));
+ begin
+ Open (Arg_File, In_File, Canonical_File_Name.all);
+ Free (Canonical_File_Name);
+ return;
+
+ exception
+ when others =>
+ Put (Standard_Error, "Cannot open argument file """);
+ Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last));
+ Put_Line (Standard_Error, """");
+ raise Error_Exit;
+ end;
+ end if;
+ end if;
- declare
- Sw : Item_Ptr := Command.Switches;
+ <<Tryagain_After_Coalesce>>
+ loop
+ declare
+ Next_Arg_Idx : Integer;
+ Arg : String_Access;
- begin
- while Sw /= null loop
- Put (" ");
- Put (Sw.Name.all);
+ begin
+ Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
- case Sw.Translation is
+ -- The first one must be a command name
- when T_Other =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all &
- "/<other>");
+ if Arg_Num = 1 and then Arg_Idx = Argv'First then
+ Command := Matching_Name (Arg.all, Commands);
- when T_Direct =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all);
+ if Command = null then
+ raise Error_Exit;
+ end if;
- when T_Directories =>
- Put ("=(direc,direc,..direc)");
- Set_Col (53);
- Put (Sw.Unix_String.all);
- Put (" direc ");
- Put (Sw.Unix_String.all);
- Put_Line (" direc ...");
+ The_Command := Command.Command;
- when T_Directory =>
- Put ("=directory");
- Set_Col (53);
- Put (Sw.Unix_String.all);
+ -- Give usage information if only command given
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ if Argument_Count = 1
+ and then Next_Arg_Idx = Argv'Last
+ then
+ Output_Version;
+ New_Line;
+ Put_Line
+ ("List of available qualifiers and options");
+ New_Line;
+
+ Put (Command.Usage.all);
+ Set_Col (53);
+ Put_Line (Command.Unix_String.all);
+
+ declare
+ Sw : Item_Ptr := Command.Switches;
+
+ begin
+ while Sw /= null loop
+ Put (" ");
+ Put (Sw.Name.all);
+
+ case Sw.Translation is
+
+ when T_Other =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all &
+ "/<other>");
+
+ when T_Direct =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all);
+
+ when T_Directories =>
+ Put ("=(direc,direc,..direc)");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+ Put (" direc ");
+ Put (Sw.Unix_String.all);
+ Put_Line (" direc ...");
+
+ when T_Directory =>
+ Put ("=directory");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put_Line ("directory ");
+
+ when T_File | T_No_Space_File =>
+ Put ("=file");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put_Line ("file ");
+
+ when T_Numeric =>
+ Put ("=nnn");
+ Set_Col (53);
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First) = '`'
+ then
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
+ Put (Sw.Unix_String.all);
+ end if;
+
+ Put_Line ("nnn");
+
+ when T_Alphanumplus =>
+ Put ("=xyz");
+ Set_Col (53);
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First) = '`'
+ then
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
+ Put (Sw.Unix_String.all);
+ end if;
+
+ Put_Line ("xyz");
+
+ when T_String =>
+ Put ("=");
+ Put ('"');
+ Put ("<string>");
+ Put ('"');
+ Set_Col (53);
+
+ Put (Sw.Unix_String.all);
+
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put ("<string>");
+ New_Line;
+
+ when T_Commands =>
+ Put (" (switches for ");
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 7
+ .. Sw.Unix_String'Last));
+ Put (')');
+ Set_Col (53);
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First
+ .. Sw.Unix_String'First + 5));
+ Put_Line (" switches");
- Put_Line ("directory ");
+ when T_Options =>
+ declare
+ Opt : Item_Ptr := Sw.Options;
- when T_File | T_No_Space_File =>
- Put ("=file");
- Set_Col (53);
- Put (Sw.Unix_String.all);
+ begin
+ Put_Line ("=(option,option..)");
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Put (' ');
- end if;
+ while Opt /= null loop
+ Put (" ");
+ Put (Opt.Name.all);
- Put_Line ("file ");
+ if Opt = Sw.Options then
+ Put (" (D)");
+ end if;
- when T_Numeric =>
- Put ("=nnn");
Set_Col (53);
+ Put_Line (Opt.Unix_String.all);
+ Opt := Opt.Next;
+ end loop;
+ end;
- if Sw.Unix_String
- (Sw.Unix_String'First) = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
+ end case;
- Put_Line ("nnn");
+ Sw := Sw.Next;
+ end loop;
+ end;
- when T_Alphanumplus =>
- Put ("=xyz");
- Set_Col (53);
+ raise Normal_Exit;
+ end if;
- if Sw.Unix_String
- (Sw.Unix_String'First) = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
+ -- Special handling for internal debugging switch /?
- Put_Line ("xyz");
+ elsif Arg.all = "/?" then
+ Display_Command := True;
- when T_String =>
- Put ("=");
- Put ('"');
- Put ("<string>");
- Put ('"');
- Set_Col (53);
+ -- Copy -switch unchanged
- Put (Sw.Unix_String.all);
+ elsif Arg (Arg'First) = '-' then
+ Place (' ');
+ Place (Arg.all);
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Put (' ');
- end if;
+ -- Copy quoted switch with quotes stripped
- Put ("<string>");
- New_Line;
+ elsif Arg (Arg'First) = '"' then
+ if Arg (Arg'Last) /= '"' then
+ Put (Standard_Error, "misquoted argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- when T_Commands =>
- Put (" (switches for ");
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 7
- .. Sw.Unix_String'Last));
- Put (')');
- Set_Col (53);
- Put (Sw.Unix_String
- (Sw.Unix_String'First
- .. Sw.Unix_String'First + 5));
- Put_Line (" switches");
-
- when T_Options =>
- declare
- Opt : Item_Ptr := Sw.Options;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
+ else
+ Place (' ');
+ Place (Arg (Arg'First + 1 .. Arg'Last - 1));
+ end if;
- end case;
+ -- Parameter Argument
- Sw := Sw.Next;
- end loop;
+ elsif Arg (Arg'First) /= '/'
+ and then Make_Commands_Active = null
+ then
+ Param_Count := Param_Count + 1;
+
+ if Param_Count <= Command.Params'Length then
+
+ case Command.Params (Param_Count) is
+
+ when File | Optional_File =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
+
+ begin
+ Place (' ');
+ Place_Lower (Normal_File.all);
+
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
end;
- raise Normal_Exit;
- end if;
+ when Unlimited_Files =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
+
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
- -- Special handling for internal debugging switch /?
+ begin
+ for J in Arg'Range loop
+ if Arg (J) = '*'
+ or else Arg (J) = '%'
+ then
+ File_Is_Wild := True;
+ end if;
+ end loop;
- elsif Arg.all = "/?" then
- Display_Command := True;
+ if File_Is_Wild then
+ File_List := To_Canonical_File_List
+ (Arg.all, False);
- -- Copy -switch unchanged
+ for J in File_List.all'Range loop
+ Place (' ');
+ Place_Lower (File_List.all (J).all);
+ end loop;
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
+ else
+ Place (' ');
+ Place_Lower (Normal_File.all);
- -- Copy quoted switch with quotes stripped
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+ end if;
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ Param_Count := Param_Count - 1;
+ end;
- else
+ when Other_As_Is =>
Place (' ');
- Place (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
+ Place (Arg.all);
- -- Parameter Argument
+ when Unlimited_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+ Param_Count := Param_Count - 1;
+
+ when Files_Or_Wildcard =>
+
+ -- Remove spaces from a comma separated list
+ -- of file names and adjust control variables
+ -- accordingly.
+
+ while Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
+ loop
+ Argv := new String'
+ (Argv.all & Argument (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx :=
+ Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ end loop;
+
+ -- Parse the comma separated list of VMS
+ -- filenames and place them on the command
+ -- line as space separated Unix style
+ -- filenames. Lower case and add default
+ -- extension as appropriate.
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
+ declare
+ Arg1_Idx : Integer := Arg'First;
- if Param_Count <= Command.Params'Length then
+ function Get_Arg1_End
+ (Arg : String;
+ Arg_Idx : Integer) return Integer;
+ -- Begins looking at Arg_Idx + 1 and
+ -- returns the index of the last character
+ -- before a comma or else the index of the
+ -- last character in the string Arg.
+
+ ------------------
+ -- Get_Arg1_End --
+ ------------------
+
+ function Get_Arg1_End
+ (Arg : String;
+ Arg_Idx : Integer) return Integer
+ is
+ begin
+ for J in Arg_Idx + 1 .. Arg'Last loop
+ if Arg (J) = ',' then
+ return J - 1;
+ end if;
+ end loop;
- case Command.Params (Param_Count) is
+ return Arg'Last;
+ end Get_Arg1_End;
- when File | Optional_File =>
+ begin
+ loop
declare
- Normal_File : constant String_Access :=
- To_Canonical_File_Spec
- (Arg.all);
+ Next_Arg1_Idx :
+ constant Integer :=
+ Get_Arg1_End (Arg.all, Arg1_Idx);
+
+ Arg1 :
+ constant String :=
+ Arg (Arg1_Idx .. Next_Arg1_Idx);
+
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg1);
begin
Place (' ');
@@ -1309,584 +1458,536 @@ package body VMS_Conv is
Place ('.');
Place (Command.Defext);
end if;
+
+ Arg1_Idx := Next_Arg1_Idx + 1;
end;
- when Unlimited_Files =>
- declare
- Normal_File : constant String_Access :=
- To_Canonical_File_Spec
- (Arg.all);
+ exit when Arg1_Idx > Arg'Last;
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
+ -- Don't allow two or more commas in
+ -- a row
- begin
- for J in Arg'Range loop
- if Arg (J) = '*'
- or else Arg (J) = '%'
- then
- File_Is_Wild := True;
- end if;
- end loop;
+ if Arg (Arg1_Idx) = ',' then
+ Arg1_Idx := Arg1_Idx + 1;
+ if Arg1_Idx > Arg'Last or else
+ Arg (Arg1_Idx) = ','
+ then
+ Put_Line
+ (Standard_Error,
+ "Malformed Parameter: " &
+ Arg.all);
+ Put (Standard_Error, "usage: ");
+ Put_Line (Standard_Error,
+ Command.Usage.all);
+ raise Error_Exit;
+ end if;
+ end if;
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for J in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (J).all);
- end loop;
+ end loop;
+ end;
+ end case;
+ end if;
- else
- Place (' ');
- Place_Lower (Normal_File.all);
+ -- Qualifier argument
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end if;
+ else
+ -- This code is too heavily nested, should be
+ -- separated out as separate subprogram ???
- Param_Count := Param_Count - 1;
- end;
+ declare
+ Sw : Item_Ptr;
+ SwP : Natural;
+ P2 : Natural;
+ Endp : Natural := 0; -- avoid warning!
+ Opt : Item_Ptr;
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
+ begin
+ SwP := Arg'First;
+ while SwP < Arg'Last
+ and then Arg (SwP + 1) /= '='
+ loop
+ SwP := SwP + 1;
+ end loop;
- when Unlimited_As_Is =>
- Place (' ');
- Place (Arg.all);
- Param_Count := Param_Count - 1;
+ -- At this point, the switch name is in
+ -- Arg (Arg'First..SwP) and if that is not the
+ -- whole switch, then there is an equal sign at
+ -- Arg (SwP + 1) and the rest of Arg is what comes
+ -- after the equal sign.
+
+ -- If make commands are active, see if we have
+ -- another COMMANDS_TRANSLATION switch belonging
+ -- to gnatmake.
+
+ if Make_Commands_Active /= null then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw /= null
+ and then Sw.Translation = T_Commands
+ then
+ null;
+
+ else
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Make_Commands_Active.Switches,
+ Quiet => False);
+ end if;
+
+ -- For case of GNAT MAKE or CHOP, if we cannot
+ -- find the switch, then see if it is a
+ -- recognized compiler switch instead, and if
+ -- so process the compiler switch.
+
+ elsif Command.Name.all = "MAKE"
+ or else Command.Name.all = "CHOP" then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw = null then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Matching_Name
+ ("COMPILE", Commands).Switches,
+ Quiet => False);
+ end if;
+
+ -- For all other cases, just search the relevant
+ -- command.
+
+ else
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => False);
+ end if;
+
+ if Sw /= null then
+ case Sw.Translation is
- when Files_Or_Wildcard =>
+ when T_Direct =>
+ Place_Unix_Switches (Sw.Unix_String);
+ if SwP < Arg'Last
+ and then Arg (SwP + 1) = '='
+ then
+ Put (Standard_Error,
+ "qualifier options ignored: ");
+ Put_Line (Standard_Error, Arg.all);
+ end if;
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
+ when T_Directories =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directories for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+
+ -- Remove spaces from a comma separated
+ -- list of file names and adjust
+ -- control variables accordingly.
- while Arg_Num < Argument_Count and then
+ if Arg_Num < Argument_Count and then
(Argv (Argv'Last) = ',' xor
Argument (Arg_Num + 1)
(Argument (Arg_Num + 1)'First) = ',')
- loop
- Argv := new String'
- (Argv.all & Argument (Arg_Num + 1));
+ then
+ Argv :=
+ new String'(Argv.all
+ & Argument
+ (Arg_Num + 1));
Arg_Num := Arg_Num + 1;
Arg_Idx := Argv'First;
Next_Arg_Idx :=
Get_Arg_End (Argv.all, Arg_Idx);
Arg := new String'
(Argv (Arg_Idx .. Next_Arg_Idx));
- end loop;
+ goto Tryagain_After_Coalesce;
+ end if;
- -- Parse the comma separated list of VMS
- -- filenames and place them on the command
- -- line as space separated Unix style
- -- filenames. Lower case and add default
- -- extension as appropriate.
+ Put (Standard_Error,
+ "incorrectly parenthesized " &
+ "or malformed argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- declare
- Arg1_Idx : Integer := Arg'First;
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
- function Get_Arg1_End
- (Arg : String;
- Arg_Idx : Integer) return Integer;
- -- Begins looking at Arg_Idx + 1 and
- -- returns the index of the last character
- -- before a comma or else the index of the
- -- last character in the string Arg.
-
- ------------------
- -- Get_Arg1_End --
- ------------------
-
- function Get_Arg1_End
- (Arg : String;
- Arg_Idx : Integer) return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Arg'Last loop
- if Arg (J) = ',' then
- return J - 1;
- end if;
- end loop;
+ while SwP <= Endp loop
+ declare
+ Dir_Is_Wild : Boolean := False;
+ Dir_Maybe_Is_Wild : Boolean := False;
- return Arg'Last;
- end Get_Arg1_End;
+ Dir_List : String_Access_List_Access;
begin
+ P2 := SwP;
+
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
loop
- declare
- Next_Arg1_Idx :
- constant Integer :=
- Get_Arg1_End (Arg.all, Arg1_Idx);
-
- Arg1 :
- constant String :=
- Arg (Arg1_Idx .. Next_Arg1_Idx);
-
- Normal_File :
- constant String_Access :=
- To_Canonical_File_Spec (Arg1);
-
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
-
- Arg1_Idx := Next_Arg1_Idx + 1;
- end;
-
- exit when Arg1_Idx > Arg'Last;
-
- -- Don't allow two or more commas in
- -- a row
-
- if Arg (Arg1_Idx) = ',' then
- Arg1_Idx := Arg1_Idx + 1;
- if Arg1_Idx > Arg'Last or else
- Arg (Arg1_Idx) = ','
- then
- Put_Line
- (Standard_Error,
- "Malformed Parameter: " &
- Arg.all);
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error,
- Command.Usage.all);
- raise Error_Exit;
- end if;
+ -- A wildcard directory spec on
+ -- VMS will contain either * or
+ -- % or ...
+
+ if Arg (P2) = '*' then
+ Dir_Is_Wild := True;
+
+ elsif Arg (P2) = '%' then
+ Dir_Is_Wild := True;
+
+ elsif Dir_Maybe_Is_Wild
+ and then Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Is_Wild := True;
+ Dir_Maybe_Is_Wild := False;
+
+ elsif Dir_Maybe_Is_Wild then
+ Dir_Maybe_Is_Wild := False;
+
+ elsif Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Maybe_Is_Wild := True;
+
end if;
+ P2 := P2 + 1;
end loop;
- end;
- end case;
- end if;
- -- Qualifier argument
+ if Dir_Is_Wild then
+ Dir_List :=
+ To_Canonical_File_List
+ (Arg (SwP .. P2), True);
- else
- -- This code is too heavily nested, should be
- -- separated out as separate subprogram ???
-
- declare
- Sw : Item_Ptr;
- SwP : Natural;
- P2 : Natural;
- Endp : Natural := 0; -- avoid warning!
- Opt : Item_Ptr;
-
- begin
- SwP := Arg'First;
- while SwP < Arg'Last
- and then Arg (SwP + 1) /= '='
- loop
- SwP := SwP + 1;
- end loop;
+ for J in Dir_List.all'Range loop
+ Place_Unix_Switches
+ (Sw.Unix_String);
+ Place_Lower
+ (Dir_List.all (J).all);
+ end loop;
- -- At this point, the switch name is in
- -- Arg (Arg'First..SwP) and if that is not the
- -- whole switch, then there is an equal sign at
- -- Arg (SwP + 1) and the rest of Arg is what comes
- -- after the equal sign.
-
- -- If make commands are active, see if we have
- -- another COMMANDS_TRANSLATION switch belonging
- -- to gnatmake.
+ else
+ Place_Unix_Switches
+ (Sw.Unix_String);
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP .. P2), False).all);
+ end if;
- if Make_Commands_Active /= null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
+ SwP := P2 + 2;
+ end;
+ end loop;
- if Sw /= null
- and then Sw.Translation = T_Commands
- then
- null;
+ when T_Directory =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directory for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Make_Commands_Active.Switches,
- Quiet => False);
- end if;
+ Place_Unix_Switches (Sw.Unix_String);
- -- For case of GNAT MAKE or CHOP, if we cannot
- -- find the switch, then see if it is a
- -- recognized compiler switch instead, and if
- -- so process the compiler switch.
-
- elsif Command.Name.all = "MAKE"
- or else Command.Name.all = "CHOP" then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
+ -- Some switches end in "=". No space
+ -- here
- if Sw = null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Matching_Name
- ("COMPILE", Commands).Switches,
- Quiet => False);
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
+
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP + 2 .. Arg'Last),
+ False).all);
end if;
- -- For all other cases, just search the relevant
- -- command.
+ when T_File | T_No_Space_File =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing file for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => False);
- end if;
+ else
+ Place_Unix_Switches (Sw.Unix_String);
- if Sw /= null then
- case Sw.Translation is
+ -- Some switches end in "=". No space
+ -- here.
- when T_Direct =>
- Place_Unix_Switches (Sw.Unix_String);
- if SwP < Arg'Last
- and then Arg (SwP + 1) = '='
- then
- Put (Standard_Error,
- "qualifier options ignored: ");
- Put_Line (Standard_Error, Arg.all);
- end if;
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
- when T_Directories =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directories for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
-
- -- Remove spaces from a comma separated
- -- list of file names and adjust
- -- control variables accordingly.
-
- if Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- then
- Argv :=
- new String'(Argv.all
- & Argument
- (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx :=
- Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- goto Tryagain_After_Coalesce;
- end if;
+ Place_Lower
+ (To_Canonical_File_Spec
+ (Arg (SwP + 2 .. Arg'Last)).all);
+ end if;
- Put (Standard_Error,
- "incorrectly parenthesized " &
- "or malformed argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ when T_Numeric =>
+ if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line
+ (Standard_Error, " must be numeric");
+ Errors := Errors + 1;
+ end if;
- while SwP <= Endp loop
- declare
- Dir_Is_Wild : Boolean := False;
- Dir_Maybe_Is_Wild : Boolean := False;
-
- Dir_List : String_Access_List_Access;
-
- begin
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- -- A wildcard directory spec on
- -- VMS will contain either * or
- -- % or ...
-
- if Arg (P2) = '*' then
- Dir_Is_Wild := True;
-
- elsif Arg (P2) = '%' then
- Dir_Is_Wild := True;
-
- elsif Dir_Maybe_Is_Wild
- and then Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Is_Wild := True;
- Dir_Maybe_Is_Wild := False;
-
- elsif Dir_Maybe_Is_Wild then
- Dir_Maybe_Is_Wild := False;
-
- elsif Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Maybe_Is_Wild := True;
-
- end if;
-
- P2 := P2 + 1;
- end loop;
-
- if Dir_Is_Wild then
- Dir_List :=
- To_Canonical_File_List
- (Arg (SwP .. P2), True);
-
- for J in Dir_List.all'Range loop
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (Dir_List.all (J).all);
- end loop;
-
- else
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP .. P2), False).all);
- end if;
+ when T_Alphanumplus =>
+ if OK_Alphanumerplus
+ (Arg (SwP + 2 .. Arg'Last))
+ then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
- SwP := P2 + 2;
- end;
- end loop;
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line (Standard_Error,
+ " must be alphanumeric");
+ Errors := Errors + 1;
+ end if;
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ when T_String =>
- else
- Place_Unix_Switches (Sw.Unix_String);
+ -- A String value must be extended to the
+ -- end of the Argv, otherwise strings like
+ -- "foo/bar" get split at the slash.
+
+ -- The begining and ending of the string
+ -- are flagged with embedded nulls which
+ -- are removed when building the Spawn
+ -- call. Nulls are use because they won't
+ -- show up in a /? output. Quotes aren't
+ -- used because that would make it
+ -- difficult to embed them.
+
+ Place_Unix_Switches (Sw.Unix_String);
+
+ if Next_Arg_Idx /= Argv'Last then
+ Next_Arg_Idx := Argv'Last;
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+
+ SwP := Arg'First;
+ while SwP < Arg'Last and then
+ Arg (SwP + 1) /= '=' loop
+ SwP := SwP + 1;
+ end loop;
+ end if;
- -- Some switches end in "=". No space
- -- here
+ Place (ASCII.NUL);
+ Place (Arg (SwP + 2 .. Arg'Last));
+ Place (ASCII.NUL);
+
+ when T_Commands =>
+
+ -- Output -largs/-bargs/-cargs
+
+ Place (' ');
+ Place (Sw.Unix_String
+ (Sw.Unix_String'First ..
+ Sw.Unix_String'First + 5));
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last) = "MAKE"
+ then
+ Make_Commands_Active := null;
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
+ else
+ -- Set source of new commands, also
+ -- setting this non-null indicates that
+ -- we are in the special commands mode
+ -- for processing the -xargs case.
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last),
- False).all);
- end if;
+ Make_Commands_Active :=
+ Matching_Name
+ (Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last),
+ Commands);
+ end if;
- when T_File | T_No_Space_File =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing file for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ when T_Options =>
+ if SwP + 1 > Arg'Last then
+ Place_Unix_Switches
+ (Sw.Options.Unix_String);
+ SwP := Endp + 1;
+
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+ Put (Standard_Error,
+ "incorrectly parenthesized argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+ SwP := Endp + 1;
- else
- Place_Unix_Switches (Sw.Unix_String);
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
- -- Some switches end in "=". No space
- -- here.
+ while SwP <= Endp loop
+ P2 := SwP;
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
+ P2 := P2 + 1;
+ end loop;
- Place_Lower
- (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
+ -- Option name is in Arg (SwP .. P2)
- when T_Numeric =>
- if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
+ Opt := Matching_Name (Arg (SwP .. P2),
+ Sw.Options);
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line
- (Standard_Error, " must be numeric");
- Errors := Errors + 1;
- end if;
+ if Opt /= null then
+ Place_Unix_Switches
+ (Opt.Unix_String);
+ end if;
- when T_Alphanumplus =>
- if OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
+ SwP := P2 + 2;
+ end loop;
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
+ when T_Other =>
+ Place_Unix_Switches
+ (new String'(Sw.Unix_String.all &
+ Arg.all));
- when T_String =>
+ end case;
+ end if;
+ end;
+ end if;
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
-
- -- The begining and ending of the string
- -- are flagged with embedded nulls which
- -- are removed when building the Spawn
- -- call. Nulls are use because they won't
- -- show up in a /? output. Quotes aren't
- -- used because that would make it
- -- difficult to embed them.
-
- Place_Unix_Switches (Sw.Unix_String);
-
- if Next_Arg_Idx /= Argv'Last then
- Next_Arg_Idx := Argv'Last;
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
-
- SwP := Arg'First;
- while SwP < Arg'Last and then
- Arg (SwP + 1) /= '=' loop
- SwP := SwP + 1;
- end loop;
- end if;
+ Arg_Idx := Next_Arg_Idx + 1;
+ end;
- Place (ASCII.NUL);
- Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
+ exit when Arg_Idx > Argv'Last;
- when T_Commands =>
+ end loop;
- -- Output -largs/-bargs/-cargs
+ if not Is_Open (Arg_File) then
+ Arg_Num := Arg_Num + 1;
+ end if;
+ end Process_Argument;
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
-
- if Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last) = "MAKE"
- then
- Make_Commands_Active := null;
+ --------------------------------
+ -- Validate_Command_Or_Option --
+ --------------------------------
- else
- -- Set source of new commands, also
- -- setting this non-null indicates that
- -- we are in the special commands mode
- -- for processing the -xargs case.
-
- Make_Commands_Active :=
- Matching_Name
- (Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last),
- Commands);
- end if;
+ procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
+ begin
+ pragma Assert (N'Length > 0);
- when T_Options =>
- if SwP + 1 > Arg'Last then
- Place_Unix_Switches
- (Sw.Options.Unix_String);
- SwP := Endp + 1;
+ for J in N'Range loop
+ if N (J) = '_' then
+ pragma Assert (N (J - 1) /= '_');
+ null;
+ else
+ pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
+ null;
+ end if;
+ end loop;
+ end Validate_Command_Or_Option;
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
+ --------------------------
+ -- Validate_Unix_Switch --
+ --------------------------
- elsif Arg (Arg'Last) /= ')' then
- Put
- (Standard_Error,
- "incorrectly parenthesized " &
- "argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
- SwP := Endp + 1;
+ procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
+ begin
+ if S (S'First) = '`' then
+ return;
+ end if;
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
+ pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
- while SwP <= Endp loop
- P2 := SwP;
+ for J in S'First + 1 .. S'Last loop
+ pragma Assert (S (J) /= ' ');
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
+ if S (J) = '!' then
+ pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
+ null;
+ end if;
+ end loop;
+ end Validate_Unix_Switch;
- -- Option name is in Arg (SwP .. P2)
+ --------------------
+ -- VMS_Conversion --
+ --------------------
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
+ procedure VMS_Conversion (The_Command : out Command_Type) is
+ Result : Command_Type := Undefined;
+ Result_Set : Boolean := False;
+ begin
+ Buffer.Init;
- if Opt /= null then
- Place_Unix_Switches
- (Opt.Unix_String);
- end if;
+ -- First we must preprocess the string form of the command and options
+ -- list into the internal form that we use.
- SwP := P2 + 2;
- end loop;
+ Preprocess_Command_Data;
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all &
- Arg.all));
+ -- If no parameters, give complete list of commands
- end case;
- end if;
- end;
- end if;
+ if Argument_Count = 0 then
+ Output_Version;
+ New_Line;
+ Put_Line ("List of available commands");
+ New_Line;
- Arg_Idx := Next_Arg_Idx + 1;
- end;
+ while Commands /= null loop
+ Put (Commands.Usage.all);
+ Set_Col (53);
+ Put_Line (Commands.Unix_String.all);
+ Commands := Commands.Next;
+ end loop;
- exit when Arg_Idx > Argv'Last;
+ raise Normal_Exit;
+ end if;
- end loop;
- end Process_Argument;
+ Arg_Num := 1;
- Arg_Num := Arg_Num + 1;
+ -- Loop through arguments
+
+ while Arg_Num <= Argument_Count loop
+ Process_Argument (Result);
+
+ if not Result_Set then
+ The_Command := Result;
+ Result_Set := True;
+ end if;
end loop;
-- Gross error checking that the number of parameters is correct.
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-01-23 10:40 Arnaud Charlet
@ 2004-01-23 19:18 ` Laurent GUERBY
0 siblings, 0 replies; 178+ messages in thread
From: Laurent GUERBY @ 2004-01-23 19:18 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches, kenner
FYI, I run acats at -O3 in run_all.sh on x86-linux, and the patch (plus
other commits of the day) fixed 5 ICEs - Richard Kenner change probably,
but introduced a new failure cc70a01 which might be caused
by the same change since the code that fails at runtime involves a few
matrices and so probably alias sets.
Laurent
,.,. CC70A01 ACATS 2.5 04-01-23 14:03:33
---- CC70A01 Check that the visible part of a generic formal package
includes the first list of basic declarative items of
the package specification. Check for a generic package
where formal package has (<>) actual part.
* CC70A01 Unexpected exception raised - Block #1.
**** CC70A01 FAILED ****************************.
summary of results (run_all.sh
=== common 19
c24211a c34005a c34005d c34005g c34005j
c41103b c94008c cc3601a cc51d02 cxb3010
cxb3014 cxb3015 cxg2006 cxg2007 cxg2008
cxg2018 cxg2019 cxg2020 cxg2021
=== fixed 5
c34005o c34007g c41325a c43205i c43214d
=== new 1
cc70a01
On Fri, 2004-01-23 at 11:32, Arnaud Charlet wrote:
> Tested on x86-linux
> --
> 2004-01-23 Robert Dewar <dewar@gnat.com>
>
> * exp_aggr.adb: Minor reformatting
>
> * exp_ch9.adb: Minor code clean up
> Minor reformatting
> Fix bad character in comment
>
> PR ada/13471
> * targparm.adb (Get_Target_Parameters): Give clean abort error on
> unexpected end of file, along with more detailed message.
>
> 2004-01-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
>
> * exp_pakd.adb (Install_PAT): Clear Freeze_Node for PAT and Etype of
> PAT.
>
> * decl.c (copy_alias_set): New function.
> (gnat_to_gnu_entity, make_aligning_type, make_packable_type): Use it.
>
> 2004-01-23 Doug Rupp <rupp@gnat.com>
>
> * Makefile.in (install-gnatlib): Change occurrences of lib$$file to
> lib$${file} in case subsequent character is not a separator.
>
> 2004-01-23 Vincent Celier <celier@gnat.com>
>
> * 5vml-tgt.adb (Build_Dynamic_Library): Invoke gcc with -shared-libgcc
> when the GCC version is at least 3.
>
> * make.adb: (Scan_Make_Arg): Pass -B to Scan_Make_Switches
> Remove all "Opt.", to prepare for opt split
>
> * prj-part.adb (Parse_Single_Project): New Boolean out parameter
> Extends_All. Set to True when the project parsed is an extending all
> project. Fails for importing an extending all project only when the
> imported project is an extending all project.
> (Post_Parse_Context_Clause): Set Is_Extending_All to the with clause,
> depending on the value of Extends_All returned.
>
> * prj-proc.adb (Process): Check that no project shares its object
> directory with a project that extends it, directly or indirectly,
> including a virtual project.
> Check that no project extended by another project shares its object
> directory with another also extended project.
>
> * prj-tree.adb (Is_Extending_All, Set_Is_Extending_All): Allow for
> Kind = N_With_Clause
>
> * prj-tree.ads: Minor reformatting
> Indicate that Flag2 also applies to N_With_Clause (Is_Extending_All).
>
> 2004-01-23 Ed Schonberg <schonberg@gnat.com>
>
> * sem_ch13.adb (Analyze_Attribute_Definition_Clause): If the attribute
> applies to a type with an incomplete view, use full view in Name of
> clause, for consistency with uses of Get_Attribute_Definition_Clause.
>
> 2004-01-23 Arnaud Charlet <charlet@act-europe.fr>
>
> * 5itaprop.adb (Set_Priority): Reset the priority to 0 when using
> SCHED_RR, since other values are not supported by this policy.
> (Initialize): Move initialization of mutex attribute to package
> elaboration, to prevent early access to this variable.
>
> * Makefile.in: Remove mention of Makefile.adalib, unused.
>
> * Makefile.adalib: Removed, unused.
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-23 10:40 Arnaud Charlet
2004-01-23 19:18 ` Laurent GUERBY
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-23 10:40 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-01-23 Robert Dewar <dewar@gnat.com>
* exp_aggr.adb: Minor reformatting
* exp_ch9.adb: Minor code clean up
Minor reformatting
Fix bad character in comment
PR ada/13471
* targparm.adb (Get_Target_Parameters): Give clean abort error on
unexpected end of file, along with more detailed message.
2004-01-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* exp_pakd.adb (Install_PAT): Clear Freeze_Node for PAT and Etype of
PAT.
* decl.c (copy_alias_set): New function.
(gnat_to_gnu_entity, make_aligning_type, make_packable_type): Use it.
2004-01-23 Doug Rupp <rupp@gnat.com>
* Makefile.in (install-gnatlib): Change occurrences of lib$$file to
lib$${file} in case subsequent character is not a separator.
2004-01-23 Vincent Celier <celier@gnat.com>
* 5vml-tgt.adb (Build_Dynamic_Library): Invoke gcc with -shared-libgcc
when the GCC version is at least 3.
* make.adb: (Scan_Make_Arg): Pass -B to Scan_Make_Switches
Remove all "Opt.", to prepare for opt split
* prj-part.adb (Parse_Single_Project): New Boolean out parameter
Extends_All. Set to True when the project parsed is an extending all
project. Fails for importing an extending all project only when the
imported project is an extending all project.
(Post_Parse_Context_Clause): Set Is_Extending_All to the with clause,
depending on the value of Extends_All returned.
* prj-proc.adb (Process): Check that no project shares its object
directory with a project that extends it, directly or indirectly,
including a virtual project.
Check that no project extended by another project shares its object
directory with another also extended project.
* prj-tree.adb (Is_Extending_All, Set_Is_Extending_All): Allow for
Kind = N_With_Clause
* prj-tree.ads: Minor reformatting
Indicate that Flag2 also applies to N_With_Clause (Is_Extending_All).
2004-01-23 Ed Schonberg <schonberg@gnat.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): If the attribute
applies to a type with an incomplete view, use full view in Name of
clause, for consistency with uses of Get_Attribute_Definition_Clause.
2004-01-23 Arnaud Charlet <charlet@act-europe.fr>
* 5itaprop.adb (Set_Priority): Reset the priority to 0 when using
SCHED_RR, since other values are not supported by this policy.
(Initialize): Move initialization of mutex attribute to package
elaboration, to prevent early access to this variable.
* Makefile.in: Remove mention of Makefile.adalib, unused.
* Makefile.adalib: Removed, unused.
--
Index: 5itaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5itaprop.adb,v
retrieving revision 1.9
diff -u -p -r1.9 5itaprop.adb
--- 5itaprop.adb 13 Jan 2004 11:51:31 -0000 1.9
+++ 5itaprop.adb 23 Jan 2004 10:12:22 -0000
@@ -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- --
@@ -712,6 +712,7 @@ package body System.Task_Primitives.Oper
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
+ Param.sched_priority := 0;
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
@@ -1038,12 +1039,6 @@ package body System.Task_Primitives.Oper
begin
Environment_Task_ID := Environment_Task;
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the global RTS lock
@@ -1096,5 +1091,11 @@ begin
pragma Assert (Result = 0);
end if;
end loop;
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0);
end;
end System.Task_Primitives.Operations;
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.3
diff -u -p -r1.3 5vml-tgt.adb
--- 5vml-tgt.adb 5 Jan 2004 15:20:43 -0000 1.3
+++ 5vml-tgt.adb 23 Jan 2004 10:12:22 -0000
@@ -69,6 +69,14 @@ package body MLib.Tgt is
Success : Boolean := False;
+ Shared_Libgcc : aliased String := "-shared-libgcc";
+
+ No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
+ Shared_Libgcc_Switch : aliased Argument_List :=
+ (1 => Shared_Libgcc'Access);
+ Link_With_Shared_Libgcc : Argument_List_Access :=
+ No_Shared_Libgcc_Switch'Access;
+
------------------------------
-- Target dependent section --
------------------------------
@@ -242,6 +250,14 @@ package body MLib.Tgt is
-- Start of processing for Build_Dynamic_Library
begin
+ -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
+
+ if GCC_Version >= 3 then
+ Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
+ else
+ Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
+ end if;
+
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
for J in Inter'Range loop
@@ -451,7 +467,8 @@ package body MLib.Tgt is
(Output_File => Lib_File,
Objects => Ofiles & Additional_Objects.all,
Options => VMS_Options,
- Options_2 => Opts (Opts'First .. Last_Opt) &
+ Options_2 => Link_With_Shared_Libgcc.all &
+ Opts (Opts'First .. Last_Opt) &
Opts2 (Opts2'First .. Last_Opt2),
Driver_Name => Driver_Name);
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.25
diff -u -p -r1.25 decl.c
--- decl.c 15 Jan 2004 17:24:16 -0000 1.25
+++ decl.c 23 Jan 2004 10:12:23 -0000
@@ -82,6 +82,7 @@ static struct incomplete
Entity_Id full_type;
} *defer_incomplete_list = 0;
+static void copy_alias_set (tree, tree);
static tree substitution_list (Entity_Id, Entity_Id, tree, int);
static int allocatable_size_p (tree, int);
static struct attrib *build_attr_list (Entity_Id);
@@ -1605,13 +1606,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
tem = build_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
- /* ??? For now, we say that any component of aggregate type is
- addressable because the front end may take 'Reference of it.
- But we have to make it addressable if it must be passed by
- reference or it that is the default. */
+ /* If the type below this an multi-array type, then this
+ does not not have aliased components.
+
+ ??? Otherwise, for now, we say that any component of aggregate
+ type is addressable because the front end may take 'Reference
+ of it. But we have to make it addressable if it must be passed
+ by reference or it that is the default. */
TYPE_NONALIASED_COMPONENT (tem)
- = (! Has_Aliased_Components (gnat_entity)
- && ! AGGREGATE_TYPE_P (TREE_TYPE (tem)));
+ = ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1
+ : (! Has_Aliased_Components (gnat_entity)
+ && ! AGGREGATE_TYPE_P (TREE_TYPE (tem))));
}
/* If an alignment is specified, use it if valid. But ignore it for
@@ -1923,13 +1929,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
{
gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
- /* ??? For now, we say that any component of aggregate type is
- addressable because the front end may take 'Reference.
- But we have to make it addressable if it must be passed by
- reference or it that is the default. */
+ /* If the type below this an multi-array type, then this
+ does not not have aliased components.
+
+ ??? Otherwise, for now, we say that any component of aggregate
+ type is addressable because the front end may take 'Reference
+ of it. But we have to make it addressable if it must be passed
+ by reference or it that is the default. */
TYPE_NONALIASED_COMPONENT (gnu_type)
- = (! Has_Aliased_Components (gnat_entity)
- && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type)));
+ = ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1
+ : (! Has_Aliased_Components (gnat_entity)
+ && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))));
}
/* If we are at file level and this is a multi-dimensional array, we
@@ -2010,8 +2021,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* Set our alias set to that of our base type. This gives all
array subtypes the same alias set. */
- TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
- record_component_aliases (gnu_type);
+ copy_alias_set (gnu_type, gnu_base_type);
}
/* If this is a packed type, make this type the same as the packed
@@ -2408,11 +2418,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
if (Etype (gnat_entity) != gnat_entity
&& ! (Is_Private_Type (Etype (gnat_entity))
&& Full_View (Etype (gnat_entity)) == gnat_entity))
- {
- TYPE_ALIAS_SET (gnu_type)
- = get_alias_set (gnat_to_gnu_type (Etype (gnat_entity)));
- record_component_aliases (gnu_type);
- }
+ copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
/* Fill in locations of fields. */
annotate_rep (gnat_entity, gnu_type);
@@ -2644,8 +2650,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
- TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
- record_component_aliases (gnu_type);
+ copy_alias_set (gnu_type, gnu_base_type);
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
for (gnu_temp = gnu_subst_list;
@@ -4144,6 +4149,30 @@ mark_out_of_scope (Entity_Id gnat_entity
}
}
\f
+/* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
+ is a multi-dimensional array type, do this recursively. */
+
+static void
+copy_alias_set (tree gnu_new_type, tree gnu_old_type)
+{
+ if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
+ {
+ /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
+ array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
+ so we need to go down to what does. */
+ if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_old_type
+ = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
+
+ copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
+ }
+
+ TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
+ record_component_aliases (gnu_new_type);
+}
+\f
/* Return a TREE_LIST describing the substitutions needed to reflect
discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
@@ -4543,7 +4572,7 @@ make_aligning_type (tree type, int align
bitsize_int (align));
TYPE_SIZE_UNIT (record_type)
= size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
- TYPE_ALIAS_SET (record_type) = get_alias_set (type);
+ copy_alias_set (record_type, type);
return record_type;
}
\f
@@ -4610,7 +4639,7 @@ make_packable_type (tree type)
}
finish_record_type (new_type, nreverse (field_list), 1, 1);
- TYPE_ALIAS_SET (new_type) = get_alias_set (type);
+ copy_alias_set (new_type, type);
return TYPE_MODE (new_type) == BLKmode ? type : new_type;
}
\f
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_aggr.adb
--- exp_aggr.adb 21 Jan 2004 10:35:14 -0000 1.14
+++ exp_aggr.adb 23 Jan 2004 10:12:23 -0000
@@ -1918,14 +1918,13 @@ package body Exp_Aggr is
Comp := First (Component_Associations (N));
while Present (Comp) loop
- Selector := Entity (First (Choices (Comp)));
+ Selector := Entity (First (Choices (Comp)));
-- Ada0Y (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
-- the activation chain and master entities (except in case of an
-- allocator because in that case these entities are generated
@@ -1949,6 +1948,7 @@ package body Exp_Aggr is
if not Inside_Init_Proc and not Inside_Allocator then
Build_Activation_Chain_Entity (N);
+
if not Has_Master_Entity (Current_Scope) then
Build_Master_Entity (Etype (N));
end if;
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_ch9.adb
--- exp_ch9.adb 21 Jan 2004 10:35:15 -0000 1.13
+++ exp_ch9.adb 23 Jan 2004 10:12:24 -0000
@@ -1198,7 +1198,8 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (E);
P : Node_Id;
Decl : Node_Id;
- S : Entity_Id := Scope (E);
+ S : Entity_Id;
+
begin
-- Ada0Y (AI-287): Do not set/get the has_master_entity reminder in
-- internal scopes. Required for nested limited aggregates.
@@ -1213,12 +1214,13 @@ package body Exp_Ch9 is
then
return;
end if;
- else
- -- Ada0Y (AI-287): Similar to the Ãprevious casebut skipping internal
- -- scopes. If we are not inside an internal scope this code is
- -- equivalent to the previous code.
+ 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.
+ S := Scope (E);
while Is_Internal (S) loop
S := Scope (S);
end loop;
@@ -1228,7 +1230,6 @@ package body Exp_Ch9 is
then
return;
end if;
-
end if;
-- Otherwise first build the master entity
Index: exp_pakd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_pakd.adb,v
retrieving revision 1.9
diff -u -p -r1.9 exp_pakd.adb
--- exp_pakd.adb 21 Jan 2004 10:35:15 -0000 1.9
+++ exp_pakd.adb 23 Jan 2004 10:12:25 -0000
@@ -791,6 +791,12 @@ package body Exp_Pakd is
Set_Has_Delayed_Freeze (PAT, False);
Set_Has_Delayed_Freeze (Etype (PAT), False);
+
+ -- If we did allocate a freeze node, then clear out the reference
+ -- since it is obsolete (should we delete the freeze node???)
+
+ Set_Freeze_Node (PAT, Empty);
+ Set_Freeze_Node (Etype (PAT), Empty);
end Install_PAT;
-----------------
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.29
diff -u -p -r1.29 make.adb
--- make.adb 13 Jan 2004 11:51:33 -0000 1.29
+++ make.adb 23 Jan 2004 10:12:26 -0000
@@ -862,7 +862,7 @@ package body Make is
begin
Add_Lib_Search_Dir (N);
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding object directory """);
Write_Str (N);
Write_Str (""".");
@@ -878,7 +878,7 @@ package body Make is
begin
Add_Src_Search_Dir (N);
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding source directory """);
Write_Str (N);
Write_Str (""".");
@@ -1037,7 +1037,7 @@ package body Make is
-- modified.
begin
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str (" Adding ");
Write_Line (Argv);
end if;
@@ -1059,7 +1059,7 @@ package body Make is
-- We need a copy, because Name_Buffer may be modified
begin
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str (" Adding ");
Write_Line (Argv);
end if;
@@ -1317,11 +1317,11 @@ package body Make is
if Read_Only then
declare
Saved_Check_Object_Consistency : constant Boolean :=
- Opt.Check_Object_Consistency;
+ Check_Object_Consistency;
begin
- Opt.Check_Object_Consistency := False;
+ Check_Object_Consistency := False;
Text := Read_Library_Info (Lib_File);
- Opt.Check_Object_Consistency := Saved_Check_Object_Consistency;
+ Check_Object_Consistency := Saved_Check_Object_Consistency;
end;
else
@@ -1384,7 +1384,7 @@ package body Make is
-- Don't take Ali file into account if it was generated without
-- object.
- if Opt.Operating_Mode /= Opt.Check_Semantics
+ if Operating_Mode /= Check_Semantics
and then ALIs.Table (ALI).No_Object
then
Verbose_Msg (Full_Lib_File, "has no corresponding object");
@@ -1394,7 +1394,7 @@ package body Make is
-- Check for matching compiler switches if needed
- if Opt.Check_Switches then
+ if Check_Switches then
-- First, collect all the switches
@@ -1465,7 +1465,7 @@ package body Make is
end loop;
if not Switch_Found then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Verbose_Msg (ALIs.Table (ALI).Sfile,
"switch mismatch """ &
Switches_To_Check.Table (J).all & '"');
@@ -1480,7 +1480,7 @@ package body Make is
Integer (Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg -
Units.Table (ALIs.Table (ALI).First_Unit).First_Arg + 1)
then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Verbose_Msg (ALIs.Table (ALI).Sfile,
"different number of switches");
@@ -1516,7 +1516,7 @@ package body Make is
if Modified_Source /= No_File then
ALI := No_ALI_Id;
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Source_Name := Full_Source_Name (Modified_Source);
if Source_Name /= No_File then
@@ -1532,7 +1532,7 @@ package body Make is
if New_Spec /= No_File then
ALI := No_ALI_Id;
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Source_Name := Full_Source_Name (New_Spec);
if Source_Name /= No_File then
@@ -2545,14 +2545,14 @@ package body Make is
end if;
-- The following two flags affect the behavior of ALI.Set_Source_Table.
- -- We set Opt.Check_Source_Files to True to ensure that source file
- -- time stamps are checked, and we set Opt.All_Sources to False to
+ -- We set Check_Source_Files to True to ensure that source file
+ -- time stamps are checked, and we set All_Sources to False to
-- avoid checking the presence of the source files listed in the
-- source dependency section of an ali file (which would be a mistake
-- since the ali file may be obsolete).
- Opt.Check_Source_Files := True;
- Opt.All_Sources := False;
+ Check_Source_Files := True;
+ All_Sources := False;
Insert_Q (Main_Source);
Mark (Main_Source);
@@ -2764,22 +2764,22 @@ package body Make is
declare
Saved_Object_Consistency : constant Boolean :=
- Opt.Check_Object_Consistency;
+ Check_Object_Consistency;
begin
-- If compilation was not OK, or if output is not an
-- object file and we don't do the bind step, don't check
-- for object consistency.
- Opt.Check_Object_Consistency :=
- Opt.Check_Object_Consistency
+ Check_Object_Consistency :=
+ Check_Object_Consistency
and Compilation_OK
and (Output_Is_Object or Do_Bind_Step);
Text := Read_Library_Info (Lib_File);
-- Restore Check_Object_Consistency to its initial value
- Opt.Check_Object_Consistency := Saved_Object_Consistency;
+ Check_Object_Consistency := Saved_Object_Consistency;
end;
-- If an ALI file was generated by this compilation, scan
@@ -2808,7 +2808,7 @@ package body Make is
-- If we could not read the ALI file that was just generated
-- then there could be a problem reading either the ALI or the
- -- corresponding object file (if Opt.Check_Object_Consistency
+ -- corresponding object file (if Check_Object_Consistency
-- is set Read_Library_Info checks that the time stamp of the
-- object file is more recent than that of the ALI). For an
-- example of problems caught by this test see [6625-009].
@@ -2870,7 +2870,7 @@ package body Make is
-- If we have a special runtime, we add the standard
-- library only if we can find it.
- if Opt.RTS_Switch then
+ if RTS_Switch then
Add_It := Find_File (Sfile, Osint.Source) /= No_File;
end if;
@@ -2927,7 +2927,7 @@ package body Make is
end if;
end loop;
- if Opt.Display_Compilation_Progress then
+ if Display_Compilation_Progress then
Write_Str ("completed ");
Write_Int (Int (Q_Front));
Write_Str (" out of ");
@@ -3158,7 +3158,7 @@ package body Make is
if (not Debug.Debug_Flag_N) and Main_Project /= No_Project then
for Project in 1 .. Projects.Last loop
if Projects.Table (Project).Config_File_Temp then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Deleting temp configuration file """);
Write_Str (Get_Name_String
(Projects.Table (Project).Config_File_Name));
@@ -3405,7 +3405,7 @@ package body Make is
-- Do not check for an object file (".o") when compiling to
-- Java bytecode since ".class" files are generated instead.
- Opt.Check_Object_Consistency := False;
+ Check_Object_Consistency := False;
end if;
-- Special case when switch -B was specified
@@ -3734,7 +3734,7 @@ package body Make is
end if;
end if;
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Eol;
Write_Str ("GNATMAKE ");
Write_Str (Gnatvsn.Gnat_Version_String);
@@ -3778,8 +3778,8 @@ package body Make is
-- If -M was specified, behave as if -n was specified
- if Opt.List_Dependencies then
- Opt.Do_Not_Execute := True;
+ if List_Dependencies then
+ Do_Not_Execute := True;
end if;
-- Note that Osint.Next_Main_Source will always return the (possibly
@@ -3791,7 +3791,7 @@ package body Make is
Add_Switch ("-I-", Compiler, And_Save => True);
if Main_Project = No_Project then
- if Opt.Look_In_Primary_Dir then
+ if Look_In_Primary_Dir then
Add_Switch
("-I" &
@@ -3815,13 +3815,13 @@ package body Make is
-- sources for other compilation units, when there are extending
-- projects.
- Opt.Look_In_Primary_Dir := False;
+ Look_In_Primary_Dir := False;
end if;
-- If the user wants a program without a main subprogram, add the
-- appropriate switch to the binder.
- if Opt.No_Main_Subprogram then
+ if No_Main_Subprogram then
Add_Switch ("-z", Binder, And_Save => True);
end if;
@@ -3951,7 +3951,7 @@ package body Make is
-- We only output the main source file if there is only one
- if Opt.Verbose_Mode and then Osint.Number_Of_Files = 1 then
+ if Verbose_Mode and then Osint.Number_Of_Files = 1 then
Write_Str ("Main source file: """);
Write_Str (Main_Unit_File_Name
(Pos + 1 .. Main_Unit_File_Name'Last));
@@ -3971,7 +3971,7 @@ package body Make is
-- switches (if any).
if Osint.Number_Of_Files = 1 then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding gnatmake switches for """);
Write_Str (Main_Unit_File_Name);
Write_Line (""".");
@@ -4004,7 +4004,7 @@ package body Make is
begin
if Defaults /= Nil_Variable_Value then
- if (not Opt.Quiet_Output)
+ if (not Quiet_Output)
and then Switches /= No_Array_Element
then
Write_Line
@@ -4020,7 +4020,7 @@ package body Make is
The_Package => Builder_Package,
Program => None);
- elsif (not Opt.Quiet_Output)
+ elsif (not Quiet_Output)
and then Switches /= No_Array_Element
then
Write_Line
@@ -4046,7 +4046,7 @@ package body Make is
-- Add binder switches from the project file for the first main
if Do_Bind_Step and Binder_Package /= No_Package then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding binder switches for """);
Write_Str (Main_Unit_File_Name);
Write_Line (""".");
@@ -4061,7 +4061,7 @@ package body Make is
-- Add linker switches from the project file for the first main
if Do_Link_Step and Linker_Package /= No_Package then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding linker switches for""");
Write_Str (Main_Unit_File_Name);
Write_Line (""".");
@@ -4087,7 +4087,7 @@ package body Make is
Make_Failed ("*** make failed.");
end;
- Display_Commands (not Opt.Quiet_Output);
+ Display_Commands (not Quiet_Output);
Check_Steps;
@@ -4104,7 +4104,7 @@ package body Make is
not MLib.Tgt.Library_Exists_For (Proj);
if Projects.Table (Proj).Flag1 then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str
("Library file does not exist for project """);
Write_Str
@@ -4280,7 +4280,7 @@ package body Make is
-- precedence.
if Saved_Maximum_Processes = 0 then
- Saved_Maximum_Processes := Opt.Maximum_Processes;
+ Saved_Maximum_Processes := Maximum_Processes;
end if;
-- Allocate as many temporary mapping file names as the maximum
@@ -4470,15 +4470,15 @@ package body Make is
Most_Recent_Obj_Stamp => Youngest_Obj_Stamp,
Main_Unit => Is_Main_Unit,
Compilation_Failures => Compilation_Failures,
- Check_Readonly_Files => Opt.Check_Readonly_Files,
- Do_Not_Execute => Opt.Do_Not_Execute,
- Force_Compilations => Opt.Force_Compilations,
- In_Place_Mode => Opt.In_Place_Mode,
- Keep_Going => Opt.Keep_Going,
+ Check_Readonly_Files => Check_Readonly_Files,
+ Do_Not_Execute => Do_Not_Execute,
+ Force_Compilations => Force_Compilations,
+ In_Place_Mode => In_Place_Mode,
+ Keep_Going => Keep_Going,
Initialize_ALI_Data => True,
Max_Process => Saved_Maximum_Processes);
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("End of compilation");
Write_Eol;
end if;
@@ -4491,7 +4491,7 @@ package body Make is
Total_Compilation_Failures + Compilation_Failures;
if Total_Compilation_Failures /= 0 then
- if Opt.Keep_Going then
+ if Keep_Going then
goto Next_Main;
else
@@ -4563,7 +4563,7 @@ package body Make is
end loop;
end if;
- if Opt.List_Dependencies then
+ if List_Dependencies then
if First_Compiled_File /= No_File then
Inform
(First_Compiled_File,
@@ -4574,13 +4574,13 @@ package body Make is
elsif First_Compiled_File = No_File
and then not Do_Bind_Step
- and then not Opt.Quiet_Output
+ and then not Quiet_Output
and then not Library_Rebuilt
and then Osint.Number_Of_Files = 1
then
Inform (Msg => "objects up to date.");
- elsif Opt.Do_Not_Execute
+ elsif Do_Not_Execute
and then First_Compiled_File /= No_File
then
Write_Name (First_Compiled_File);
@@ -4598,8 +4598,8 @@ package body Make is
-- 4) Made unit cannot be a main unit
- if (Opt.Do_Not_Execute
- or Opt.List_Dependencies
+ if (Do_Not_Execute
+ or List_Dependencies
or not Do_Bind_Step
or not Is_Main_Unit)
and then not No_Main_Subprogram
@@ -4659,7 +4659,7 @@ package body Make is
-- and otherwise motivate the relink/rebind.
if not Executable_Obsolete then
- if not Opt.Quiet_Output then
+ if not Quiet_Output then
Inform (Executable, "up to date.");
end if;
@@ -4722,7 +4722,7 @@ package body Make is
-- library path. In this case, use the corresponding library file
-- name.
- if Main_ALI_File = No_File and then Opt.In_Place_Mode then
+ if Main_ALI_File = No_File and then In_Place_Mode then
Get_Name_String (Get_Directory (Full_Source_Name (Src_File)));
Get_Name_String_And_Append (ALI_File);
Main_ALI_File := Name_Find;
@@ -5300,7 +5300,7 @@ package body Make is
exception
when Link_Failed =>
- if Osint.Number_Of_Files = 1 or not Opt.Keep_Going then
+ if Osint.Number_Of_Files = 1 or not Keep_Going then
raise;
else
@@ -5402,7 +5402,7 @@ package body Make is
-- if any.
if Do_Bind_Step and Binder_Package /= No_Package then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding binder switches for """);
Write_Str (Main_Unit_File_Name);
Write_Line (""".");
@@ -5418,7 +5418,7 @@ package body Make is
-- if any.
if Do_Link_Step and Linker_Package /= No_Package then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding linker switches for""");
Write_Str (Main_Unit_File_Name);
Write_Line (""".");
@@ -5649,7 +5649,7 @@ package body Make is
-- GNATMAKE since we do not need to check source consistency
-- again once GNATMAKE has looked at the sources to check.
- Opt.Check_Object_Consistency := True;
+ Check_Object_Consistency := True;
-- Package initializations. The order of calls is important here.
@@ -5689,14 +5689,14 @@ package body Make is
-- Test for trailing -o switch
- elsif Opt.Output_File_Name_Present
+ elsif Output_File_Name_Present
and then not Output_File_Name_Seen
then
Make_Failed ("output file name missing after -o");
-- Test for trailing -D switch
- elsif Opt.Object_Directory_Present
+ elsif Object_Directory_Present
and then not Object_Directory_Seen then
Make_Failed ("object directory missing after -D");
end if;
@@ -5730,7 +5730,7 @@ package body Make is
-- A project file was specified by a -P switch
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Eol;
Write_Str ("Parsing Project File """);
Write_Str (Project_File_Name.all);
@@ -5740,7 +5740,7 @@ package body Make is
-- Avoid looking in the current directory for ALI files
- -- Opt.Look_In_Primary_Dir := False;
+ -- Look_In_Primary_Dir := False;
-- Set the project parsing verbosity to whatever was specified
-- by a possible -vP switch.
@@ -5759,7 +5759,7 @@ package body Make is
Make_Failed ("""", Project_File_Name.all, """ processing failed");
end if;
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Eol;
Write_Str ("Parsing of Project File """);
Write_Str (Project_File_Name.all);
@@ -5941,7 +5941,7 @@ package body Make is
-- is not marked.
if Sfile /= No_Name and then not Is_Marked (Sfile) then
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding """);
Write_Str (Get_Name_String (Sfile));
Write_Line (""" to the queue");
@@ -5959,7 +5959,7 @@ package body Make is
-- queue. This will allow parallel compilation processes if -jx
-- switch is used.
- if Opt.Verbose_Mode then
+ if Verbose_Mode then
Write_Str ("Adding """);
Write_Str (Get_Name_String (Sfile));
Write_Line (""" as if on the command line");
@@ -6229,7 +6229,7 @@ package body Make is
-- We have to provide the full library file name in In_Place_Mode
- if Opt.In_Place_Mode then
+ if In_Place_Mode then
Lib_Name := Full_Lib_File_Name (Lib_Name);
end if;
@@ -6249,7 +6249,7 @@ package body Make is
then
null;
else
- if not Opt.Quiet_Output then
+ if not Quiet_Output then
Src_Name := Full_Source_Name (Src_Name);
end if;
@@ -6479,7 +6479,7 @@ package body Make is
-- flag (that is we have seen a -o), then the next argument is
-- the name of the output executable.
- elsif Opt.Output_File_Name_Present
+ elsif Output_File_Name_Present
and then not Output_File_Name_Seen
then
Output_File_Name_Seen := True;
@@ -6511,7 +6511,7 @@ package body Make is
-- (that is we have seen a -D), then the next argument is
-- the path name of the object directory..
- elsif Opt.Object_Directory_Present
+ elsif Object_Directory_Present
and then not Object_Directory_Seen
then
Object_Directory_Seen := True;
@@ -6581,7 +6581,7 @@ package body Make is
if Argv'Length > 2 and then Argv (1 .. 2) = "-I" then
if Argv (3 .. Argv'Last) = "-" then
- Opt.Look_In_Primary_Dir := False;
+ Look_In_Primary_Dir := False;
elsif Program_Args = Compiler then
if Argv (3 .. Argv'Last) /= "-" then
@@ -6683,9 +6683,9 @@ package body Make is
-- Valid --RTS switch
- Opt.No_Stdinc := True;
- Opt.No_Stdlib := True;
- Opt.RTS_Switch := True;
+ No_Stdinc := True;
+ No_Stdlib := True;
+ RTS_Switch := True;
declare
Src_Path_Name : constant String_Ptr :=
@@ -6737,7 +6737,7 @@ package body Make is
-- -I-
elsif Argv (2 .. Argv'Last) = "I-" then
- Opt.Look_In_Primary_Dir := False;
+ Look_In_Primary_Dir := False;
-- Forbid -?- or -??- where ? is any character
@@ -6835,7 +6835,7 @@ package body Make is
elsif Argv (2) = 'd'
and then Argv'Last = 2
then
- Opt.Display_Compilation_Progress := True;
+ Display_Compilation_Progress := True;
-- -i
@@ -6862,7 +6862,7 @@ package body Make is
elsif Argv (2) = 'm'
and then Argv'Last = 2
then
- Opt.Minimal_Recompilation := True;
+ Minimal_Recompilation := True;
-- -u
@@ -6870,7 +6870,7 @@ package body Make is
and then Argv'Last = 2
then
Unique_Compile := True;
- Opt.Compile_Only := True;
+ Compile_Only := True;
Do_Bind_Step := False;
Do_Link_Step := False;
@@ -6881,7 +6881,7 @@ package body Make is
then
Unique_Compile_All_Projects := True;
Unique_Compile := True;
- Opt.Compile_Only := True;
+ Compile_Only := True;
Do_Bind_Step := False;
Do_Link_Step := False;
@@ -6962,9 +6962,9 @@ package body Make is
-- step are not executed.
Add_Switch (Argv, Compiler, And_Save => And_Save);
- Opt.Operating_Mode := Opt.Check_Semantics;
- Opt.Check_Object_Consistency := False;
- Opt.Compile_Only := True;
+ Operating_Mode := Check_Semantics;
+ Check_Object_Consistency := False;
+ Compile_Only := True;
Do_Bind_Step := False;
Do_Link_Step := False;
@@ -6973,7 +6973,7 @@ package body Make is
-- Don't pass -nostdlib to gnatlink, it will disable
-- linking with all standard library files.
- Opt.No_Stdlib := True;
+ No_Stdlib := True;
Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Binder, And_Save => And_Save);
@@ -6982,19 +6982,20 @@ package body Make is
-- Pass -nostdinc to the Compiler and to gnatbind
- Opt.No_Stdinc := True;
+ No_Stdinc := True;
Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Binder, And_Save => And_Save);
-- By default all switches with more than one character
-- or one character switches which are not in 'a' .. 'z'
- -- (except 'C', 'F', and 'M') are passed to the compiler,
+ -- (except 'C', 'F', 'M' and 'B') are passed to the compiler,
-- unless we are dealing with a debug switch (starts with 'd')
elsif Argv (2) /= 'd'
and then Argv (2 .. Argv'Last) /= "C"
and then Argv (2 .. Argv'Last) /= "F"
and then Argv (2 .. Argv'Last) /= "M"
+ and then Argv (2 .. Argv'Last) /= "B"
and then (Argv'Length > 2 or else Argv (2) not in 'a' .. 'z')
then
Add_Switch (Argv, Compiler, And_Save => And_Save);
@@ -7214,7 +7215,7 @@ package body Make is
Prefix : String := " -> ")
is
begin
- if not Opt.Verbose_Mode then
+ if not Verbose_Mode then
return;
end if;
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.66
diff -u -p -r1.66 Makefile.in
--- Makefile.in 21 Jan 2004 10:35:16 -0000 1.66
+++ Makefile.in 23 Jan 2004 10:12:26 -0000
@@ -1451,7 +1451,7 @@ RAVEN_OBJS = \
ADA_INCLUDE_SRCS =\
ada.ads calendar.ads directio.ads gnat.ads interfac.ads ioexcept.ads \
machcode.ads text_io.ads unchconv.ads unchdeal.ads \
- sequenio.ads system.ads Makefile.adalib Makefile.prolog Makefile.generic \
+ sequenio.ads system.ads Makefile.prolog Makefile.generic \
memtrack.adb \
a-*.adb a-*.ads g-*.ad? i-*.ad? \
s-[a-o]*.adb s-[p-z]*.adb \
@@ -1706,13 +1706,13 @@ install-gnatlib: ../stamp-gnatlib
# for shared libraries on some targets, e.g. on HP-UX where the x
# permission is required.
for file in gnat gnarl; do \
- if [ -f rts/lib$$file$(hyphen)$(LIBRARY_VERSION)$(soext) ]; then \
- $(INSTALL) rts/lib$$file$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ if [ -f rts/lib$${file}$(hyphen)$(LIBRARY_VERSION)$(soext) ]; then \
+ $(INSTALL) rts/lib$${file}$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(DESTDIR)$(ADA_RTL_OBJ_DIR); \
fi; \
- if [ -f rts/lib$$file$(soext) ]; then \
- $(LN_S) lib$$file$(hyphen)$(LIBRARY_VERSION)$(soext) \
- $(DESTDIR)$(ADA_RTL_OBJ_DIR)/lib$$file$(soext); \
+ if [ -f rts/lib$${file}$(soext) ]; then \
+ $(LN_S) lib$${file}$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(DESTDIR)$(ADA_RTL_OBJ_DIR)/lib$${file}$(soext); \
fi; \
done
# This copy must be done preserving the date on the original file.
Index: prj-part.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.adb,v
retrieving revision 1.10
diff -u -p -r1.10 prj-part.adb
--- prj-part.adb 8 Dec 2003 10:33:15 -0000 1.10
+++ prj-part.adb 23 Jan 2004 10:12:26 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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,7 +26,7 @@
with Err_Vars; use Err_Vars;
with Namet; use Namet;
-with Opt;
+with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Com; use Prj.Com;
@@ -167,6 +167,7 @@ package body Prj.Part is
procedure Parse_Single_Project
(Project : out Project_Node_Id;
+ Extends_All : out Boolean;
Path_Name : String;
Extended : Boolean;
From_Extended : Extension_Origin);
@@ -431,6 +432,7 @@ package body Prj.Part is
Store_Comments : Boolean := False)
is
Current_Directory : constant String := Get_Current_Dir;
+ Dummy : Boolean;
begin
-- Save the Packages_To_Check in Prj, so that it is visible from
@@ -467,6 +469,7 @@ package body Prj.Part is
Parse_Single_Project
(Project => Project,
+ Extends_All => Dummy,
Path_Name => Path_Name,
Extended => False,
From_Extended => None);
@@ -678,6 +681,7 @@ package body Prj.Part is
Current_With : With_Record;
Limited_With : Boolean := False;
+ Extends_All : Boolean := False;
begin
Imported_Projects := Empty_Node;
@@ -775,9 +779,13 @@ package body Prj.Part is
if Withed_Project = Empty_Node then
Parse_Single_Project
(Project => Withed_Project,
+ Extends_All => Extends_All,
Path_Name => Imported_Path_Name,
Extended => False,
From_Extended => From_Extended);
+
+ else
+ Extends_All := Is_Extending_All (Withed_Project);
end if;
if Withed_Project = Empty_Node then
@@ -805,6 +813,10 @@ package body Prj.Part is
Name_Len := Imported_Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Imported_Path_Name;
Set_Path_Name_Of (Current_Project, Name_Find);
+
+ if Extends_All then
+ Set_Is_Extending_All (Current_Project);
+ end if;
end if;
end if;
end;
@@ -817,6 +829,7 @@ package body Prj.Part is
procedure Parse_Single_Project
(Project : out Project_Node_Id;
+ Extends_All : out Boolean;
Path_Name : String;
Extended : Boolean;
From_Extended : Extension_Origin)
@@ -843,6 +856,8 @@ package body Prj.Part is
Project_Comment_State : Tree.Comment_State;
begin
+ Extends_All := False;
+
declare
Normed : String := Normalize_Pathname (Path_Name);
begin
@@ -908,6 +923,8 @@ package body Prj.Part is
end if;
elsif A_Project_Name_And_Node.Extended then
+ Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node);
+
-- If the imported project is an extended project A, and we are
-- in an extended project, replace A with the ultimate project
-- extending A.
@@ -1136,13 +1153,14 @@ package body Prj.Part is
-- Make sure that gnatmake will use mapping files
- Opt.Create_Mapping_File := True;
+ Create_Mapping_File := True;
-- We are extending another project
Scan; -- scan past EXTENDS
if Token = Tok_All then
+ Extends_All := True;
Set_Is_Extending_All (Project);
Scan; -- scan past ALL
end if;
@@ -1196,6 +1214,7 @@ package body Prj.Part is
Parse_Single_Project
(Project => Extended_Project,
+ Extends_All => Extends_All,
Path_Name => Extended_Project_Path_Name,
Extended => True,
From_Extended => From_Extended);
@@ -1226,14 +1245,15 @@ package body Prj.Part is
With_Clause_Loop :
while With_Clause /= Empty_Node loop
Imported := Project_Node_Of (With_Clause);
- With_Clause := Next_With_Clause_Of (With_Clause);
- if Is_Extending_All (Imported) then
+ if Is_Extending_All (With_Clause) then
Error_Msg_Name_1 := Name_Of (Imported);
Error_Msg ("cannot import extending-all project {",
Token_Ptr);
exit With_Clause_Loop;
end if;
+
+ With_Clause := Next_With_Clause_Of (With_Clause);
end loop With_Clause_Loop;
end;
end if;
Index: prj-proc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-proc.adb,v
retrieving revision 1.11
diff -u -p -r1.11 prj-proc.adb
--- prj-proc.adb 17 Nov 2003 14:58:16 -0000 1.11
+++ prj-proc.adb 23 Jan 2004 10:12:27 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -817,8 +817,9 @@ package body Prj.Proc is
From_Project_Node : Project_Node_Id;
Report_Error : Put_Line_Access)
is
- Obj_Dir : Name_Id;
- Extending : Project_Id;
+ Obj_Dir : Name_Id;
+ Extending : Project_Id;
+ Extending2 : Project_Id;
begin
Error_Report := Report_Error;
@@ -861,7 +862,7 @@ package body Prj.Proc is
end if;
-- Check that no extended project shares its object directory with
- -- another project.
+ -- another extended project or with its extending project(s).
if Project /= No_Project then
for Extended in 1 .. Projects.Last loop
@@ -870,45 +871,95 @@ package body Prj.Proc is
if Extending /= No_Project then
Obj_Dir := Projects.Table (Extended).Object_Directory;
- for Prj in 1 .. Projects.Last loop
- if Prj /= Extended
- and then Projects.Table (Prj).Sources_Present
- and then Projects.Table (Prj).Object_Directory = Obj_Dir
+ -- Check that a project being extended does not share its
+ -- object directory with any project that extends it, directly
+ -- or indirectly, including a virtual extending project.
+
+ -- Start with the project directly extending it
+
+ Extending2 := Extending;
+
+ while Extending2 /= No_Project loop
+ if Projects.Table (Extending2).Sources_Present
+ and then
+ Projects.Table (Extending2).Object_Directory = Obj_Dir
then
- if Projects.Table (Extending).Virtual then
+ if Projects.Table (Extending2).Virtual then
Error_Msg_Name_1 := Projects.Table (Extended).Name;
if Error_Report = null then
Error_Msg
- ("project % cannot be extended by " &
- "a virtual project",
- Projects.Table (Extending).Location);
+ ("project % cannot be extended by a virtual " &
+ "project with the same object directory",
+ Projects.Table (Extended).Location);
else
Error_Report
("project """ &
Get_Name_String (Error_Msg_Name_1) &
- """ cannot be extended by a virtual project",
+ """ cannot be extended by a virtual " &
+ "project with the same object directory",
Project);
end if;
else
- Error_Msg_Name_1 := Projects.Table (Extending).Name;
+ Error_Msg_Name_1 :=
+ Projects.Table (Extending2).Name;
Error_Msg_Name_2 := Projects.Table (Extended).Name;
if Error_Report = null then
- Error_Msg ("project % cannot extend project %",
- Projects.Table (Extending).Location);
+ Error_Msg
+ ("project % cannot extend project %",
+ Projects.Table (Extending2).Location);
+ Error_Msg
+ ("\they share the same object directory",
+ Projects.Table (Extending2).Location);
else
Error_Report
("project """ &
Get_Name_String (Error_Msg_Name_1) &
""" cannot extend project """ &
- Get_Name_String (Error_Msg_Name_2) & '"',
+ Get_Name_String (Error_Msg_Name_2) & """",
+ Project);
+ Error_Report
+ ("they share the same object directory",
Project);
end if;
end if;
+ end if;
+
+ -- Continue with the next extending project, if any
+
+ Extending2 := Projects.Table (Extending2).Extended_By;
+ end loop;
+
+ -- Check that two projects being extended do not share their
+ -- project directories.
+
+ for Prj in Extended + 1 .. Projects.Last loop
+ Extending2 := Projects.Table (Prj).Extended_By;
+
+ if Extending2 /= No_Project
+ and then Projects.Table (Prj).Sources_Present
+ and then Projects.Table (Prj).Object_Directory = Obj_Dir
+ and then not Projects.Table (Extending).Virtual
+ then
+ Error_Msg_Name_1 := Projects.Table (Extending).Name;
+ Error_Msg_Name_2 := Projects.Table (Extended).Name;
+
+ if Error_Report = null then
+ Error_Msg ("project % cannot extend project %",
+ Projects.Table (Extending).Location);
+
+ else
+ Error_Report
+ ("project """ &
+ Get_Name_String (Error_Msg_Name_1) &
+ """ cannot extend project """ &
+ Get_Name_String (Error_Msg_Name_2) & '"',
+ Project);
+ end if;
Error_Msg_Name_1 := Projects.Table (Extended).Name;
Error_Msg_Name_2 := Projects.Table (Prj).Name;
@@ -924,7 +975,21 @@ package body Prj.Proc is
("project """ &
Get_Name_String (Error_Msg_Name_1) &
""" has the same object directory as project """ &
- Get_Name_String (Error_Msg_Name_2) & '"',
+ Get_Name_String (Error_Msg_Name_2) & """,",
+ Project);
+ end if;
+
+ Error_Msg_Name_1 := Projects.Table (Extending2).Name;
+
+ if Error_Report = null then
+ Error_Msg
+ ("\which is extended by project %",
+ Projects.Table (Extending).Location);
+
+ else
+ Error_Report
+ ("which is extended by project """ &
+ Get_Name_String (Error_Msg_Name_1) & '"',
Project);
end if;
Index: prj-tree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.adb,v
retrieving revision 1.10
diff -u -p -r1.10 prj-tree.adb
--- prj-tree.adb 21 Jan 2004 10:35:16 -0000 1.10
+++ prj-tree.adb 23 Jan 2004 10:12:27 -0000
@@ -933,7 +933,9 @@ package body Prj.Tree is
pragma Assert
(Node /= Empty_Node
and then
- Project_Nodes.Table (Node).Kind = N_Project);
+ (Project_Nodes.Table (Node).Kind = N_Project
+ or else
+ Project_Nodes.Table (Node).Kind = N_With_Clause));
return Project_Nodes.Table (Node).Flag2;
end Is_Extending_All;
@@ -1947,7 +1949,9 @@ package body Prj.Tree is
pragma Assert
(Node /= Empty_Node
and then
- Project_Nodes.Table (Node).Kind = N_Project);
+ (Project_Nodes.Table (Node).Kind = N_Project
+ or else
+ Project_Nodes.Table (Node).Kind = N_With_Clause));
Project_Nodes.Table (Node).Flag2 := True;
end Set_Is_Extending_All;
Index: prj-tree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.ads,v
retrieving revision 1.11
diff -u -p -r1.11 prj-tree.ads
--- prj-tree.ads 8 Dec 2003 10:33:15 -0000 1.11
+++ prj-tree.ads 23 Jan 2004 10:12:27 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -245,7 +245,7 @@ package Prj.Tree is
function Is_Extending_All (Node : Project_Node_Id) return Boolean;
pragma Inline (Is_Extending_All);
- -- Only valid for N_Project
+ -- Only valid for N_Project and N_With_Clause
function First_Variable_Of
(Node : Project_Node_Id) return Variable_Node_Id;
@@ -798,7 +798,7 @@ package Prj.Tree is
-- N_Project - it indicates that there are comments in the project
-- source that cannot be kept in the tree.
-- N_Project_Declaration
- -- - it indixates that there are unkept comment in the
+ -- - it indicates that there are unkept comments in the
-- project.
Flag2 : Boolean := False;
@@ -807,6 +807,9 @@ package Prj.Tree is
-- project.
-- N_Comment - it indicates that the comment is followed by an
-- empty line.
+ -- N_With_Clause
+ -- - it indicates that the originally imported project
+ -- is an extending all project.
Comments : Project_Node_Id := Empty_Node;
-- For nodes other that N_Comment_Zones or N_Comment, designates the
Index: sem_ch13.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sem_ch13.adb
--- sem_ch13.adb 27 Nov 2003 11:40:45 -0000 1.12
+++ sem_ch13.adb 23 Jan 2004 10:12:28 -0000
@@ -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- --
@@ -265,8 +265,14 @@ package body Sem_Ch13 is
U_Ent := Ent;
elsif Ekind (Ent) = E_Incomplete_Type then
+
+ -- The attribute applies to the full view, set the entity
+ -- of the attribute definition accordingly.
+
Ent := Underlying_Type (Ent);
U_Ent := Ent;
+ Set_Entity (Nam, Ent);
+
else
U_Ent := Underlying_Type (Ent);
end if;
@@ -3035,8 +3041,7 @@ package body Sem_Ch13 is
function Minimum_Size
(T : Entity_Id;
- Biased : Boolean := False)
- return Nat
+ Biased : Boolean := False) return Nat
is
Lo : Uint := No_Uint;
Hi : Uint := No_Uint;
@@ -3253,7 +3258,7 @@ package body Sem_Ch13 is
-- Build_Spec --
----------------
- function Build_Spec return Node_Id is
+ function Build_Spec return Node_Id is
begin
Subp_Id := Make_Defining_Identifier (Loc, Sname);
@@ -3327,7 +3332,7 @@ package body Sem_Ch13 is
-- Build_Spec --
----------------
- function Build_Spec return Node_Id is
+ function Build_Spec return Node_Id is
begin
Subp_Id := Make_Defining_Identifier (Loc, Sname);
@@ -3394,9 +3399,8 @@ package body Sem_Ch13 is
------------------------
function Rep_Item_Too_Early
- (T : Entity_Id;
- N : Node_Id)
- return Boolean
+ (T : Entity_Id;
+ N : Node_Id) return Boolean
is
begin
-- Cannot apply rep items that are not operational items
@@ -3446,8 +3450,7 @@ package body Sem_Ch13 is
function Rep_Item_Too_Late
(T : Entity_Id;
N : Node_Id;
- FOnly : Boolean := False)
- return Boolean
+ FOnly : Boolean := False) return Boolean
is
S : Entity_Id;
Parent_Type : Entity_Id;
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-21 10:41 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-21 10:41 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-01-21 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb (Build_Record_Aggr_Code): Do not build the master
entity if already built in the current scope.
* exp_ch9.adb (Build_Master_Entity): Do not set the has_master_entity
reminder in internal scopes. Required for nested limited aggregates.
2004-01-21 Doug Rupp <rupp@gnat.com>
* Makefile.in (hyphen): New variable, default value '-'. Set to '_' on
VMS. Replace all occurences of libgnat- and libgnarl- with
libgnat$(hyphen) and libgnarl$(hyphen).
Fixed shared library build problem on VMS.
2004-01-21 Robert Dewar <dewar@gnat.com>
* mlib-prj.adb: Minor reformatting
2004-01-21 Thomas Quinot <quinot@act-europe.fr>
* prj-tree.adb, 7staprop.adb, vms_conv.adb, xr_tabls.adb: Add missing
'constant' keywords for declaration of pointers that are not modified.
* exp_pakd.adb: Fix English in comment.
2004-01-21 Ed Schonberg <schonberg@gnat.com>
PR ada/10889
* sem_ch3.adb (Analyze_Subtype_Declaration): For an array subtype,
copy all attributes of the parent, including the foreign language
convention.
2004-01-21 Sergey Rybin <rybin@act-europe.fr>
PR ada/10565
* sem_ch9.adb (Analyze_Delay_Alternative): Add expression type check
for 'delay until' statement.
--
Index: 7staprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7staprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 7staprop.adb
--- 7staprop.adb 5 Jan 2004 15:20:43 -0000 1.8
+++ 7staprop.adb 21 Jan 2004 09:36:47 -0000
@@ -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- --
@@ -218,7 +218,7 @@ package body System.Task_Primitives.Oper
procedure Abort_Handler (Sig : Signal) is
pragma Warnings (Off, Sig);
- T : Task_ID := Self;
+ T : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_aggr.adb
--- exp_aggr.adb 12 Jan 2004 11:45:23 -0000 1.13
+++ exp_aggr.adb 21 Jan 2004 09:36:47 -0000
@@ -1949,7 +1949,9 @@ package body Exp_Aggr is
if not Inside_Init_Proc and not Inside_Allocator then
Build_Activation_Chain_Entity (N);
- Build_Master_Entity (Etype (N));
+ if not Has_Master_Entity (Current_Scope) then
+ Build_Master_Entity (Etype (N));
+ end if;
end if;
end if;
end;
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_ch9.adb
--- exp_ch9.adb 13 Jan 2004 11:51:31 -0000 1.12
+++ exp_ch9.adb 21 Jan 2004 09:36:47 -0000
@@ -1198,15 +1198,37 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (E);
P : Node_Id;
Decl : Node_Id;
-
+ S : Entity_Id := Scope (E);
begin
- -- Nothing to do if we already built a master entity for this scope
- -- or if there is no task hierarchy.
+ -- 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;
+ else
+
+ -- Ada0Y (AI-287): Similar to the Ãprevious casebut skipping internal
+ -- scopes. If we are not inside an internal scope this code is
+ -- equivalent to the previous code.
+
+ while Is_Internal (S) loop
+ S := Scope (S);
+ end loop;
+
+ if Has_Master_Entity (S)
+ or else Restrictions (No_Task_Hierarchy)
+ then
+ return;
+ end if;
- if Has_Master_Entity (Scope (E))
- or else Restrictions (No_Task_Hierarchy)
- then
- return;
end if;
-- Otherwise first build the master entity
@@ -1226,7 +1248,15 @@ package body Exp_Ch9 is
P := Parent (E);
Insert_Before (P, Decl);
Analyze (Decl);
- Set_Has_Master_Entity (Scope (E));
+
+ -- Ada0Y (AI-287): Set the has_marter_entity reminder in the
+ -- non-internal scope selected above.
+
+ if not Extensions_Allowed then
+ Set_Has_Master_Entity (Scope (E));
+ else
+ Set_Has_Master_Entity (S);
+ end if;
-- Now mark the containing scope as a task master
Index: exp_pakd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_pakd.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_pakd.adb
--- exp_pakd.adb 12 Jan 2004 11:45:23 -0000 1.8
+++ exp_pakd.adb 21 Jan 2004 09:36:47 -0000
@@ -1061,11 +1061,11 @@ package body Exp_Pakd is
Set_Parent (Len_Expr, Typ);
Analyze_Per_Use_Expression (Len_Expr, Standard_Integer);
- -- Use a modular type if possible. We can do this if we are we
- -- have static bounds, and the length is small enough, and the
- -- length is not zero. We exclude the zero length case because the
- -- size of things is always at least one, and the zero length object
- -- would have an anomous size.
+ -- Use a modular type if possible. We can do this if we have
+ -- static bounds, and the length is small enough, and the length
+ -- is not zero. We exclude the zero length case because the size
+ -- of things is always at least one, and the zero length object
+ -- would have an anomalous size.
if Compile_Time_Known_Value (Len_Expr) then
Len_Bits := Expr_Value (Len_Expr) * Csize;
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.65
diff -u -p -r1.65 Makefile.in
--- Makefile.in 16 Jan 2004 08:51:38 -0000 1.65
+++ Makefile.in 21 Jan 2004 09:36:47 -0000
@@ -144,6 +144,7 @@ exeext =
arext = .a
soext = .so
shext =
+hyphen = -
# Define this as & to perform parallel make on a Sequent.
# Note that this has some bugs, and it seems currently necessary
@@ -1126,6 +1127,7 @@ endif
ifeq ($(strip $(filter-out alpha% ia64 dec vms% openvms% alphavms%,$(host))),)
soext = .exe
+hyphen = _
.SUFFIXES: .sym
@@ -1704,12 +1706,12 @@ install-gnatlib: ../stamp-gnatlib
# for shared libraries on some targets, e.g. on HP-UX where the x
# permission is required.
for file in gnat gnarl; do \
- if [ -f rts/lib$$file-$(LIBRARY_VERSION)$(soext) ]; then \
- $(INSTALL) rts/lib$$file-$(LIBRARY_VERSION)$(soext) \
+ if [ -f rts/lib$$file$(hyphen)$(LIBRARY_VERSION)$(soext) ]; then \
+ $(INSTALL) rts/lib$$file$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(DESTDIR)$(ADA_RTL_OBJ_DIR); \
fi; \
if [ -f rts/lib$$file$(soext) ]; then \
- $(LN_S) lib$$file-$(LIBRARY_VERSION)$(soext) \
+ $(LN_S) lib$$file$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(DESTDIR)$(ADA_RTL_OBJ_DIR)/lib$$file$(soext); \
fi; \
done
@@ -1892,15 +1894,19 @@ gnatlib-shared-default:
gnatlib
$(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
- -o libgnat-$(LIBRARY_VERSION)$(soext) \
+ -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \
- $(SO_OPTS)libgnat-$(LIBRARY_VERSION)$(soext) $(MISCLIB) -lm
+ $(SO_OPTS)libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(MISCLIB) -lm
cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
- -o libgnarl-$(LIBRARY_VERSION)$(soext) \
+ -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_TASKING_OBJS) \
- $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB)
- cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
- cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
+ $(SO_OPTS)libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(THREADSLIB)
+ cd rts; $(LN_S) libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ libgnat$(soext)
+ cd rts; $(LN_S) libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ libgnarl$(soext)
gnatlib-shared-dual:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1944,14 +1950,14 @@ gnatlib-shared-win32:
gnatlib
$(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
- -o libgnat-$(LIBRARY_VERSION)$(soext) \
+ -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \
- $(SO_OPTS)libgnat-$(LIBRARY_VERSION)$(soext) $(MISCLIB)
+ $(SO_OPTS)libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) $(MISCLIB)
cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
- -o libgnarl-$(LIBRARY_VERSION)$(soext) \
+ -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_TASKING_OBJS) \
- $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \
- $(THREADSLIB) -Wl,libgnat-$(LIBRARY_VERSION)$(soext)
+ $(SO_OPTS)libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(THREADSLIB) -Wl,libgnat$(hyphen)$(LIBRARY_VERSION)$(soext)
gnatlib-shared-vms:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1965,7 +1971,7 @@ gnatlib-shared-vms:
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
- -o libgnat_$(LIBRARY_VERSION)$(soext) libgnat.a \
+ -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) libgnat.a \
sys\$$library:trace.exe \
--for-linker=/noinform \
--for-linker=SYMVEC_$$$$.opt \
@@ -1975,8 +1981,8 @@ gnatlib-shared-vms:
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
- -o libgnarl_$(LIBRARY_VERSION)$(soext) \
- libgnarl.a libgnat_$(LIBRARY_VERSION)$(soext) \
+ -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ libgnarl.a libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
sys\$$library:trace.exe \
--for-linker=/noinform \
--for-linker=SYMVEC_$$$$.opt \
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.9
diff -u -p -r1.9 mlib-prj.adb
--- mlib-prj.adb 19 Jan 2004 10:37:59 -0000 1.9
+++ mlib-prj.adb 21 Jan 2004 09:36:48 -0000
@@ -389,8 +389,9 @@ package body MLib.Prj is
-----------------
procedure Add_ALI_For (Source : Name_Id) is
- ALI : constant String := ALI_File_Name (Get_Name_String (Source));
+ ALI : constant String := ALI_File_Name (Get_Name_String (Source));
ALI_Id : Name_Id;
+
begin
if Bind then
Add_Argument (ALI);
@@ -665,7 +666,7 @@ package body MLib.Prj is
Element : Project_Element;
begin
- -- Nothing to do if process has already been processed.
+ -- Nothing to do if process has already been processed
if not Processed_Projects.Get (Data.Name) then
Processed_Projects.Set (Data.Name, True);
@@ -879,6 +880,7 @@ package body MLib.Prj is
Library_ALIs.Reset;
Interface_ALIs.Reset;
Processed_ALIs.Reset;
+
for Source in 1 .. Com.Units.Last loop
Unit := Com.Units.Table (Source);
@@ -924,12 +926,12 @@ package body MLib.Prj is
exit when not Bind;
end if;
end loop;
-
end;
-- Continue setup and call gnatbind if Bind is True
if Bind then
+
-- Get an eventual --RTS from the ALI file
if First_ALI /= No_Name then
@@ -991,7 +993,6 @@ package body MLib.Prj is
Com.Fail ("could not bind standalone library ",
Get_Name_String (Data.Library_Name));
end if;
-
end if;
-- Compile the binder generated file only if Link is true
@@ -1196,9 +1197,9 @@ package body MLib.Prj is
-- If in the object directory of an extended project,
-- do not consider generated object files.
- if In_Main_Object_Directory or else
- Last < 5 or else
- Filename (1 .. B_Start'Length) /= B_Start
+ if In_Main_Object_Directory
+ or else Last < 5
+ or else Filename (1 .. B_Start'Length) /= B_Start
then
Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Filename (1 .. Last);
@@ -1233,8 +1234,7 @@ package body MLib.Prj is
Check_Libs (ALI_File);
else
- -- The object file is a foreign object
- -- file.
+ -- Object file is a foreign object file
Foreigns.Increment_Last;
Foreigns.Table (Foreigns.Last) :=
@@ -1338,7 +1338,6 @@ package body MLib.Prj is
if Object_Files'Length = 0 then
Com.Fail ("no object files for library """ &
Lib_Filename.all & '"');
-
end if;
if not Opt.Quiet_Output then
@@ -1470,8 +1469,7 @@ package body MLib.Prj is
Copy_Dir := Projects.Table (For_Project).Library_Dir;
Clean (Copy_Dir);
- -- Call the procedure to build the library, depending on the build
- -- mode.
+ -- Call procedure to build the library, depending on the build mode
case The_Build_Mode is
when Dynamic | Relocatable =>
@@ -1501,11 +1499,11 @@ package body MLib.Prj is
null;
end case;
- -- We need to copy the ALI files from the object directory
- -- to the library directory, so that the linker find them there,
- -- and does not need to look in the object directory where it would
- -- also find the object files; and we don't want that: we want the
- -- linker to use the library.
+ -- We need to copy the ALI files from the object directory to
+ -- the library directory, so that the linker find them there,
+ -- and does not need to look in the object directory where it
+ -- would also find the object files; and we don't want that:
+ -- we want the linker to use the library.
-- Copy the ALI files and make the copies read-only. For interfaces,
-- mark the copies as interfaces.
@@ -1521,8 +1519,8 @@ package body MLib.Prj is
and then Projects.Table (For_Project).Library_Src_Dir /= No_Name
then
-- Clean the interface copy directory, if it is not also the
- -- library directory. If it is also the library directory, it has
- -- already been cleaned before the generation of the library.
+ -- library directory. If it is also the library directory, it
+ -- has already been cleaned before generation of the library.
if Projects.Table (For_Project).Library_Src_Dir /= Copy_Dir then
Copy_Dir := Projects.Table (For_Project).Library_Src_Dir;
@@ -1558,7 +1556,7 @@ package body MLib.Prj is
procedure Check_Context is
begin
- -- check that each object file exists
+ -- Check that each object file exists
for F in Object_Files'Range loop
Check (Object_Files (F).all);
@@ -1609,7 +1607,6 @@ package body MLib.Prj is
if Is_Obj (Name_Buffer (1 .. Name_Len))
and then Name_Buffer (1 .. B_Start'Length) /= B_Start
then
-
-- Get the object file time stamp
Obj_TS := File_Stamp (Name_Find);
Index: prj-tree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.adb,v
retrieving revision 1.9
diff -u -p -r1.9 prj-tree.adb
--- prj-tree.adb 8 Dec 2003 10:33:15 -0000 1.9
+++ prj-tree.adb 21 Jan 2004 09:36:48 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -1242,8 +1242,7 @@ package body Prj.Tree is
function Project_File_Includes_Unkept_Comments
(Node : Project_Node_Id) return Boolean
is
- Declaration : constant Project_Node_Id :=
- Project_Declaration_Of (Node);
+ Declaration : constant Project_Node_Id := Project_Declaration_Of (Node);
begin
return Project_Nodes.Table (Declaration).Flag1;
end Project_File_Includes_Unkept_Comments;
@@ -1329,7 +1328,8 @@ package body Prj.Tree is
----------
procedure Save (S : out Comment_State) is
- Cmts : Comments_Ptr := new Comment_Array (1 .. Comments.Last);
+ Cmts : constant Comments_Ptr := new Comment_Array (1 .. Comments.Last);
+
begin
for J in 1 .. Comments.Last loop
Cmts (J) := Comments.Table (J);
@@ -1393,7 +1393,7 @@ package body Prj.Tree is
elsif End_Of_Line_Node /= Empty_Node then
declare
Zones : constant Project_Node_Id :=
- Comment_Zones_Of (End_Of_Line_Node);
+ Comment_Zones_Of (End_Of_Line_Node);
begin
Project_Nodes.Table (Zones).Value := Comment_Id;
end;
@@ -1722,8 +1722,7 @@ package body Prj.Tree is
(Node : Project_Node_Id;
To : Project_Node_Id)
is
- Zone : constant Project_Node_Id :=
- Comment_Zones_Of (Node);
+ Zone : constant Project_Node_Id := Comment_Zones_Of (Node);
begin
Project_Nodes.Table (Zone).Field2 := To;
end Set_First_Comment_After;
@@ -1736,8 +1735,7 @@ package body Prj.Tree is
(Node : Project_Node_Id;
To : Project_Node_Id)
is
- Zone : constant Project_Node_Id :=
- Comment_Zones_Of (Node);
+ Zone : constant Project_Node_Id := Comment_Zones_Of (Node);
begin
Project_Nodes.Table (Zone).Comments := To;
end Set_First_Comment_After_End;
@@ -1751,8 +1749,7 @@ package body Prj.Tree is
To : Project_Node_Id)
is
- Zone : constant Project_Node_Id :=
- Comment_Zones_Of (Node);
+ Zone : constant Project_Node_Id := Comment_Zones_Of (Node);
begin
Project_Nodes.Table (Zone).Field1 := To;
end Set_First_Comment_Before;
@@ -1765,8 +1762,7 @@ package body Prj.Tree is
(Node : Project_Node_Id;
To : Project_Node_Id)
is
- Zone : constant Project_Node_Id :=
- Comment_Zones_Of (Node);
+ Zone : constant Project_Node_Id := Comment_Zones_Of (Node);
begin
Project_Nodes.Table (Zone).Field2 := To;
end Set_First_Comment_Before_End;
@@ -2275,8 +2271,7 @@ package body Prj.Tree is
(Node : Project_Node_Id;
To : Boolean)
is
- Declaration : constant Project_Node_Id :=
- Project_Declaration_Of (Node);
+ Declaration : constant Project_Node_Id := Project_Declaration_Of (Node);
begin
Project_Nodes.Table (Declaration).Flag1 := To;
end Set_Project_File_Includes_Unkept_Comments;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.28
diff -u -p -r1.28 sem_ch3.adb
--- sem_ch3.adb 12 Jan 2004 11:45:24 -0000 1.28
+++ sem_ch3.adb 21 Jan 2004 09:36:48 -0000
@@ -2115,13 +2115,8 @@ package body Sem_Ch3 is
case Ekind (T) is
when Array_Kind =>
- Set_Ekind (Id, E_Array_Subtype);
-
- -- Shouldn't we call Copy_Array_Subtype_Attributes here???
-
- Set_First_Index (Id, First_Index (T));
- Set_Is_Aliased (Id, Is_Aliased (T));
- Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Ekind (Id, E_Array_Subtype);
+ Copy_Array_Subtype_Attributes (Id, T);
when Decimal_Fixed_Point_Kind =>
Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
Index: sem_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch9.adb,v
retrieving revision 1.7
diff -u -p -r1.7 sem_ch9.adb
--- sem_ch9.adb 14 Nov 2003 10:24:43 -0000 1.7
+++ sem_ch9.adb 21 Jan 2004 09:36:48 -0000
@@ -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- --
@@ -481,6 +481,13 @@ package body Sem_Ch9 is
else
Pre_Analyze_And_Resolve (Expr);
+ end if;
+
+ if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
+ not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then
+ not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
+ then
+ Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
end if;
Check_Restriction (No_Fixed_Point, Expr);
Index: xr_tabls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/xr_tabls.adb,v
retrieving revision 1.8
diff -u -p -r1.8 xr_tabls.adb
--- xr_tabls.adb 5 Jan 2004 15:20:47 -0000 1.8
+++ xr_tabls.adb 21 Jan 2004 09:36:48 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -1413,7 +1413,7 @@ package body Xr_Tabls is
(Sorted : Boolean := True)
return Declaration_Array_Access
is
- Arr : Declaration_Array_Access :=
+ Arr : constant Declaration_Array_Access :=
new Declaration_Array (1 .. Entities_Count);
Decl : Declaration_Reference := Entities_HTable.Get_First;
Index : Natural := Arr'First;
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.3
diff -u -p -r1.3 vms_conv.adb
--- vms_conv.adb 5 Jan 2004 15:20:47 -0000 1.3
+++ vms_conv.adb 21 Jan 2004 09:36:48 -0000
@@ -793,7 +793,7 @@ package body VMS_Conv is
for C in Real_Command_Type loop
declare
- Command : Item_Ptr := new Command_Item;
+ Command : constant Item_Ptr := new Command_Item;
Last_Switch : Item_Ptr;
-- Last switch in list
@@ -975,8 +975,9 @@ package body VMS_Conv is
P := P + 1; -- bump past =
while P <= SS'Last loop
declare
- Opt : Item_Ptr := new Option_Item;
+ Opt : constant Item_Ptr := new Option_Item;
Q : Natural;
+
begin
-- Link new option item into options list
@@ -1088,7 +1089,6 @@ package body VMS_Conv is
-- The first one must be a command name
if Arg_Num = 1 and then Arg_Idx = Argv'First then
-
Command := Matching_Name (Arg.all, Commands);
if Command = null then
@@ -1159,8 +1159,7 @@ package body VMS_Conv is
if Sw.Translation = T_File
and then Sw.Unix_String
- (Sw.Unix_String'Last)
- /= '='
+ (Sw.Unix_String'Last) /= '='
then
Put (' ');
end if;
@@ -1171,8 +1170,8 @@ package body VMS_Conv is
Put ("=nnn");
Set_Col (53);
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
+ if Sw.Unix_String
+ (Sw.Unix_String'First) = '`'
then
Put (Sw.Unix_String
(Sw.Unix_String'First + 1
@@ -1187,8 +1186,8 @@ package body VMS_Conv is
Put ("=xyz");
Set_Col (53);
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
+ if Sw.Unix_String
+ (Sw.Unix_String'First) = '`'
then
Put (Sw.Unix_String
(Sw.Unix_String'First + 1
@@ -1208,8 +1207,8 @@ package body VMS_Conv is
Put (Sw.Unix_String.all);
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
then
Put (' ');
end if;
@@ -1297,8 +1296,8 @@ package body VMS_Conv is
when File | Optional_File =>
declare
Normal_File : constant String_Access :=
- To_Canonical_File_Spec
- (Arg.all);
+ To_Canonical_File_Spec
+ (Arg.all);
begin
Place (' ');
@@ -1314,12 +1313,12 @@ package body VMS_Conv is
when Unlimited_Files =>
declare
- Normal_File :
- constant String_Access :=
- To_Canonical_File_Spec (Arg.all);
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
begin
for J in Arg'Range loop
@@ -1599,8 +1598,8 @@ package body VMS_Conv is
(Arg_Num + 1));
Arg_Num := Arg_Num + 1;
Arg_Idx := Argv'First;
- Next_Arg_Idx
- := Get_Arg_End (Argv.all, Arg_Idx);
+ Next_Arg_Idx :=
+ Get_Arg_End (Argv.all, Arg_Idx);
Arg := new String'
(Argv (Arg_Idx .. Next_Arg_Idx));
goto Tryagain_After_Coalesce;
@@ -1621,14 +1620,15 @@ package body VMS_Conv is
declare
Dir_Is_Wild : Boolean := False;
Dir_Maybe_Is_Wild : Boolean := False;
+
Dir_List : String_Access_List_Access;
+
begin
P2 := SwP;
while P2 < Endp
and then Arg (P2 + 1) /= ','
loop
-
-- A wildcard directory spec on
-- VMS will contain either * or
-- % or ...
@@ -1660,8 +1660,9 @@ package body VMS_Conv is
end loop;
if Dir_Is_Wild then
- Dir_List := To_Canonical_File_List
- (Arg (SwP .. P2), True);
+ Dir_List :=
+ To_Canonical_File_List
+ (Arg (SwP .. P2), True);
for J in Dir_List.all'Range loop
Place_Unix_Switches
@@ -1696,7 +1697,7 @@ package body VMS_Conv is
-- here
if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
+ (Sw.Unix_String'Last) /= '='
then
Place (' ');
end if;
@@ -1722,7 +1723,7 @@ package body VMS_Conv is
if Sw.Translation = T_File
and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
+ (Sw.Unix_String'Last) /= '='
then
Place (' ');
end if;
@@ -1733,9 +1734,7 @@ package body VMS_Conv is
end if;
when T_Numeric =>
- if
- OK_Integer (Arg (SwP + 2 .. Arg'Last))
- then
+ if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
Place_Unix_Switches (Sw.Unix_String);
Place (Arg (SwP + 2 .. Arg'Last));
@@ -1748,9 +1747,8 @@ package body VMS_Conv is
end if;
when T_Alphanumplus =>
- if
- OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
+ if OK_Alphanumerplus
+ (Arg (SwP + 2 .. Arg'Last))
then
Place_Unix_Switches (Sw.Unix_String);
Place (Arg (SwP + 2 .. Arg'Last));
@@ -1768,7 +1766,7 @@ package body VMS_Conv is
-- A String value must be extended to the
-- end of the Argv, otherwise strings like
-- "foo/bar" get split at the slash.
- --
+
-- The begining and ending of the string
-- are flagged with embedded nulls which
-- are removed when building the Spawn
@@ -1778,6 +1776,7 @@ package body VMS_Conv is
-- difficult to embed them.
Place_Unix_Switches (Sw.Unix_String);
+
if Next_Arg_Idx /= Argv'Last then
Next_Arg_Idx := Argv'Last;
Arg := new String'
@@ -1789,6 +1788,7 @@ package body VMS_Conv is
SwP := SwP + 1;
end loop;
end if;
+
Place (ASCII.NUL);
Place (Arg (SwP + 2 .. Arg'Last));
Place (ASCII.NUL);
@@ -1803,9 +1803,8 @@ package body VMS_Conv is
Sw.Unix_String'First + 5));
if Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last) =
- "MAKE"
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last) = "MAKE"
then
Make_Commands_Active := null;
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-01-19 10:43 Arnaud Charlet
2004-01-19 10:49 ` Gerald Pfeifer
@ 2004-01-19 12:59 ` Andreas Schwab
1 sibling, 0 replies; 178+ messages in thread
From: Andreas Schwab @ 2004-01-19 12:59 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
> It would be good if people could use a script to check that they're
> not forgetting to update the copyright notice, or we could even modify
> the cvs server set up to force this check (that's what we do at AdaCore
> since it's too easy to forget these), just a thought.
Emacs has a nice function copyright-update which can be put on
write-file-functions (or on before-save-hook if you use CVS Emacs).
Andreas.
--
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux AG, Maxfeldstraße 5, 90409 Nürnberg, Germany
Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-01-19 10:43 Arnaud Charlet
@ 2004-01-19 10:49 ` Gerald Pfeifer
2004-01-19 12:59 ` Andreas Schwab
1 sibling, 0 replies; 178+ messages in thread
From: Gerald Pfeifer @ 2004-01-19 10:49 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
On Mon, 19 Jan 2004, Arnaud Charlet wrote:
> It would be good if people could use a script to check that they're
> not forgetting to update the copyright notice, or we could even modify
> the cvs server set up to force this check (that's what we do at AdaCore
> since it's too easy to forget these), just a thought.
> [...]
> --- Copyright (C) 1992-2003 Free Software Foundation, Inc.
> +-- Copyright (C) 1992-2004 Free Software Foundation, Inc.
Has the FSF changed it's requirement that individual years be listed in
the copyright statement?
I just checked, and http://www.gnu.org/prep/maintain_8.html#SEC8 still
has the following:
Do not abbreviate the year list using a range; for instance, do not
write `1996--1998'; instead, write `1996, 1997, 1998'.
Gerald
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-19 10:43 Arnaud Charlet
2004-01-19 10:49 ` Gerald Pfeifer
2004-01-19 12:59 ` Andreas Schwab
0 siblings, 2 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-19 10:43 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
It would be good if people could use a script to check that they're
not forgetting to update the copyright notice, or we could even modify
the cvs server set up to force this check (that's what we do at AdaCore
since it's too easy to forget these), just a thought.
--
2004-01-19 Arnaud Charlet <charlet@act-europe.fr>
* utils.c: Update copyright notice, missed in previous change.
2004-01-19 Vincent Celier <celier@gnat.com>
* mlib-prj.adb (Build_Library.Add_ALI_For): Only add the ALI to the
args if Bind is True. Set First_ALI, if not already done.
(Build_Library): For Stand Alone Libraries, extract from one ALI file
an eventual --RTS switch, for gnatbind, and all backend switches +
--RTS, for linking.
2004-01-19 Robert Dewar <dewar@gnat.com>
* sem_attr.adb, memtrack.adb: Minor reformatting
2004-01-19 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Expand_Call): Remove code to fold calls to functions
that rename enumeration literals. This is properly done in sem_eval.
* sem_eval.ads, sem_eval.adb (Eval_Call): New procedure to fold calls
to functions that rename enumeration literals.
* sem_res.adb (Resolve_Call): Use Eval_Call to fold static calls to
functions that rename enumeration literals.
--
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.17
diff -u -p -r1.17 exp_ch6.adb
--- exp_ch6.adb 5 Jan 2004 15:20:43 -0000 1.17
+++ exp_ch6.adb 19 Jan 2004 10:13:01 -0000
@@ -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- --
@@ -1828,32 +1828,10 @@ package body Exp_Ch6 is
Check_Restriction (No_Abort_Statements, N);
end if;
- -- Some more special cases for cases other than explicit dereference
-
- if Nkind (Name (N)) /= N_Explicit_Dereference then
-
- -- Calls to an enumeration literal are replaced by the literal
- -- This case occurs only when we have a call to a function that
- -- is a renaming of an enumeration literal. The normal case of
- -- a direct reference to an enumeration literal has already been
- -- been dealt with by Resolve_Call. If the function is itself
- -- inherited (see 7423-001) the literal of the parent type must
- -- be explicitly converted to the return type of the function.
-
- if Ekind (Subp) = E_Enumeration_Literal then
- if Base_Type (Etype (Subp)) /= Base_Type (Etype (N)) then
- Rewrite
- (N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc)));
- else
- Rewrite (N, New_Occurrence_Of (Subp, Loc));
- end if;
-
- Resolve (N);
- end if;
+ if Nkind (Name (N)) = N_Explicit_Dereference then
-- Handle case of access to protected subprogram type
- else
if Ekind (Base_Type (Etype (Prefix (Name (N))))) =
E_Access_Protected_Subprogram_Type
then
Index: memtrack.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/memtrack.adb,v
retrieving revision 1.7
diff -u -p -r1.7 memtrack.adb
--- memtrack.adb 15 Jan 2004 17:24:17 -0000 1.7
+++ memtrack.adb 19 Jan 2004 10:13:01 -0000
@@ -235,6 +235,7 @@ package body System.Memory is
procedure Free (Ptr : System.Address) is
Addr : aliased constant System.Address := Ptr;
+
begin
Lock_Task.all;
@@ -265,7 +266,6 @@ package body System.Memory is
c_free (Ptr);
First_Call := True;
-
end if;
Unlock_Task.all;
@@ -280,10 +280,12 @@ package body System.Memory is
if Needs_Init then
Needs_Init := False;
Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
+
if Gmemfile = System.Null_Address then
Put_Line ("Couldn't open gnatmem log file for writing");
OS_Exit (255);
end if;
+
fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
end if;
end Gmem_Initialize;
@@ -296,6 +298,7 @@ package body System.Memory is
(Ptr : System.Address; Size : size_t) return System.Address
is
Result : System.Address;
+
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.8
diff -u -p -r1.8 mlib-prj.adb
--- mlib-prj.adb 5 Jan 2004 15:20:45 -0000 1.8
+++ mlib-prj.adb 19 Jan 2004 10:13:01 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003, Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -39,6 +39,7 @@ with Prj.Env; use Prj.Env;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
+with Switch; use Switch;
with Table;
with Types; use Types;
@@ -353,6 +354,9 @@ package body MLib.Prj is
Copy_Dir : Name_Id;
-- Directory where to copy ALI files and possibly interface sources
+ First_ALI : Name_Id := No_Name;
+ -- Store the ALI file name of a source of the library (the first found)
+
procedure Add_ALI_For (Source : Name_Id);
-- Add the name of the ALI file corresponding to Source to the
-- Arguments.
@@ -386,14 +390,27 @@ package body MLib.Prj is
procedure Add_ALI_For (Source : Name_Id) is
ALI : constant String := ALI_File_Name (Get_Name_String (Source));
+ ALI_Id : Name_Id;
begin
- Add_Argument (ALI);
-
- -- Add the ALI file name to the library ALIs
+ if Bind then
+ Add_Argument (ALI);
+ end if;
Name_Len := 0;
Add_Str_To_Name_Buffer (S => ALI);
- Library_ALIs.Set (Name_Find, True);
+ ALI_Id := Name_Find;
+
+ -- Add the ALI file name to the library ALIs
+
+ if Bind then
+ Library_ALIs.Set (ALI_Id, True);
+ end if;
+
+ -- Set First_ALI, if not already done
+
+ if First_ALI = No_Name then
+ First_ALI := ALI_Id;
+ end if;
end Add_ALI_For;
---------------
@@ -850,59 +867,111 @@ package body MLib.Prj is
end;
end if;
end;
+ end if;
- -- Get all the ALI files of the project file
+ -- Get all the ALI files of the project file. We do that even if
+ -- Bind is False, so that First_ALI is set.
- declare
- Unit : Unit_Data;
+ declare
+ Unit : Unit_Data;
- begin
- Library_ALIs.Reset;
- Interface_ALIs.Reset;
- Processed_ALIs.Reset;
- for Source in 1 .. Com.Units.Last loop
- Unit := Com.Units.Table (Source);
+ begin
+ Library_ALIs.Reset;
+ Interface_ALIs.Reset;
+ Processed_ALIs.Reset;
+ for Source in 1 .. Com.Units.Last loop
+ Unit := Com.Units.Table (Source);
- if Unit.File_Names (Body_Part).Name /= No_Name
- and then Unit.File_Names (Body_Part).Path /= Slash
+ if Unit.File_Names (Body_Part).Name /= No_Name
+ and then Unit.File_Names (Body_Part).Path /= Slash
+ then
+ if
+ Check_Project (Unit.File_Names (Body_Part).Project)
then
- if
- Check_Project (Unit.File_Names (Body_Part).Project)
- then
- if Unit.File_Names (Specification).Name = No_Name then
- declare
- Src_Ind : Source_File_Index;
+ if Unit.File_Names (Specification).Name = No_Name then
+ declare
+ Src_Ind : Source_File_Index;
+
+ begin
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (Unit.File_Names
+ (Body_Part).Path));
+
+ -- Add the ALI file only if it is not a subunit
+
+ if
+ not Sinput.P.Source_File_Is_Subunit (Src_Ind)
+ then
+ Add_ALI_For
+ (Unit.File_Names (Body_Part).Name);
+ exit when not Bind;
+ end if;
+ end;
- begin
- Src_Ind := Sinput.P.Load_Project_File
- (Get_Name_String
- (Unit.File_Names
- (Body_Part).Path));
+ else
+ Add_ALI_For (Unit.File_Names (Body_Part).Name);
+ exit when not Bind;
+ end if;
+ end if;
- -- Add the ALI file only if it is not a subunit
+ elsif Unit.File_Names (Specification).Name /= No_Name
+ and then Unit.File_Names (Specification).Path /= Slash
+ and then Check_Project
+ (Unit.File_Names (Specification).Project)
+ then
+ Add_ALI_For (Unit.File_Names (Specification).Name);
+ exit when not Bind;
+ end if;
+ end loop;
- if
- not Sinput.P.Source_File_Is_Subunit (Src_Ind)
- then
- Add_ALI_For
- (Unit.File_Names (Body_Part).Name);
- end if;
- end;
+ end;
- else
- Add_ALI_For (Unit.File_Names (Body_Part).Name);
- end if;
- end if;
+ -- Continue setup and call gnatbind if Bind is True
- elsif Unit.File_Names (Specification).Name /= No_Name
- and then Unit.File_Names (Specification).Path /= Slash
- and then Check_Project
- (Unit.File_Names (Specification).Project)
- then
- Add_ALI_For (Unit.File_Names (Specification).Name);
+ if Bind then
+ -- Get an eventual --RTS from the ALI file
+
+ if First_ALI /= No_Name then
+ declare
+ use Types;
+ T : Text_Buffer_Ptr;
+ A : ALI_Id;
+
+ begin
+ -- Load the ALI file
+
+ T := Read_Library_Info (First_ALI, True);
+
+ -- Read it
+
+ A := Scan_ALI
+ (First_ALI, T, Ignore_ED => False, Err => False);
+
+ if A /= No_ALI_Id then
+ for Index in
+ ALI.Units.Table
+ (ALI.ALIs.Table (A).First_Unit).First_Arg ..
+ ALI.Units.Table
+ (ALI.ALIs.Table (A).First_Unit).Last_Arg
+ loop
+ -- Look for --RTS. If found, add the switch to call
+ -- gnatbind.
+
+ declare
+ Arg : String_Ptr renames Args.Table (Index);
+ begin
+ if
+ Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
+ then
+ Add_Argument (Arg.all);
+ exit;
+ end if;
+ end;
+ end loop;
end if;
- end loop;
- end;
+ end;
+ end if;
-- Set the paths
@@ -957,6 +1026,52 @@ package body MLib.Prj is
if PIC_Option /= "" then
Add_Argument (PIC_Option);
end if;
+
+ -- Get the back-end switches and --RTS from the ALI file
+
+ if First_ALI /= No_Name then
+ declare
+ use Types;
+ T : Text_Buffer_Ptr;
+ A : ALI_Id;
+
+ begin
+ -- Load the ALI file
+
+ T := Read_Library_Info (First_ALI, True);
+
+ -- Read it
+
+ A := Scan_ALI
+ (First_ALI, T, Ignore_ED => False, Err => False);
+
+ if A /= No_ALI_Id then
+ for Index in
+ ALI.Units.Table
+ (ALI.ALIs.Table (A).First_Unit).First_Arg ..
+ ALI.Units.Table
+ (ALI.ALIs.Table (A).First_Unit).Last_Arg
+ loop
+ -- Do not compile with the front end switches except
+ -- for --RTS.
+
+ declare
+ Arg : String_Ptr renames Args.Table (Index);
+ begin
+ if not Is_Front_End_Switch (Arg.all)
+ or else
+ Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
+ then
+ Add_Argument (Arg.all);
+ end if;
+ end;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Now that all the arguments are set, compile the binder
+ -- generated file.
Display (Gcc);
GNAT.OS_Lib.Spawn
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.18
diff -u -p -r1.18 sem_attr.adb
--- sem_attr.adb 15 Jan 2004 17:24:17 -0000 1.18
+++ sem_attr.adb 19 Jan 2004 10:13:02 -0000
@@ -4464,8 +4464,8 @@ package body Sem_Attr is
and then Raises_Constraint_Error (N)
then
Rewrite (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, C_Type);
return;
Index: sem_eval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_eval.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_eval.adb
--- sem_eval.adb 5 Jan 2004 15:20:46 -0000 1.11
+++ sem_eval.adb 19 Jan 2004 10:13:02 -0000
@@ -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- --
@@ -1179,6 +1179,49 @@ package body Sem_Eval is
begin
null;
end Eval_Character_Literal;
+
+ ---------------
+ -- Eval_Call --
+ ---------------
+
+ -- Static function calls are either calls to predefined operators
+ -- with static arguments, or calls to functions that rename a literal.
+ -- Only the latter case is handled here, predefined operators are
+ -- constant-folded elsewhere.
+ -- If the function is itself inherited (see 7423-001) the literal of
+ -- the parent type must be explicitly converted to the return type
+ -- of the function.
+
+ procedure Eval_Call (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Lit : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Function_Call
+ and then No (Parameter_Associations (N))
+ and then Is_Entity_Name (Name (N))
+ and then Present (Alias (Entity (Name (N))))
+ and then Is_Enumeration_Type (Base_Type (Typ))
+ then
+ Lit := Alias (Entity (Name (N)));
+
+ while Present (Alias (Lit)) loop
+ Lit := Alias (Lit);
+ end loop;
+
+ if Ekind (Lit) = E_Enumeration_Literal then
+ if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
+ Rewrite
+ (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
+ else
+ Rewrite (N, New_Occurrence_Of (Lit, Loc));
+ end if;
+
+ Resolve (N, Typ);
+ end if;
+ end if;
+ end Eval_Call;
------------------------
-- Eval_Concatenation --
Index: sem_eval.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_eval.ads,v
retrieving revision 1.5
diff -u -p -r1.5 sem_eval.ads
--- sem_eval.ads 21 Oct 2003 13:42:20 -0000 1.5
+++ sem_eval.ads 19 Jan 2004 10:13:02 -0000
@@ -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- --
@@ -268,6 +268,7 @@ package Sem_Eval is
procedure Eval_Actual (N : Node_Id);
procedure Eval_Allocator (N : Node_Id);
procedure Eval_Arithmetic_Op (N : Node_Id);
+ procedure Eval_Call (N : Node_Id);
procedure Eval_Character_Literal (N : Node_Id);
procedure Eval_Concatenation (N : Node_Id);
procedure Eval_Conditional_Expression (N : Node_Id);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.19
diff -u -p -r1.19 sem_res.adb
--- sem_res.adb 13 Jan 2004 11:51:33 -0000 1.19
+++ sem_res.adb 19 Jan 2004 10:13:03 -0000
@@ -3807,8 +3807,7 @@ package body Sem_Res is
Check_Intrinsic_Call (N);
end if;
- -- If we fall through we definitely have a non-static call
-
+ Eval_Call (N);
Check_Elab_Call (N);
end Resolve_Call;
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.40
diff -u -p -r1.40 utils.c
--- utils.c 16 Jan 2004 21:19:03 -0000 1.40
+++ utils.c 19 Jan 2004 10:13:03 -0000
@@ -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- *
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-01-16 8:53 ` Andreas Jaeger
@ 2004-01-16 9:38 ` Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-16 9:38 UTC (permalink / raw)
To: Andreas Jaeger; +Cc: Arnaud Charlet, gcc-patches
> Here you have DESTDIR
[...]
> But not here anymore.
Indeed, thanks.
Arno
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: Ada updates
2004-01-15 17:24 Arnaud Charlet
@ 2004-01-16 8:53 ` Andreas Jaeger
2004-01-16 9:38 ` Arnaud Charlet
0 siblings, 1 reply; 178+ messages in thread
From: Andreas Jaeger @ 2004-01-16 8:53 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3246 bytes --]
This is broken:
Arnaud Charlet <charlet@ACT-Europe.FR> writes:
> [...]
> Index: Makefile.in
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
> retrieving revision 1.63
> diff -u -p -r1.63 Makefile.in
> --- Makefile.in 12 Jan 2004 11:36:13 -0000 1.63
> +++ Makefile.in 15 Jan 2004 16:23:49 -0000
> @@ -1703,15 +1703,16 @@ install-gnatlib: ../stamp-gnatlib
> # of $(INSTALL_DATA). The latter may force a mode inappropriate
> # for shared libraries on some targets, e.g. on HP-UX where the x
> # permission is required.
> -ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
> - -for file in rts/lib*$(soext);do \
> - $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
Here you have DESTDIR
> + for file in gnat gnarl; do \
> + if [ -f rts/lib$$file-$(LIBRARY_VERSION)$(soext) ]; then \
> + $(INSTALL) rts/lib$$file-$(LIBRARY_VERSION)$(soext) \
> + $(ADA_RTL_OBJ_DIR); \
But not here anymore.
> + fi; \
> + if [ -f rts/lib$$file$(soext) ]; then \
> + $(LN_S) lib$$file-$(LIBRARY_VERSION)$(soext) \
> + $(ADA_RTL_OBJ_DIR)/lib$$file$(soext); \
And neither here.
> + fi; \
> done
> -else
> - -for file in rts/lib*-*$(soext);do \
> - $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
> - done
> -endif
> # This copy must be done preserving the date on the original file.
> for file in rts/*.adb rts/*.ads; do \
> $(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
> @@ -1898,6 +1899,8 @@ gnatlib-shared-default:
> -o libgnarl-$(LIBRARY_VERSION)$(soext) \
> $(GNATRTL_TASKING_OBJS) \
> $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB)
> + cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
> + cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
>
> gnatlib-shared-dual:
> $(MAKE) $(FLAGS_TO_PASS) \
>
I'm committing the appended patch as obvious,
Andreas
2004-01-16 Andreas Jaeger <aj@suse.de>
* Makefile.in: Add $(DESTDIR).
Index: gcc/ada/Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -p -r1.64 -r1.65
--- gcc/ada/Makefile.in 15 Jan 2004 17:24:16 -0000 1.64
+++ gcc/ada/Makefile.in 16 Jan 2004 08:51:38 -0000 1.65
@@ -1706,11 +1706,11 @@ install-gnatlib: ../stamp-gnatlib
for file in gnat gnarl; do \
if [ -f rts/lib$$file-$(LIBRARY_VERSION)$(soext) ]; then \
$(INSTALL) rts/lib$$file-$(LIBRARY_VERSION)$(soext) \
- $(ADA_RTL_OBJ_DIR); \
+ $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
fi; \
if [ -f rts/lib$$file$(soext) ]; then \
$(LN_S) lib$$file-$(LIBRARY_VERSION)$(soext) \
- $(ADA_RTL_OBJ_DIR)/lib$$file$(soext); \
+ $(DESTDIR)$(ADA_RTL_OBJ_DIR)/lib$$file$(soext); \
fi; \
done
# This copy must be done preserving the date on the original file.
--
Andreas Jaeger, aj@suse.de, http://www.suse.de/~aj
SuSE Linux AG, Maxfeldstr. 5, 90409 Nürnberg, Germany
GPG fingerprint = 93A3 365E CE47 B889 DF7F FED1 389A 563C C272 A126
[-- Attachment #2: Type: application/pgp-signature, Size: 188 bytes --]
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-15 17:24 Arnaud Charlet
2004-01-16 8:53 ` Andreas Jaeger
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-15 17:24 UTC (permalink / raw)
To: gcc-patches
Test on x86-linux
--
2004-01-15 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_entity, E_Variable): Retrieve the object size
also when not defining if a Size clause applies. That information is
not to be ignored.
2004-01-15 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.in (install-gnatlib, gnatlib-shared-default): Set up
symbolic links for the shared gnat run time when needed.
2004-01-15 Vasiliy Fofanov <fofanov@act-europe.fr>
* memtrack.adb (Gmem_Initialize): check that gmem.out could be opened
for writing, and terminate with an error message if not.
2004-01-15 Ed Schonberg <schonberg@gnat.com>
* sem_attr.adb (Resolve_Attribute, case 'Access): Remove spurious
warning on an access to subprogram in an instance, when the target
type is declared in the same generic unit.
(Eval_Attribute): If 'access is known to fail accessibility check,
rewrite as a raise statement.
2004-01-15 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.24
diff -u -p -r1.24 decl.c
--- decl.c 5 Jan 2004 15:20:43 -0000 1.24
+++ decl.c 15 Jan 2004 16:23:49 -0000
@@ -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- *
@@ -548,11 +548,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
}
/* If we are defining the object, see if it has a Size value and
- validate it if so. Then get the new type, if any. */
+ validate it if so. If we are not defining the object and a Size
+ clause applies, simply retrieve the value. We don't want to ignore
+ the clause and it is expected to have been validated already. Then
+ get the new type, if any. */
if (definition)
gnu_size = validate_size (Esize (gnat_entity), gnu_type,
gnat_entity, VAR_DECL, 0,
Has_Size_Clause (gnat_entity));
+ else if (Has_Size_Clause (gnat_entity))
+ gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
if (gnu_size != 0)
{
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.63
diff -u -p -r1.63 Makefile.in
--- Makefile.in 12 Jan 2004 11:36:13 -0000 1.63
+++ Makefile.in 15 Jan 2004 16:23:49 -0000
@@ -1703,15 +1703,16 @@ install-gnatlib: ../stamp-gnatlib
# of $(INSTALL_DATA). The latter may force a mode inappropriate
# for shared libraries on some targets, e.g. on HP-UX where the x
# permission is required.
-ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
- -for file in rts/lib*$(soext);do \
- $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
+ for file in gnat gnarl; do \
+ if [ -f rts/lib$$file-$(LIBRARY_VERSION)$(soext) ]; then \
+ $(INSTALL) rts/lib$$file-$(LIBRARY_VERSION)$(soext) \
+ $(ADA_RTL_OBJ_DIR); \
+ fi; \
+ if [ -f rts/lib$$file$(soext) ]; then \
+ $(LN_S) lib$$file-$(LIBRARY_VERSION)$(soext) \
+ $(ADA_RTL_OBJ_DIR)/lib$$file$(soext); \
+ fi; \
done
-else
- -for file in rts/lib*-*$(soext);do \
- $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
- done
-endif
# This copy must be done preserving the date on the original file.
for file in rts/*.adb rts/*.ads; do \
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
@@ -1898,6 +1899,8 @@ gnatlib-shared-default:
-o libgnarl-$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_TASKING_OBJS) \
$(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB)
+ cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
+ cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
gnatlib-shared-dual:
$(MAKE) $(FLAGS_TO_PASS) \
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.69
diff -u -p -r1.69 Make-lang.in
--- Make-lang.in 15 Jan 2004 04:02:23 -0000 1.69
+++ Make-lang.in 15 Jan 2004 16:23:49 -0000
@@ -2516,10 +2516,10 @@ ada/live.o : ada/ada.ads ada/a-except.ad
ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \
ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/memtrack.o : ada/ada.ads ada/a-except.ads ada/system.ads \
- ada/s-memory.ads ada/memtrack.adb ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traceb.ads \
- ada/s-traent.ads ada/s-traent.adb ada/unchconv.ads
+ada/memtrack.o : ada/ada.ads ada/a-except.ads ada/gnat.ads ada/g-io.ads \
+ ada/system.ads ada/s-memory.ads ada/memtrack.adb ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traceb.ads ada/s-traent.ads ada/s-traent.adb ada/unchconv.ads
ada/namet.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
Index: memtrack.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/memtrack.adb,v
retrieving revision 1.6
diff -u -p -r1.6 memtrack.adb
--- memtrack.adb 21 Oct 2003 13:42:09 -0000 1.6
+++ memtrack.adb 15 Jan 2004 16:23:49 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -71,6 +71,7 @@ with Ada.Exceptions;
with System.Soft_Links;
with System.Traceback;
with System.Traceback_Entries;
+with GNAT.IO;
package body System.Memory is
@@ -78,6 +79,7 @@ package body System.Memory is
use System.Soft_Links;
use System.Traceback;
use System.Traceback_Entries;
+ use GNAT.IO;
function c_malloc (Size : size_t) return System.Address;
pragma Import (C, c_malloc, "malloc");
@@ -89,11 +91,15 @@ package body System.Memory is
(Ptr : System.Address; Size : size_t) return System.Address;
pragma Import (C, c_realloc, "realloc");
- type File_Ptr is new System.Address;
+ subtype File_Ptr is System.Address;
function fopen (Path : String; Mode : String) return File_Ptr;
pragma Import (C, fopen);
+ procedure OS_Exit (Status : Integer);
+ pragma Import (C, OS_Exit, "__gnat_os_exit");
+ pragma No_Return (OS_Exit);
+
procedure fwrite
(Ptr : System.Address;
Size : size_t;
@@ -274,6 +280,10 @@ package body System.Memory is
if Needs_Init then
Needs_Init := False;
Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
+ if Gmemfile = System.Null_Address then
+ Put_Line ("Couldn't open gnatmem log file for writing");
+ OS_Exit (255);
+ end if;
fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
end if;
end Gmem_Initialize;
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_attr.adb
--- sem_attr.adb 5 Jan 2004 15:20:45 -0000 1.17
+++ sem_attr.adb 15 Jan 2004 16:23:49 -0000
@@ -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- --
@@ -4457,6 +4457,18 @@ package body Sem_Attr is
Compile_Time_Known_Attribute (N, Alignment (P_Entity));
return;
+ -- If this is an access attribute that is known to fail accessibility
+ -- check, rewrite accordingly.
+
+ elsif Attribute_Name (N) = Name_Access
+ and then Raises_Constraint_Error (N)
+ then
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, C_Type);
+ return;
+
-- No other cases are foldable (they certainly aren't static, and at
-- the moment we don't try to fold any cases other than these three).
@@ -6501,6 +6513,9 @@ package body Sem_Attr is
null; -- Nothing to check
-- Check the static accessibility rule of 3.10.2(32)
+ -- In an instance body, if subprogram and type are both
+ -- local, other rules prevent dangling references, and no
+ -- warning is needed.
elsif Attr_Id = Attribute_Access
and then Subprogram_Access_Level (Entity (P))
@@ -6510,7 +6525,8 @@ package body Sem_Attr is
Error_Msg_N
("subprogram must not be deeper than access type",
P);
- else
+
+ elsif Scope (Entity (P)) /= Scope (Btyp) then
Error_Msg_N
("subprogram must not be deeper than access type?",
P);
@@ -6521,7 +6537,7 @@ package body Sem_Attr is
-- Check the restriction of 3.10.2(32) that disallows
-- the type of the access attribute to be declared
- -- outside a generic body when the attribute occurs
+ -- outside a generic body when the subprogram is declared
-- within that generic body.
elsif Enclosing_Generic_Body (Entity (P))
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-13 11:52 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-13 11:52 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-01-13 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Build_Assignment): Fix bug in handling of controlled
components that are initialized with aggregates.
2004-01-13 Vincent Celier <celier@gnat.com>
* gnatlink.adb (Process_Binder_File): To find directory of shared
libgcc, if "gcc-lib" is not a subdirectory, look for the last
subdirectory "lib" in the path of the shared libgnat or libgnarl.
* make.adb (Gnatmake): If GCC version is at least 3, link with
-shared-libgcc, when there is at least one shared library project.
* opt.ads (GCC_Version): New integer constant.
* adaint.c (get_gcc_version): New function.
2004-01-13 Robert Dewar <dewar@gnat.com>
* sem_dist.adb, sem_res.adb, sem_util.adb,
sprint.adb, 3zsocthi.adb, einfo.adb, cstand.adb,
exp_ch4.adb, exp_ch9.adb, exp_dist.adb: Minor reformatting
2004-01-13 Thomas Quinot <quinot@act-europe.fr>
* s-interr.adb, s-stache.adb, s-taenca.adb, g-regpat.adb,
g-spitbo.adb, 5itaprop.adb: Add missing 'constant' keywords in object
declarations.
--
Index: 3zsocthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3zsocthi.adb,v
retrieving revision 1.3
diff -u -p -r1.3 3zsocthi.adb
--- 3zsocthi.adb 12 Jan 2004 11:45:23 -0000 1.3
+++ 3zsocthi.adb 13 Jan 2004 10:29:02 -0000
@@ -64,7 +64,7 @@ package body GNAT.Sockets.Thin is
Thread_Blocking_IO : Boolean := True;
Unknown_System_Error : constant C.Strings.chars_ptr :=
- C.Strings.New_String ("Unknown system error");
+ C.Strings.New_String ("Unknown system error");
-- The following types and variables are required to create a Hostent
-- record "by hand".
Index: 5itaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5itaprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5itaprop.adb
--- 5itaprop.adb 5 Jan 2004 15:20:42 -0000 1.8
+++ 5itaprop.adb 13 Jan 2004 10:29:02 -0000
@@ -201,7 +201,7 @@ package body System.Task_Primitives.Oper
procedure Abort_Handler (signo : Signal) is
pragma Unreferenced (signo);
- Self_Id : Task_ID := Self;
+ Self_Id : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.25
diff -u -p -r1.25 adaint.c
--- adaint.c 3 Dec 2003 11:47:52 -0000 1.25
+++ adaint.c 13 Jan 2004 10:29:03 -0000
@@ -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- *
@@ -2487,3 +2487,11 @@ __gnat_lseek (int fd, long offset, int w
{
return (int) lseek (fd, offset, whence);
}
+
+/* This function returns the version of GCC being used. Here it's GCC 3. */
+int
+get_gcc_version (void)
+{
+ return 3;
+}
+
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.15
diff -u -p -r1.15 cstand.adb
--- cstand.adb 12 Jan 2004 11:45:23 -0000 1.15
+++ cstand.adb 13 Jan 2004 10:29:03 -0000
@@ -559,6 +559,7 @@ package body CStand is
-- Create type definition node for type String
Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
+
declare
CompDef_Node : Node_Id;
begin
@@ -567,6 +568,7 @@ package body CStand is
Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character));
Set_Component_Definition (Tdef_Node, CompDef_Node);
end;
+
Set_Subtype_Marks (Tdef_Node, New_List);
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_String), Tdef_Node);
Index: einfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.adb,v
retrieving revision 1.12
diff -u -p -r1.12 einfo.adb
--- einfo.adb 5 Jan 2004 15:20:43 -0000 1.12
+++ einfo.adb 13 Jan 2004 10:29:03 -0000
@@ -6,14 +6,14 @@
-- --
-- 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- --
-- 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 CPARTICULAR PURPOSE. See the GNU General Public License --
+-- 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, --
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_ch3.adb
--- exp_ch3.adb 12 Jan 2004 11:45:23 -0000 1.13
+++ exp_ch3.adb 13 Jan 2004 10:29:03 -0000
@@ -1527,7 +1527,7 @@ package body Exp_Ch3 is
-- aggregate that will be expanded inline
if Kind = N_Qualified_Expression then
- Kind := Nkind (Parent (N));
+ Kind := Nkind (Expression (N));
end if;
if Controlled_Type (Typ)
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch4.adb
--- exp_ch4.adb 5 Jan 2004 15:20:43 -0000 1.14
+++ exp_ch4.adb 13 Jan 2004 10:29:03 -0000
@@ -654,7 +654,8 @@ package body Exp_Ch4 is
Comp : RE_Id;
- Stg_Unit_Is_Byte : constant Boolean := System_Storage_Unit = Byte'Size;
+ Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
+ -- True for byte addressable target
function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
-- Returns True if the length of the given operand is known to be
@@ -707,7 +708,7 @@ package body Exp_Ch4 is
-- addressing of array components.
if not Is_Bit_Packed_Array (Typ1)
- and then Stg_Unit_Is_Byte
+ and then Byte_Addressable
and then not Java_VM
then
-- The call we generate is:
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch9.adb
--- exp_ch9.adb 12 Jan 2004 11:45:23 -0000 1.11
+++ exp_ch9.adb 13 Jan 2004 10:29:04 -0000
@@ -2612,10 +2612,10 @@ package body Exp_Ch9 is
(Parent (Efam)))), Loc))),
Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Character, Loc))));
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (Standard_Character, Loc))));
Insert_After (Current_Node, Efam_Decl);
Current_Node := Efam_Decl;
@@ -2629,10 +2629,12 @@ package body Exp_Ch9 is
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
+
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Efam_Type, Loc),
+
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
@@ -7283,11 +7285,13 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask_Info),
+
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
+
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
Index: exp_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dist.adb,v
retrieving revision 1.7
diff -u -p -r1.7 exp_dist.adb
--- exp_dist.adb 12 Jan 2004 11:45:23 -0000 1.7
+++ exp_dist.adb 13 Jan 2004 10:29:04 -0000
@@ -55,17 +55,19 @@ package body Exp_Dist is
-- The following model has been used to implement distributed objects:
-- given a designated type D and a RACW type R, then a record of the
-- form:
+
-- type Stub is tagged record
-- [...declaration similar to s-parint.ads RACW_Stub_Type...]
-- end record;
+
-- is built. This type has two properties:
- --
+
-- 1) Since it has the same structure than RACW_Stub_Type, it can be
-- converted to and from this type to make it suitable for
-- System.Partition_Interface.Get_Unique_Remote_Pointer in order
-- to avoid memory leaks when the same remote object arrive on the
-- same partition by following different pathes
- --
+
-- 2) It also has the same dispatching table as the designated type D,
-- and thus can be used as an object designated by a value of type
-- R on any partition other than the one on which the object has
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.12
diff -u -p -r1.12 gnatlink.adb
--- gnatlink.adb 5 Jan 2004 15:20:44 -0000 1.12
+++ gnatlink.adb 13 Jan 2004 10:29:04 -0000
@@ -678,7 +678,7 @@ procedure Gnatlink is
-- terminator.
function Index (S, Pattern : String) return Natural;
- -- Return the first occurrence of Pattern in S, or 0 if none.
+ -- Return the last occurrence of Pattern in S, or 0 if none.
function Is_Option_Present (Opt : in String) return Boolean;
-- Return true if the option Opt is already present in
@@ -727,8 +727,9 @@ procedure Gnatlink is
function Index (S, Pattern : String) return Natural is
Len : constant Natural := Pattern'Length;
+
begin
- for J in S'First .. S'Last - Len + 1 loop
+ for J in reverse S'First .. S'Last - Len + 1 loop
if Pattern = S (J .. J + Len - 1) then
return J;
end if;
@@ -1061,7 +1062,42 @@ procedure Gnatlink is
-- Also add path to find libgcc_s.so, if
-- relevant.
- GCC_Index := Index (File_Path.all, "gcc-lib");
+ -- To find the location of the shared version
+ -- of libgcc, we look for "gcc-lib" in the
+ -- path of the library. However, this
+ -- subdirectory is no longer present in
+ -- in recent version of GCC. So, we look for
+ -- the last subdirectory "lib" in the path.
+
+ GCC_Index :=
+ Index (File_Path.all, "gcc-lib");
+
+ if GCC_Index /= 0 then
+ -- The shared version of libgcc is
+ -- located in the parent directory.
+
+ GCC_Index := GCC_Index - 1;
+
+ else
+ GCC_Index :=
+ Index (File_Path.all, "/lib/");
+
+ if GCC_Index = 0 then
+ GCC_Index :=
+ Index (File_Path.all,
+ Directory_Separator &
+ "lib" &
+ Directory_Separator);
+ end if;
+
+ -- We have found a subdirectory "lib",
+ -- this is where the shared version of
+ -- libgcc should be located.
+
+ if GCC_Index /= 0 then
+ GCC_Index := GCC_Index + 3;
+ end if;
+ end if;
-- Look for an eventual run_path_option in
-- the linker switches.
@@ -1124,7 +1160,7 @@ procedure Gnatlink is
(1 .. File_Path'Length
- File_Name'Length)
& Path_Separator
- & File_Path (1 .. GCC_Index - 1));
+ & File_Path (1 .. GCC_Index));
else
Linker_Options.Table
@@ -1137,7 +1173,7 @@ procedure Gnatlink is
(1 .. File_Path'Length
- File_Name'Length)
& Path_Separator
- & File_Path (1 .. GCC_Index - 1));
+ & File_Path (1 .. GCC_Index));
end if;
end if;
end if;
Index: g-regpat.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-regpat.adb,v
retrieving revision 1.9
diff -u -p -r1.9 g-regpat.adb
--- g-regpat.adb 23 Oct 2003 11:57:52 -0000 1.9
+++ g-regpat.adb 13 Jan 2004 10:29:04 -0000
@@ -2997,9 +2997,9 @@ package body GNAT.Regpat is
function Match_Whilem (IP : Pointer) return Boolean is
pragma Unreferenced (IP);
- Cc : Current_Curly_Access := Current_Curly;
- N : constant Natural := Cc.Cur + 1;
- Ln : Natural := 0;
+ Cc : constant Current_Curly_Access := Current_Curly;
+ N : constant Natural := Cc.Cur + 1;
+ Ln : Natural := 0;
Lastloc : constant Natural := Cc.Lastloc;
-- Detection of 0-len.
Index: g-spitbo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-spitbo.adb,v
retrieving revision 1.4
diff -u -p -r1.4 g-spitbo.adb
--- g-spitbo.adb 21 Oct 2003 13:42:05 -0000 1.4
+++ g-spitbo.adb 13 Jan 2004 10:29:04 -0000
@@ -169,7 +169,7 @@ package body GNAT.Spitbol is
procedure Reverse_String (Str : in out VString) is
Len : constant Natural := Length (Str);
- Chars : String_Access := Get_String (Str);
+ Chars : constant String_Access := Get_String (Str);
Temp : Character;
begin
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.28
diff -u -p -r1.28 make.adb
--- make.adb 5 Jan 2004 15:20:44 -0000 1.28
+++ make.adb 13 Jan 2004 10:29:04 -0000
@@ -393,6 +393,14 @@ package body Make is
Bind_Shared_Known : Boolean := False;
-- Set to True after the first time Bind_Shared is computed
+ Shared_Libgcc : aliased String := "-shared-libgcc";
+
+ No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
+ Shared_Libgcc_Switch : aliased Argument_List :=
+ (1 => Shared_Libgcc'Access);
+ Link_With_Shared_Libgcc : Argument_List_Access :=
+ No_Shared_Libgcc_Switch'Access;
+
procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "");
-- Delete all temp files created by Gnatmake and call Osint.Fail,
-- with the parameter S1, S2 and S3 (see osint.ads).
@@ -3383,6 +3391,7 @@ package body Make is
Make.Initialize;
Bind_Shared := No_Shared_Switch'Access;
+ Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
Bind_Shared_Known := False;
Failed_Links.Set_Last (0);
@@ -4769,6 +4778,12 @@ package body Make is
Projects.Table (Proj).Library_Kind /= Static
then
Bind_Shared := Shared_Switch'Access;
+
+ if GCC_Version >= 3 then
+ Link_With_Shared_Libgcc :=
+ Shared_Libgcc_Switch'Access;
+ end if;
+
exit;
end if;
end loop;
@@ -5276,7 +5291,9 @@ package body Make is
-- And invoke the linker
begin
- Link (Main_ALI_File, Args (Args'First .. Last_Arg));
+ Link (Main_ALI_File,
+ Link_With_Shared_Libgcc.all &
+ Args (Args'First .. Last_Arg));
Successful_Links.Increment_Last;
Successful_Links.Table (Successful_Links.Last) :=
Main_ALI_File;
Index: opt.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.ads,v
retrieving revision 1.11
diff -u -p -r1.11 opt.ads
--- opt.ads 5 Jan 2004 15:20:45 -0000 1.11
+++ opt.ads 13 Jan 2004 10:29:04 -0000
@@ -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- --
@@ -443,6 +443,15 @@ package Opt is
Full_List : Boolean := False;
-- GNAT
-- Set True to generate full source listing with embedded errors
+
+ function get_gcc_version return Int;
+ pragma Import (C, get_gcc_version, "get_gcc_version");
+
+ GCC_Version : constant Nat := get_gcc_version;
+ -- GNATMAKE
+ -- Indicates which version of gcc is in use (2 = 2.8.1, 3 = 3.x).
+ -- Used in particular to decide if gcc switch -shared-libgcc should be
+ -- used (it cannot be used for 2.8.1).
Global_Discard_Names : Boolean := False;
-- GNAT, GNATBIND
Index: sem_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_dist.adb,v
retrieving revision 1.7
diff -u -p -r1.7 sem_dist.adb
--- sem_dist.adb 12 Jan 2004 11:45:25 -0000 1.7
+++ sem_dist.adb 13 Jan 2004 10:29:04 -0000
@@ -441,8 +441,7 @@ package body Sem_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
- New_Reference_To
- (Standard_Integer, Loc))),
+ New_Reference_To (Standard_Integer, Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -452,8 +451,7 @@ package body Sem_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
- New_Reference_To
- (RTE (RE_Unsigned_64), Loc))),
+ New_Reference_To (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -463,8 +461,7 @@ package body Sem_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
- New_Reference_To
- (Standard_Natural, Loc))),
+ New_Reference_To (Standard_Natural, Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -474,8 +471,7 @@ package body Sem_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
- New_Reference_To
- (Standard_Boolean, Loc)))))));
+ New_Reference_To (Standard_Boolean, Loc)))))));
Insert_After (N, New_Type_Decl);
Set_Equivalent_Type (User_Type, Fat_Type);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.18
diff -u -p -r1.18 sem_res.adb
--- sem_res.adb 12 Jan 2004 11:45:25 -0000 1.18
+++ sem_res.adb 13 Jan 2004 10:29:04 -0000
@@ -408,9 +408,10 @@ package body Sem_Res is
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
- and then
- (Nkind (Parent (Parent (P))) = N_Component_Definition
- or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then
+ (Nkind (Parent (Parent (P))) = N_Component_Definition
+ or else
+ Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
@@ -419,8 +420,9 @@ package body Sem_Res is
end if;
-- Detect a common beginner error:
+
-- type R (D : Positive := 100) is record
- -- Name: String (1 .. D);
+ -- Name : String (1 .. D);
-- end record;
-- The default value causes an object of type R to be
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.19
diff -u -p -r1.19 sem_util.adb
--- sem_util.adb 12 Jan 2004 11:45:25 -0000 1.19
+++ sem_util.adb 13 Jan 2004 10:29:05 -0000
@@ -3221,7 +3221,7 @@ package body Sem_Util is
function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
Comp_Decl : constant Node_Id := Parent (Comp);
Subt_Indic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp_Decl));
+ Subtype_Indication (Component_Definition (Comp_Decl));
Constr : Node_Id;
Assn : Node_Id;
Index: s-interr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-interr.adb,v
retrieving revision 1.9
diff -u -p -r1.9 s-interr.adb
--- s-interr.adb 5 Jan 2004 15:20:46 -0000 1.9
+++ s-interr.adb 13 Jan 2004 10:29:05 -0000
@@ -1249,7 +1249,7 @@ package body System.Interrupts is
task body Server_Task is
Intwait_Mask : aliased IMNG.Interrupt_Mask;
Ret_Interrupt : Interrupt_ID;
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
Tmp_Handler : Parameterless_Handler;
Tmp_ID : Task_ID;
Tmp_Entry_Index : Task_Entry_Index;
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sprint.adb
--- sprint.adb 12 Jan 2004 11:45:25 -0000 1.14
+++ sprint.adb 13 Jan 2004 10:29:05 -0000
@@ -951,9 +951,11 @@ package body Sprint is
when N_Component_Definition =>
Set_Debug_Sloc;
+
if Aliased_Present (Node) then
Write_Str_With_Col_Check ("aliased ");
end if;
+
Sprint_Node (Subtype_Indication (Node));
when N_Component_Declaration =>
Index: s-stache.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-stache.adb,v
retrieving revision 1.8
diff -u -p -r1.8 s-stache.adb
--- s-stache.adb 15 Dec 2003 11:51:00 -0000 1.8
+++ s-stache.adb 13 Jan 2004 10:29:05 -0000
@@ -214,7 +214,7 @@ package body System.Stack_Checking is
Full_Check :
declare
- My_Stack : Stack_Access := Set_Stack_Info (Cache'Access);
+ My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
-- At this point Stack.all might already be invalid, so
-- it is essential to use our local copy of Stack!
Index: s-taenca.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-taenca.adb,v
retrieving revision 1.5
diff -u -p -r1.5 s-taenca.adb
--- s-taenca.adb 21 Oct 2003 13:42:15 -0000 1.5
+++ s-taenca.adb 13 Jan 2004 10:29:05 -0000
@@ -262,7 +262,7 @@ package body System.Tasking.Entry_Calls
if Ceiling_Violation then
declare
- Current_Task : Task_ID := STPO.Self;
+ Current_Task : constant Task_ID := STPO.Self;
Old_Base_Priority : System.Any_Priority;
begin
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-12 11:52 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-12 11:52 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2004-01-12 Arnaud Charlet <charlet@act-europe.fr>
PR ada/13572
* bld.adb (Recursive_Process): Reference prefix/share/gnat instead of
prefix/share/make
* Makefile.generic: Update copyright.
Add license notice.
* Makefile.in (ADA_SHARE_MAKE_DIR): Set to prefix/share/gnat instead
of prefix/share/make.
* Makefile.prolog: Update copyright.
Add license notice.
2004-01-12 Laurent Pautet <pautet@act-europe.fr>
* 3vsocthi.adb, 3vsocthi.ads, 3wsocthi.adb,
3wsocthi.ads, 3zsocthi.adb, 3zsocthi.ads, g-socthi.adb,
g-socthi.ads (Socket_Error_Message): Return C.Strings.chars_ptr
instead of String.
* g-socket.adb (Raise_Socket_Error): Use new Socket_Error_Message
signature.
2004-01-12 Javier Miranda <miranda@gnat.com>
* cstand.adb, exp_aggr.adb, exp_ch3.adb, exp_ch9.adb, exp_dist.adb,
exp_imgv.adb, exp_pakd.adb, exp_util.adb, par-ch3.adb, sem.adb,
sem_ch12.adb, sem_ch3.adb, sem_dist.adb, sem_prag.adb, sem_res.adb,
sem_util.adb, sinfo.adb, sinfo.ads, sprint.adb: Addition of
Component_Definition node.
2004-01-12 Ed Falis <falis@gnat.com>
* impunit.adb: Add GNAT.Secondary_Stack_Info as user-visible unit
2004-01-12 Thomas Quinot <quinot@act-europe.fr>
* link.c: Change default libgnat kind to STATIC for FreeBSD.
2004-01-12 Bernard Banner <banner@gnat.com>
* Makefile.in: map 86numaux to a-numaux for x86_64
2004-01-12 Ed Schonberg <schonberg@gnat.com>
* lib-xref.adb (Get_Type_Reference): If the type is the subtype entity
generated to rename a generic actual, go to the actual itself, the
subtype is not a user-visible entity.
* sem_ch7.adb (Uninstall_Declarations): If an entity in the visible
part is a private subtype, reset the visibility of its full view, if
any, to be consistent.
PR ada/13417
* sem_ch12.adb (Analyze_Formal_Package): Diagnose properly an attempt
to use a generic package G as a formal package for another generic
declared within G.
2004-01-12 Robert Dewar <dewar@gnat.com>
* trans.c (Eliminate_Error_Msg): New procedure called to generate msg
* usage.adb: Remove mention of obsolete -gnatwb switch
Noticed during code reading
2004-01-12 Jerome Guitton <guitton@act-europe.fr>
* 1ssecsta.adb: Minor changes for -gnatwa warnings
2004-01-12 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 1ssecsta.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/1ssecsta.adb,v
retrieving revision 1.4
diff -u -p -r1.4 1ssecsta.adb
--- 1ssecsta.adb 24 Apr 2003 17:53:50 -0000 1.4
+++ 1ssecsta.adb 12 Jan 2004 11:43:51 -0000
@@ -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- --
@@ -94,7 +94,7 @@ package body System.Secondary_Stack is
end if;
Address := Sec_Stack.Mem (Sec_Stack.Top)'Address;
- Sec_Stack.Top := Sec_Stack.Top + Mark_Id (Max_Size);
+ Sec_Stack.Top := Sec_Stack.Top + Max_Size;
end SS_Allocate;
-------------
Index: 3vsocthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vsocthi.adb,v
retrieving revision 1.1
diff -u -p -r1.1 3vsocthi.adb
--- 3vsocthi.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 3vsocthi.adb 12 Jan 2004 11:43:51 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -58,33 +58,32 @@ package body GNAT.Sockets.Thin is
Thread_Blocking_IO : Boolean := True;
+ Unknown_System_Error : constant C.Strings.chars_ptr :=
+ C.Strings.New_String ("Unknown system error");
+
function Syscall_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int;
+ Addrlen : access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
pragma Import (C, Syscall_Connect, "connect");
function Syscall_Ioctl
(S : C.int;
Req : C.int;
- Arg : Int_Access)
- return C.int;
+ Arg : Int_Access) return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
@@ -93,8 +92,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int;
+ Fromlen : access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
@@ -116,8 +114,7 @@ package body GNAT.Sockets.Thin is
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
- (Domain, Typ, Protocol : C.int)
- return C.int;
+ (Domain, Typ, Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
function Non_Blocking_Socket (S : C.int) return Boolean;
@@ -130,8 +127,7 @@ package body GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int
+ Addrlen : access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
@@ -170,8 +166,7 @@ package body GNAT.Sockets.Thin is
function C_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int
+ Namelen : C.int) return C.int
is
Res : C.int;
@@ -231,10 +226,9 @@ package body GNAT.Sockets.Thin is
-------------
function C_Ioctl
- (S : C.int;
- Req : C.int;
- Arg : Int_Access)
- return C.int
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access) return C.int
is
begin
if not Thread_Blocking_IO
@@ -256,8 +250,7 @@ package body GNAT.Sockets.Thin is
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int
+ Flags : C.int) return C.int
is
Res : C.int;
@@ -284,8 +277,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int
+ Fromlen : access C.int) return C.int
is
Res : C.int;
@@ -310,8 +302,7 @@ package body GNAT.Sockets.Thin is
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int
+ Flags : C.int) return C.int
is
Res : C.int;
@@ -338,8 +329,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int
+ Tolen : C.int) return C.int
is
Res : C.int;
@@ -363,8 +353,7 @@ package body GNAT.Sockets.Thin is
function C_Socket
(Domain : C.int;
Typ : C.int;
- Protocol : C.int)
- return C.int
+ Protocol : C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
@@ -412,7 +401,6 @@ package body GNAT.Sockets.Thin is
function Non_Blocking_Socket (S : C.int) return Boolean is
R : Boolean;
-
begin
Task_Lock.Lock;
R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
@@ -424,10 +412,7 @@ package body GNAT.Sockets.Thin is
-- Set_Address --
-----------------
- procedure Set_Address
- (Sin : Sockaddr_In_Access;
- Address : In_Addr)
- is
+ procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is
begin
Sin.Sin_Addr := Address;
end Set_Address;
@@ -436,10 +421,7 @@ package body GNAT.Sockets.Thin is
-- Set_Family --
----------------
- procedure Set_Family
- (Sin : Sockaddr_In_Access;
- Family : C.int)
- is
+ procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is
begin
Sin.Sin_Family := C.unsigned_short (Family);
end Set_Family;
@@ -448,13 +430,9 @@ package body GNAT.Sockets.Thin is
-- Set_Length --
----------------
- procedure Set_Length
- (Sin : Sockaddr_In_Access;
- Len : C.int)
- is
+ procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is
pragma Unreferenced (Sin);
pragma Unreferenced (Len);
-
begin
null;
end Set_Length;
@@ -480,10 +458,7 @@ package body GNAT.Sockets.Thin is
-- Set_Port --
--------------
- procedure Set_Port
- (Sin : Sockaddr_In_Access;
- Port : C.unsigned_short)
- is
+ procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is
begin
Sin.Sin_Port := Port;
end Set_Port;
@@ -492,7 +467,9 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
- function Socket_Error_Message (Errno : Integer) return String is
+ function Socket_Error_Message
+ (Errno : Integer) return C.Strings.chars_ptr
+ is
use type Interfaces.C.Strings.chars_ptr;
C_Msg : C.Strings.chars_ptr;
@@ -501,10 +478,9 @@ package body GNAT.Sockets.Thin is
C_Msg := C_Strerror (C.int (Errno));
if C_Msg = C.Strings.Null_Ptr then
- return "Unknown system error";
-
+ return Unknown_System_Error;
else
- return C.Strings.Value (C_Msg);
+ return C_Msg;
end if;
end Socket_Error_Message;
@@ -515,8 +491,7 @@ package body GNAT.Sockets.Thin is
function C_Readv
(Fd : C.int;
Iov : System.Address;
- Iovcnt : C.int)
- return C.int
+ Iovcnt : C.int) return C.int
is
Res : C.int;
Count : C.int := 0;
@@ -548,8 +523,7 @@ package body GNAT.Sockets.Thin is
function C_Writev
(Fd : C.int;
Iov : System.Address;
- Iovcnt : C.int)
- return C.int
+ Iovcnt : C.int) return C.int
is
Res : C.int;
Count : C.int := 0;
Index: 3vsocthi.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vsocthi.ads,v
retrieving revision 1.1
diff -u -p -r1.1 3vsocthi.ads
--- 3vsocthi.ads 21 Oct 2003 13:41:51 -0000 1.1
+++ 3vsocthi.ads 12 Jan 2004 11:43:51 -0000
@@ -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- --
@@ -60,7 +60,7 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number.
- function Socket_Error_Message (Errno : Integer) return String;
+ function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
Index: 3wsocthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3wsocthi.adb,v
retrieving revision 1.5
diff -u -p -r1.5 3wsocthi.adb
--- 3wsocthi.adb 5 Jan 2004 15:20:42 -0000 1.5
+++ 3wsocthi.adb 12 Jan 2004 11:43:51 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -38,6 +38,7 @@
-- This version is for NT.
with GNAT.Sockets.Constants; use GNAT.Sockets.Constants;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
with System; use System;
@@ -71,6 +72,166 @@ package body GNAT.Sockets.Thin is
return C.int;
pragma Import (Stdcall, Standard_Select, "select");
+ type Error_Type is
+ (N_EINTR,
+ N_EBADF,
+ N_EACCES,
+ N_EFAULT,
+ N_EINVAL,
+ N_EMFILE,
+ N_EWOULDBLOCK,
+ N_EINPROGRESS,
+ N_EALREADY,
+ N_ENOTSOCK,
+ N_EDESTADDRREQ,
+ N_EMSGSIZE,
+ N_EPROTOTYPE,
+ N_ENOPROTOOPT,
+ N_EPROTONOSUPPORT,
+ N_ESOCKTNOSUPPORT,
+ N_EOPNOTSUPP,
+ N_EPFNOSUPPORT,
+ N_EAFNOSUPPORT,
+ N_EADDRINUSE,
+ N_EADDRNOTAVAIL,
+ N_ENETDOWN,
+ N_ENETUNREACH,
+ N_ENETRESET,
+ N_ECONNABORTED,
+ N_ECONNRESET,
+ N_ENOBUFS,
+ N_EISCONN,
+ N_ENOTCONN,
+ N_ESHUTDOWN,
+ N_ETOOMANYREFS,
+ N_ETIMEDOUT,
+ N_ECONNREFUSED,
+ N_ELOOP,
+ N_ENAMETOOLONG,
+ N_EHOSTDOWN,
+ N_EHOSTUNREACH,
+ N_SYSNOTREADY,
+ N_VERNOTSUPPORTED,
+ N_NOTINITIALISED,
+ N_EDISCON,
+ N_HOST_NOT_FOUND,
+ N_TRY_AGAIN,
+ N_NO_RECOVERY,
+ N_NO_DATA,
+ N_OTHERS);
+
+ Error_Messages : constant array (Error_Type) of chars_ptr :=
+ (N_EINTR =>
+ New_String ("Interrupted system call"),
+ N_EBADF =>
+ New_String ("Bad file number"),
+ N_EACCES =>
+ New_String ("Permission denied"),
+ N_EFAULT =>
+ New_String ("Bad address"),
+ N_EINVAL =>
+ New_String ("Invalid argument"),
+ N_EMFILE =>
+ New_String ("Too many open files"),
+ N_EWOULDBLOCK =>
+ New_String ("Operation would block"),
+ N_EINPROGRESS =>
+ New_String ("Operation now in progress. This error is "
+ & "returned if any Windows Sockets API "
+ & "function is called while a blocking "
+ & "function is in progress"),
+ N_EALREADY =>
+ New_String ("Operation already in progress"),
+ N_ENOTSOCK =>
+ New_String ("Socket operation on nonsocket"),
+ N_EDESTADDRREQ =>
+ New_String ("Destination address required"),
+ N_EMSGSIZE =>
+ New_String ("Message too long"),
+ N_EPROTOTYPE =>
+ New_String ("Protocol wrong type for socket"),
+ N_ENOPROTOOPT =>
+ New_String ("Protocol not available"),
+ N_EPROTONOSUPPORT =>
+ New_String ("Protocol not supported"),
+ N_ESOCKTNOSUPPORT =>
+ New_String ("Socket type not supported"),
+ N_EOPNOTSUPP =>
+ New_String ("Operation not supported on socket"),
+ N_EPFNOSUPPORT =>
+ New_String ("Protocol family not supported"),
+ N_EAFNOSUPPORT =>
+ New_String ("Address family not supported by protocol family"),
+ N_EADDRINUSE =>
+ New_String ("Address already in use"),
+ N_EADDRNOTAVAIL =>
+ New_String ("Cannot assign requested address"),
+ N_ENETDOWN =>
+ New_String ("Network is down. This error may be "
+ & "reported at any time if the Windows "
+ & "Sockets implementation detects an "
+ & "underlying failure"),
+ N_ENETUNREACH =>
+ New_String ("Network is unreachable"),
+ N_ENETRESET =>
+ New_String ("Network dropped connection on reset"),
+ N_ECONNABORTED =>
+ New_String ("Software caused connection abort"),
+ N_ECONNRESET =>
+ New_String ("Connection reset by peer"),
+ N_ENOBUFS =>
+ New_String ("No buffer space available"),
+ N_EISCONN =>
+ New_String ("Socket is already connected"),
+ N_ENOTCONN =>
+ New_String ("Socket is not connected"),
+ N_ESHUTDOWN =>
+ New_String ("Cannot send after socket shutdown"),
+ N_ETOOMANYREFS =>
+ New_String ("Too many references: cannot splice"),
+ N_ETIMEDOUT =>
+ New_String ("Connection timed out"),
+ N_ECONNREFUSED =>
+ New_String ("Connection refused"),
+ N_ELOOP =>
+ New_String ("Too many levels of symbolic links"),
+ N_ENAMETOOLONG =>
+ New_String ("File name too long"),
+ N_EHOSTDOWN =>
+ New_String ("Host is down"),
+ N_EHOSTUNREACH =>
+ New_String ("No route to host"),
+ N_SYSNOTREADY =>
+ New_String ("Returned by WSAStartup(), indicating that "
+ & "the network subsystem is unusable"),
+ N_VERNOTSUPPORTED =>
+ New_String ("Returned by WSAStartup(), indicating that "
+ & "the Windows Sockets DLL cannot support "
+ & "this application"),
+ N_NOTINITIALISED =>
+ New_String ("Winsock not initialized. This message is "
+ & "returned by any function except WSAStartup(), "
+ & "indicating that a successful WSAStartup() has "
+ & "not yet been performed"),
+ N_EDISCON =>
+ New_String ("Disconnect"),
+ N_HOST_NOT_FOUND =>
+ New_String ("Host not found. This message indicates "
+ & "that the key (name, address, and so on) was not found"),
+ N_TRY_AGAIN =>
+ New_String ("Nonauthoritative host not found. This error may "
+ & "suggest that the name service itself is not "
+ & "functioning"),
+ N_NO_RECOVERY =>
+ New_String ("Nonrecoverable error. This error may suggest that the "
+ & "name service itself is not functioning"),
+ N_NO_DATA =>
+ New_String ("Valid name, no data record of requested type. "
+ & "This error indicates that the key (name, address, "
+ & "and so on) was not found."),
+ N_OTHERS =>
+ New_String ("Unknown system error"));
+
---------------
-- C_Connect --
---------------
@@ -366,165 +527,60 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
- function Socket_Error_Message (Errno : Integer) return String is
+ function Socket_Error_Message
+ (Errno : Integer)
+ return C.Strings.chars_ptr
+ is
use GNAT.Sockets.Constants;
begin
case Errno is
- when EINTR =>
- return "Interrupted system call";
-
- when EBADF =>
- return "Bad file number";
-
- when EACCES =>
- return "Permission denied";
-
- when EFAULT =>
- return "Bad address";
-
- when EINVAL =>
- return "Invalid argument";
-
- when EMFILE =>
- return "Too many open files";
-
- when EWOULDBLOCK =>
- return "Operation would block";
-
- when EINPROGRESS =>
- return "Operation now in progress. This error is "
- & "returned if any Windows Sockets API "
- & "function is called while a blocking "
- & "function is in progress";
-
- when EALREADY =>
- return "Operation already in progress";
-
- when ENOTSOCK =>
- return "Socket operation on nonsocket";
-
- when EDESTADDRREQ =>
- return "Destination address required";
-
- when EMSGSIZE =>
- return "Message too long";
-
- when EPROTOTYPE =>
- return "Protocol wrong type for socket";
-
- when ENOPROTOOPT =>
- return "Protocol not available";
-
- when EPROTONOSUPPORT =>
- return "Protocol not supported";
-
- when ESOCKTNOSUPPORT =>
- return "Socket type not supported";
-
- when EOPNOTSUPP =>
- return "Operation not supported on socket";
-
- when EPFNOSUPPORT =>
- return "Protocol family not supported";
-
- when EAFNOSUPPORT =>
- return "Address family not supported by protocol family";
-
- when EADDRINUSE =>
- return "Address already in use";
-
- when EADDRNOTAVAIL =>
- return "Cannot assign requested address";
-
- when ENETDOWN =>
- return "Network is down. This error may be "
- & "reported at any time if the Windows "
- & "Sockets implementation detects an "
- & "underlying failure";
-
- when ENETUNREACH =>
- return "Network is unreachable";
-
- when ENETRESET =>
- return "Network dropped connection on reset";
-
- when ECONNABORTED =>
- return "Software caused connection abort";
-
- when ECONNRESET =>
- return "Connection reset by peer";
-
- when ENOBUFS =>
- return "No buffer space available";
-
- when EISCONN =>
- return "Socket is already connected";
-
- when ENOTCONN =>
- return "Socket is not connected";
-
- when ESHUTDOWN =>
- return "Cannot send after socket shutdown";
-
- when ETOOMANYREFS =>
- return "Too many references: cannot splice";
-
- when ETIMEDOUT =>
- return "Connection timed out";
-
- when ECONNREFUSED =>
- return "Connection refused";
-
- when ELOOP =>
- return "Too many levels of symbolic links";
-
- when ENAMETOOLONG =>
- return "File name too long";
-
- when EHOSTDOWN =>
- return "Host is down";
-
- when EHOSTUNREACH =>
- return "No route to host";
-
- when SYSNOTREADY =>
- return "Returned by WSAStartup(), indicating that "
- & "the network subsystem is unusable";
-
- when VERNOTSUPPORTED =>
- return "Returned by WSAStartup(), indicating that "
- & "the Windows Sockets DLL cannot support this application";
-
- when NOTINITIALISED =>
- return "Winsock not initialized. This message is "
- & "returned by any function except WSAStartup(), "
- & "indicating that a successful WSAStartup() has "
- & "not yet been performed";
-
- when EDISCON =>
- return "Disconnect";
-
- when HOST_NOT_FOUND =>
- return "Host not found. This message indicates "
- & "that the key (name, address, and so on) was not found";
-
- when TRY_AGAIN =>
- return "Nonauthoritative host not found. This error may "
- & "suggest that the name service itself is not functioning";
-
- when NO_RECOVERY =>
- return "Nonrecoverable error. This error may suggest that the "
- & "name service itself is not functioning";
-
- when NO_DATA =>
- return "Valid name, no data record of requested type. "
- & "This error indicates that the key (name, address, "
- & "and so on) was not found.";
-
- when others =>
- return "Unknown system error";
-
+ when EINTR => return Error_Messages (N_EINTR);
+ when EBADF => return Error_Messages (N_EBADF);
+ when EACCES => return Error_Messages (N_EACCES);
+ when EFAULT => return Error_Messages (N_EFAULT);
+ when EINVAL => return Error_Messages (N_EINVAL);
+ when EMFILE => return Error_Messages (N_EMFILE);
+ when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
+ when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
+ when EALREADY => return Error_Messages (N_EALREADY);
+ when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
+ when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
+ when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
+ when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
+ when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
+ when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
+ when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
+ when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
+ when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
+ when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
+ when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
+ when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
+ when ENETDOWN => return Error_Messages (N_ENETDOWN);
+ when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
+ when ENETRESET => return Error_Messages (N_ENETRESET);
+ when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
+ when ECONNRESET => return Error_Messages (N_ECONNRESET);
+ when ENOBUFS => return Error_Messages (N_ENOBUFS);
+ when EISCONN => return Error_Messages (N_EISCONN);
+ when ENOTCONN => return Error_Messages (N_ENOTCONN);
+ when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
+ when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
+ when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
+ when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
+ when ELOOP => return Error_Messages (N_ELOOP);
+ when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
+ when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
+ when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
+ when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY);
+ when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED);
+ when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED);
+ when EDISCON => return Error_Messages (N_EDISCON);
+ when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
+ when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
+ when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
+ when NO_DATA => return Error_Messages (N_NO_DATA);
+ when others => return Error_Messages (N_OTHERS);
end case;
end Socket_Error_Message;
Index: 3wsocthi.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3wsocthi.ads,v
retrieving revision 1.4
diff -u -p -r1.4 3wsocthi.ads
--- 3wsocthi.ads 21 Oct 2003 13:41:51 -0000 1.4
+++ 3wsocthi.ads 12 Jan 2004 11:43:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -60,7 +60,9 @@ package GNAT.Sockets.Thin is
procedure Set_Socket_Errno (Errno : Integer);
-- Set last socket error number.
- function Socket_Error_Message (Errno : Integer) return String;
+ function Socket_Error_Message
+ (Errno : Integer)
+ return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
@@ -177,10 +179,10 @@ package GNAT.Sockets.Thin is
-- Access to host entry
type Servent is record
- S_Name : C.Strings.chars_ptr;
- S_Aliases : Chars_Ptr_Pointers.Pointer;
- S_Port : C.int;
- S_Proto : C.Strings.chars_ptr;
+ S_Name : C.Strings.chars_ptr;
+ S_Aliases : Chars_Ptr_Pointers.Pointer;
+ S_Port : C.int;
+ S_Proto : C.Strings.chars_ptr;
end record;
pragma Convention (C, Servent);
-- Service entry
@@ -196,102 +198,85 @@ package GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int;
+ Addrlen : access C.int) return C.int;
function C_Bind
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
function C_Close
- (Fd : C.int)
- return C.int;
+ (Fd : C.int) return C.int;
function C_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
function C_Gethostbyaddr
(Addr : System.Address;
Length : C.int;
- Typ : C.int)
- return Hostent_Access;
+ Typ : C.int) return Hostent_Access;
function C_Gethostbyname
- (Name : C.char_array)
- return Hostent_Access;
+ (Name : C.char_array) return Hostent_Access;
function C_Gethostname
(Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
function C_Getpeername
(S : C.int;
Name : System.Address;
- Namelen : access C.int)
- return C.int;
+ Namelen : access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
- Proto : C.char_array)
- return Servent_Access;
+ Proto : C.char_array) return Servent_Access;
function C_Getservbyport
(Port : C.int;
- Proto : C.char_array)
- return Servent_Access;
+ Proto : C.char_array) return Servent_Access;
function C_Getsockname
(S : C.int;
Name : System.Address;
- Namelen : access C.int)
- return C.int;
+ Namelen : access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
- Optlen : access C.int)
- return C.int;
+ Optlen : access C.int) return C.int;
function C_Inet_Addr
- (Cp : C.Strings.chars_ptr)
- return C.int;
+ (Cp : C.Strings.chars_ptr) return C.int;
function C_Ioctl
(S : C.int;
Req : C.int;
- Arg : Int_Access)
- return C.int;
+ Arg : Int_Access) return C.int;
function C_Listen
- (S, Backlog : C.int)
- return C.int;
+ (S : C.int;
+ Backlog : C.int) return C.int;
function C_Read
(Fildes : C.int;
Buf : System.Address;
- Nbyte : C.int)
- return C.int;
+ Nbyte : C.int) return C.int;
function C_Readv
(Socket : C.int;
Iov : System.Address;
- Iovcnt : C.int)
- return C.int;
+ Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Buf : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
function C_Recvfrom
(S : C.int;
@@ -299,23 +284,20 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int;
+ Fromlen : access C.int) return C.int;
function C_Select
(Nfds : C.int;
Readfds : Fd_Set_Access;
Writefds : Fd_Set_Access;
Exceptfds : Fd_Set_Access;
- Timeout : Timeval_Access)
- return C.int;
+ Timeout : Timeval_Access) return C.int;
function C_Send
(S : C.int;
Buf : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
function C_Sendto
(S : C.int;
@@ -323,55 +305,46 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int;
+ Tolen : C.int) return C.int;
function C_Setsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
- Optlen : C.int)
- return C.int;
+ Optlen : C.int) return C.int;
function C_Shutdown
(S : C.int;
- How : C.int)
- return C.int;
+ How : C.int) return C.int;
function C_Socket
(Domain : C.int;
Typ : C.int;
- Protocol : C.int)
- return C.int;
+ Protocol : C.int) return C.int;
function C_Strerror
- (Errnum : C.int)
- return C.Strings.chars_ptr;
+ (Errnum : C.int) return C.Strings.chars_ptr;
function C_System
- (Command : System.Address)
- return C.int;
+ (Command : System.Address) return C.int;
function C_Write
(Fildes : C.int;
Buf : System.Address;
- Nbyte : C.int)
- return C.int;
+ Nbyte : C.int) return C.int;
function C_Writev
(Socket : C.int;
Iov : System.Address;
- Iovcnt : C.int)
- return C.int;
+ Iovcnt : C.int) return C.int;
function WSAStartup
(WS_Version : Interfaces.C.int;
- WSADataAddress : System.Address)
- return Interfaces.C.int;
+ WSADataAddress : System.Address) return Interfaces.C.int;
procedure Free_Socket_Set
- (Set : Fd_Set_Access);
+ (Set : Fd_Set_Access);
-- Free system-dependent socket set.
procedure Get_Socket_From_Set
@@ -391,8 +364,7 @@ package GNAT.Sockets.Thin is
function Is_Socket_In_Set
(Set : Fd_Set_Access;
- Socket : C.int)
- return Boolean;
+ Socket : C.int) return Boolean;
-- Check whether Socket is in the socket set
procedure Last_Socket_In_Set
@@ -405,8 +377,7 @@ package GNAT.Sockets.Thin is
-- set back to the real largest socket in the socket set.
function New_Socket_Set
- (Set : Fd_Set_Access)
- return Fd_Set_Access;
+ (Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure
-- and initialize by copying Set if it is non-null, by making it
-- empty otherwise.
Index: 3zsocthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3zsocthi.adb,v
retrieving revision 1.2
diff -u -p -r1.2 3zsocthi.adb
--- 3zsocthi.adb 5 Jan 2004 15:20:42 -0000 1.2
+++ 3zsocthi.adb 12 Jan 2004 11:43:52 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- 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- --
@@ -63,6 +63,9 @@ package body GNAT.Sockets.Thin is
Thread_Blocking_IO : Boolean := True;
+ Unknown_System_Error : constant C.Strings.chars_ptr :=
+ C.Strings.New_String ("Unknown system error");
+
-- The following types and variables are required to create a Hostent
-- record "by hand".
@@ -588,7 +591,9 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
- function Socket_Error_Message (Errno : Integer) return String is
+ function Socket_Error_Message
+ (Errno : Integer) return C.Strings.chars_ptr
+ is
use type Interfaces.C.Strings.chars_ptr;
C_Msg : C.Strings.chars_ptr;
@@ -597,9 +602,10 @@ package body GNAT.Sockets.Thin is
C_Msg := C_Strerror (C.int (Errno));
if C_Msg = C.Strings.Null_Ptr then
- return "Unknown system error";
+ return Unknown_System_Error;
+
else
- return C.Strings.Value (C_Msg);
+ return C_Msg;
end if;
end Socket_Error_Message;
Index: 3zsocthi.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3zsocthi.ads,v
retrieving revision 1.1
diff -u -p -r1.1 3zsocthi.ads
--- 3zsocthi.ads 21 Oct 2003 13:41:51 -0000 1.1
+++ 3zsocthi.ads 12 Jan 2004 11:43:52 -0000
@@ -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- --
@@ -59,7 +59,7 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number.
- function Socket_Error_Message (Errno : Integer) return String;
+ function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -p -r1.5 -r1.6
--- bld.adb 5 Jan 2004 15:20:43 -0000 1.5
+++ bld.adb 12 Jan 2004 11:36:12 -0000 1.6
@@ -2626,7 +2626,7 @@ package body Bld is
Put_Directory_Separator;
Put ("share");
Put_Directory_Separator;
- Put ("make");
+ Put ("gnat");
Put_Directory_Separator;
Put ("Makefile.prolog");
New_Line;
@@ -3347,7 +3347,7 @@ package body Bld is
Put_Directory_Separator;
Put ("share");
Put_Directory_Separator;
- Put ("make");
+ Put ("gnat");
Put_Directory_Separator;
Put ("Makefile.generic");
New_Line;
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.14
diff -u -p -r1.14 cstand.adb
--- cstand.adb 5 Jan 2004 15:20:43 -0000 1.14
+++ cstand.adb 12 Jan 2004 11:43:52 -0000
@@ -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- --
@@ -559,7 +559,14 @@ package body CStand is
-- Create type definition node for type String
Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
- Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Character));
+ declare
+ CompDef_Node : Node_Id;
+ begin
+ CompDef_Node := New_Node (N_Component_Definition, Stloc);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character));
+ Set_Component_Definition (Tdef_Node, CompDef_Node);
+ end;
Set_Subtype_Marks (Tdef_Node, New_List);
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_String), Tdef_Node);
@@ -581,7 +588,15 @@ package body CStand is
-- Create type definition node for type Wide_String
Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
- Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Wide_Character));
+ declare
+ CompDef_Node : Node_Id;
+ begin
+ CompDef_Node := New_Node (N_Component_Definition, Stloc);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Subtype_Indication (CompDef_Node,
+ Identifier_For (S_Wide_Character));
+ Set_Component_Definition (Tdef_Node, CompDef_Node);
+ end;
Set_Subtype_Marks (Tdef_Node, New_List);
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
@@ -1119,7 +1134,11 @@ package body CStand is
Append (
Make_Component_Declaration (Stloc,
Defining_Identifier => Comp,
- Subtype_Indication => New_Occurrence_Of (Etype (Comp), Stloc)),
+ Component_Definition =>
+ Make_Component_Definition (Stloc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Etype (Comp),
+ Stloc))),
Comp_List);
Next_Entity (Comp);
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_aggr.adb
--- exp_aggr.adb 5 Jan 2004 15:20:43 -0000 1.12
+++ exp_aggr.adb 12 Jan 2004 11:43:53 -0000
@@ -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- --
@@ -3062,8 +3062,11 @@ package body Exp_Aggr is
Type_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => Indices,
- Subtype_Indication =>
- New_Occurrence_Of (Component_Type (Typ), Loc)));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Component_Type (Typ), Loc))));
Insert_Action (N, Decl);
Analyze (Decl);
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_ch3.adb
--- exp_ch3.adb 5 Jan 2004 15:20:43 -0000 1.12
+++ exp_ch3.adb 12 Jan 2004 11:43:54 -0000
@@ -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- --
@@ -1937,7 +1937,8 @@ package body Exp_Ch3 is
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Loc := Sloc (Decl);
- Build_Record_Checks (Subtype_Indication (Decl), Check_List);
+ Build_Record_Checks
+ (Subtype_Indication (Component_Definition (Decl)), Check_List);
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
@@ -2725,7 +2726,10 @@ package body Exp_Ch3 is
Comp_Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Parent_N,
- Subtype_Indication => New_Reference_To (Par_Subtype, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Par_Subtype, Loc)));
if Null_Present (Rec_Ext_Part) then
Set_Component_List (Rec_Ext_Part,
@@ -3302,7 +3306,10 @@ package body Exp_Ch3 is
Comp_Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Ent,
- Subtype_Indication => New_Reference_To (Controller_Type, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Controller_Type, Loc)));
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
@@ -3393,8 +3400,10 @@ package body Exp_Ch3 is
Comp_Decl :=
Make_Component_Declaration (Sloc_N,
Defining_Identifier => Tag_Component (T),
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Tag), Sloc_N));
+ Component_Definition =>
+ Make_Component_Definition (Sloc_N,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N)));
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
@@ -3410,7 +3419,7 @@ package body Exp_Ch3 is
-- already been analyzed previously. Here we just insure that the
-- tree is coherent with the semantic decoration
- Find_Type (Subtype_Indication (Comp_Decl));
+ Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
exception
when RE_Not_Available =>
@@ -3579,7 +3588,10 @@ package body Exp_Ch3 is
High_Bound =>
Make_Integer_Literal (Loc, Num - 1))))),
- Subtype_Indication => New_Reference_To (Typ, Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Typ, Loc))),
Expression =>
Make_Aggregate (Loc,
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_ch9.adb
--- exp_ch9.adb 5 Jan 2004 15:20:43 -0000 1.10
+++ exp_ch9.adb 12 Jan 2004 11:43:56 -0000
@@ -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- --
@@ -2611,8 +2611,11 @@ package body Exp_Ch9 is
(Etype (Discrete_Subtype_Definition
(Parent (Efam)))), Loc))),
- Subtype_Indication =>
- New_Reference_To (Standard_Character, Loc)));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (Standard_Character, Loc))));
Insert_After (Current_Node, Efam_Decl);
Current_Node := Efam_Decl;
@@ -2623,17 +2626,21 @@ package body Exp_Ch9 is
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Efam)),
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Efam_Type, Loc),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Efam_Type, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ New_Occurrence_Of
+ (Etype (Discrete_Subtype_Definition
+ (Parent (Efam))), Loc)))))));
+
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- New_Occurrence_Of
- (Etype (Discrete_Subtype_Definition
- (Parent (Efam))), Loc))))));
end if;
Next_Entity (Efam);
@@ -3265,14 +3272,19 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Address), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
- Subtype_Indication =>
- New_Occurrence_Of (D_T2, Loc)));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
Decl2 :=
Make_Full_Type_Declaration (Loc,
@@ -4668,7 +4680,10 @@ package body Exp_Ch9 is
Append_To (Components,
Make_Component_Declaration (Loc,
Defining_Identifier => Component,
- Subtype_Indication => New_Reference_To (Ctype, Loc)));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Ctype, Loc))));
Next_Formal_With_Extras (Formal);
end loop;
@@ -5227,8 +5242,10 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uObject),
- Aliased_Present => True,
- Subtype_Indication => Protection_Subtype);
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => True,
+ Subtype_Indication => Protection_Subtype));
end;
pragma Assert (Present (Pdef));
@@ -5246,8 +5263,13 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Pent), Chars (Pent)),
- Subtype_Indication =>
- New_Copy_Tree (Subtype_Indication (Priv), Discr_Map),
+ Component_Definition =>
+ Make_Component_Definition (Sloc (Pent),
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Copy_Tree (Subtype_Indication
+ (Component_Definition (Priv)),
+ Discr_Map)),
Expression => Expression (Priv));
Append_To (Cdecls, New_Priv);
@@ -7175,7 +7197,11 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask_Id),
- Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_ID), Loc)));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_ID),
+ Loc))));
-- Add components for entry families
@@ -7216,7 +7242,11 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uPriority),
- Subtype_Indication => New_Reference_To (Standard_Integer, Loc),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Standard_Integer,
+ Loc)),
Expression => Expr));
end;
end if;
@@ -7231,7 +7261,11 @@ package body Exp_Ch9 is
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uSize),
- Subtype_Indication => New_Reference_To (RTE (RE_Size_Type), Loc),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
+ Loc)),
Expression =>
Convert_To (RTE (RE_Size_Type),
@@ -7249,8 +7283,11 @@ package body Exp_Ch9 is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask_Info),
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Task_Info_Type), Loc),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
Index: exp_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dist.adb,v
retrieving revision 1.6
diff -u -p -r1.6 exp_dist.adb
--- exp_dist.adb 21 Oct 2003 13:41:59 -0000 1.6
+++ exp_dist.adb 12 Jan 2004 11:43:56 -0000
@@ -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- --
@@ -1886,26 +1886,38 @@ package body Exp_Dist is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Origin),
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Receiver),
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Addr),
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Asynchronous),
- Subtype_Indication =>
- New_Occurrence_Of (Standard_Boolean, Loc))))));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Boolean, Loc)))))));
Append_To (Decls, Stub_Type_Declaration);
Analyze (Stub_Type_Declaration);
Index: exp_imgv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_imgv.adb,v
retrieving revision 1.6
diff -u -p -r1.6 exp_imgv.adb
--- exp_imgv.adb 21 Oct 2003 13:41:59 -0000 1.6
+++ exp_imgv.adb 12 Jan 2004 11:43:56 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -140,7 +140,10 @@ package body Exp_Imgv is
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 0),
High_Bound => Make_Integer_Literal (Loc, Nlit))),
- Subtype_Indication => New_Occurrence_Of (Ityp, Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
Expression =>
Make_Aggregate (Loc,
Index: exp_pakd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_pakd.adb,v
retrieving revision 1.7
diff -u -p -r1.7 exp_pakd.adb
--- exp_pakd.adb 21 Oct 2003 13:41:59 -0000 1.7
+++ exp_pakd.adb 12 Jan 2004 11:43:57 -0000
@@ -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- --
@@ -958,15 +958,21 @@ package body Exp_Pakd is
Typedef :=
Make_Unconstrained_Array_Definition (Loc,
Subtype_Marks => Indexes,
- Subtype_Indication =>
- New_Occurrence_Of (Ctyp, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ctyp, Loc)));
else
Typedef :=
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => Indexes,
- Subtype_Indication =>
- New_Occurrence_Of (Ctyp, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ctyp, Loc)));
end if;
Decl :=
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.17
diff -u -p -r1.17 exp_util.adb
--- exp_util.adb 5 Jan 2004 15:20:43 -0000 1.17
+++ exp_util.adb 12 Jan 2004 11:43:57 -0000
@@ -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- --
@@ -2009,6 +2009,7 @@ package body Exp_Util is
N_Compilation_Unit_Aux |
N_Component_Clause |
N_Component_Declaration |
+ N_Component_Definition |
N_Component_List |
N_Constrained_Array_Definition |
N_Decimal_Fixed_Point_Definition |
@@ -2813,13 +2814,22 @@ package body Exp_Util is
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uParent),
- Subtype_Indication => New_Reference_To (Constr_Root, Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (Constr_Root, Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('C')),
- Subtype_Indication => New_Reference_To (Str_Type, Loc))),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (Str_Type, Loc)))),
+
Variant_Part => Empty))));
Insert_Actions (E, List_Def);
Index: g-socket.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.adb,v
retrieving revision 1.8
diff -u -p -r1.8 g-socket.adb
--- g-socket.adb 1 Dec 2003 13:29:27 -0000 1.8
+++ g-socket.adb 12 Jan 2004 11:43:57 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -1403,7 +1403,8 @@ package body GNAT.Sockets is
begin
Ada.Exceptions.Raise_Exception
- (Socket_Error'Identity, Image (Error) & Socket_Error_Message (Error));
+ (Socket_Error'Identity,
+ Image (Error) & C.Strings.Value (Socket_Error_Message (Error)));
end Raise_Socket_Error;
----------
Index: g-socthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socthi.adb,v
retrieving revision 1.4
diff -u -p -r1.4 g-socthi.adb
--- g-socthi.adb 21 Oct 2003 13:42:05 -0000 1.4
+++ g-socthi.adb 12 Jan 2004 11:43:57 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -44,8 +44,8 @@ with Interfaces.C; use Interfaces.C;
package body GNAT.Sockets.Thin is
- Non_Blocking_Sockets : constant Fd_Set_Access
- := New_Socket_Set (No_Socket_Set);
+ Non_Blocking_Sockets : constant Fd_Set_Access :=
+ New_Socket_Set (No_Socket_Set);
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
@@ -62,33 +62,32 @@ package body GNAT.Sockets.Thin is
Thread_Blocking_IO : Boolean := True;
+ Unknown_System_Error : constant C.Strings.chars_ptr :=
+ C.Strings.New_String ("Unknown system error");
+
function Syscall_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int;
+ Addrlen : access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
pragma Import (C, Syscall_Connect, "connect");
function Syscall_Ioctl
(S : C.int;
Req : C.int;
- Arg : Int_Access)
- return C.int;
+ Arg : Int_Access) return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
@@ -97,16 +96,14 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int;
+ Fromlen : access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
pragma Import (C, Syscall_Send, "send");
function Syscall_Sendto
@@ -115,13 +112,13 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int;
+ Tolen : C.int) return C.int;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
- (Domain, Typ, Protocol : C.int)
- return C.int;
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
function Non_Blocking_Socket (S : C.int) return Boolean;
@@ -134,8 +131,7 @@ package body GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int
+ Addrlen : access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
@@ -174,8 +170,7 @@ package body GNAT.Sockets.Thin is
function C_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int
+ Namelen : C.int) return C.int
is
Res : C.int;
@@ -235,10 +230,9 @@ package body GNAT.Sockets.Thin is
-------------
function C_Ioctl
- (S : C.int;
- Req : C.int;
- Arg : Int_Access)
- return C.int
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access) return C.int
is
begin
if not Thread_Blocking_IO
@@ -260,8 +254,7 @@ package body GNAT.Sockets.Thin is
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int
+ Flags : C.int) return C.int
is
Res : C.int;
@@ -288,8 +281,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int
+ Fromlen : access C.int) return C.int
is
Res : C.int;
@@ -314,8 +306,7 @@ package body GNAT.Sockets.Thin is
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int
+ Flags : C.int) return C.int
is
Res : C.int;
@@ -342,8 +333,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int
+ Tolen : C.int) return C.int
is
Res : C.int;
@@ -367,8 +357,7 @@ package body GNAT.Sockets.Thin is
function C_Socket
(Domain : C.int;
Typ : C.int;
- Protocol : C.int)
- return C.int
+ Protocol : C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
@@ -416,7 +405,6 @@ package body GNAT.Sockets.Thin is
function Non_Blocking_Socket (S : C.int) return Boolean is
R : Boolean;
-
begin
Task_Lock.Lock;
R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
@@ -433,7 +421,7 @@ package body GNAT.Sockets.Thin is
Address : In_Addr)
is
begin
- Sin.Sin_Addr := Address;
+ Sin.Sin_Addr := Address;
end Set_Address;
----------------
@@ -496,7 +484,9 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
- function Socket_Error_Message (Errno : Integer) return String is
+ function Socket_Error_Message
+ (Errno : Integer) return C.Strings.chars_ptr
+ is
use type Interfaces.C.Strings.chars_ptr;
C_Msg : C.Strings.chars_ptr;
@@ -505,10 +495,10 @@ package body GNAT.Sockets.Thin is
C_Msg := C_Strerror (C.int (Errno));
if C_Msg = C.Strings.Null_Ptr then
- return "Unknown system error";
+ return Unknown_System_Error;
else
- return C.Strings.Value (C_Msg);
+ return C_Msg;
end if;
end Socket_Error_Message;
Index: g-socthi.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socthi.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-socthi.ads
--- g-socthi.ads 21 Oct 2003 13:42:05 -0000 1.4
+++ g-socthi.ads 12 Jan 2004 11:43:58 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -61,7 +61,7 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number.
- function Socket_Error_Message (Errno : Integer) return String;
+ function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
@@ -198,100 +198,85 @@ package GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int;
+ Addrlen : access C.int) return C.int;
function C_Bind
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
function C_Close
- (Fd : C.int)
- return C.int;
+ (Fd : C.int) return C.int;
function C_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
function C_Gethostbyaddr
(Addr : System.Address;
Len : C.int;
- Typ : C.int)
- return Hostent_Access;
+ Typ : C.int) return Hostent_Access;
function C_Gethostbyname
- (Name : C.char_array)
- return Hostent_Access;
+ (Name : C.char_array) return Hostent_Access;
function C_Gethostname
(Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
function C_Getpeername
(S : C.int;
Name : System.Address;
- Namelen : access C.int)
- return C.int;
+ Namelen : access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
- Proto : C.char_array)
- return Servent_Access;
+ Proto : C.char_array) return Servent_Access;
function C_Getservbyport
(Port : C.int;
- Proto : C.char_array)
- return Servent_Access;
+ Proto : C.char_array) return Servent_Access;
function C_Getsockname
(S : C.int;
Name : System.Address;
- Namelen : access C.int)
- return C.int;
+ Namelen : access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
- Optlen : access C.int)
- return C.int;
+ Optlen : access C.int) return C.int;
function C_Inet_Addr
- (Cp : C.Strings.chars_ptr)
- return C.int;
+ (Cp : C.Strings.chars_ptr) return C.int;
function C_Ioctl
(S : C.int;
Req : C.int;
- Arg : Int_Access)
- return C.int;
+ Arg : Int_Access) return C.int;
- function C_Listen (S, Backlog : C.int) return C.int;
+ function C_Listen
+ (S : C.int;
+ Backlog : C.int) return C.int;
function C_Read
(Fd : C.int;
Buf : System.Address;
- Count : C.int)
- return C.int;
+ Count : C.int) return C.int;
function C_Readv
(Fd : C.int;
Iov : System.Address;
- Iovcnt : C.int)
- return C.int;
+ Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
function C_Recvfrom
(S : C.int;
@@ -299,23 +284,20 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int;
+ Fromlen : access C.int) return C.int;
function C_Select
(Nfds : C.int;
Readfds : Fd_Set_Access;
Writefds : Fd_Set_Access;
Exceptfds : Fd_Set_Access;
- Timeout : Timeval_Access)
- return C.int;
+ Timeout : Timeval_Access) return C.int;
function C_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
function C_Sendto
(S : C.int;
@@ -323,47 +305,39 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int;
+ Tolen : C.int) return C.int;
function C_Setsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
- Optlen : C.int)
- return C.int;
+ Optlen : C.int) return C.int;
function C_Shutdown
- (S : C.int;
- How : C.int)
- return C.int;
+ (S : C.int;
+ How : C.int) return C.int;
function C_Socket
(Domain : C.int;
Typ : C.int;
- Protocol : C.int)
- return C.int;
+ Protocol : C.int) return C.int;
function C_Strerror
- (Errnum : C.int)
- return C.Strings.chars_ptr;
+ (Errnum : C.int) return C.Strings.chars_ptr;
function C_System
- (Command : System.Address)
- return C.int;
+ (Command : System.Address) return C.int;
function C_Write
(Fd : C.int;
Buf : System.Address;
- Count : C.int)
- return C.int;
+ Count : C.int) return C.int;
function C_Writev
(Fd : C.int;
Iov : System.Address;
- Iovcnt : C.int)
- return C.int;
+ Iovcnt : C.int) return C.int;
procedure Free_Socket_Set
(Set : Fd_Set_Access);
@@ -386,8 +360,7 @@ package GNAT.Sockets.Thin is
function Is_Socket_In_Set
(Set : Fd_Set_Access;
- Socket : C.int)
- return Boolean;
+ Socket : C.int) return Boolean;
-- Check whether Socket is in the socket set
procedure Last_Socket_In_Set
@@ -400,8 +373,7 @@ package GNAT.Sockets.Thin is
-- set back to the real largest socket in the socket set.
function New_Socket_Set
- (Set : Fd_Set_Access)
- return Fd_Set_Access;
+ (Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure
-- and initialize by copying Set if it is non-null, by making it
-- empty otherwise.
Index: impunit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/impunit.adb,v
retrieving revision 1.9
diff -u -p -r1.9 impunit.adb
--- impunit.adb 30 Oct 2003 11:50:12 -0000 1.9
+++ impunit.adb 12 Jan 2004 11:43:58 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -229,6 +229,7 @@ package body Impunit is
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
"g-semaph", -- GNAT.Semaphores
+ "g-sestin", -- GNAT.Secondary_Stack_Info
"g-signal", -- GNAT.Signals
"g-socket", -- GNAT.Sockets
"g-souinf", -- GNAT.Source_Info
Index: lib-xref.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-xref.adb,v
retrieving revision 1.12
diff -u -p -r1.12 lib-xref.adb
--- lib-xref.adb 5 Jan 2004 15:20:44 -0000 1.12
+++ lib-xref.adb 12 Jan 2004 11:43:58 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -604,9 +604,7 @@ package body Lib.Xref is
exit;
end if;
- -- For a subtype, go to ancestor subtype. If it is a
- -- subtype created for a generic actual, not clear yet
- -- what is the right type to use ???
+ -- For a subtype, go to ancestor subtype.
else
Tref := Ancestor_Subtype (Tref);
@@ -651,6 +649,19 @@ package body Lib.Xref is
if Sloc (Tref) = Standard_Location
or else Comes_From_Source (Tref)
then
+ -- If the reference is a subtype created for a generic
+ -- actual, go to actual directly, the inner subtype is
+ -- not user visible.
+
+ if Nkind (Parent (Tref)) = N_Subtype_Declaration
+ and then not Comes_From_Source (Parent (Tref))
+ and then
+ (Is_Wrapper_Package (Scope (Tref))
+ or else Is_Generic_Instance (Scope (Tref)))
+ then
+ Tref := Base_Type (Tref);
+ end if;
+
return;
end if;
end loop;
Index: link.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/link.c,v
retrieving revision 1.8
diff -u -p -r1.8 link.c
--- link.c 7 Jan 2004 20:58:20 -0000 1.8
+++ link.c 12 Jan 2004 11:43:58 -0000
@@ -157,7 +157,7 @@ const char *object_library_extension = "
#elif defined (__FreeBSD__)
char *object_file_option = "";
char *run_path_option = "";
-char shared_libgnat_default = SHARED;
+char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -p -r1.4 -r1.5
--- Makefile.generic 29 Oct 2003 10:26:14 -0000 1.4
+++ Makefile.generic 12 Jan 2004 11:36:13 -0000 1.5
@@ -1,7 +1,24 @@
# Generic Makefile to support compilation for multiple languages.
# See also Makefile.prolog
#
-# Copyright (C) 2001-2003 ACT-Europe
+# Copyright (C) 2001-2004 Free Software Foundation, Inc.
+
+# This file is part of GCC.
+
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT 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
+# along with GCC; see the file COPYING. If not, write to
+# the Free Software Foundation, 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
# This Makefile provides a very generic framework of the following
# functionalities:
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -p -r1.62 -r1.63
--- Makefile.in 5 Jan 2004 15:20:44 -0000 1.62
+++ Makefile.in 12 Jan 2004 11:36:13 -0000 1.63
@@ -1,5 +1,5 @@
# Makefile for GNU Ada Compiler (GNAT).
-# Copyright (C) 1994-2003 Free Software Foundation, Inc.
+# Copyright (C) 1994-2004 Free Software Foundation, Inc.
#This file is part of GCC.
@@ -1272,6 +1272,8 @@ endif
ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
@@ -2016,7 +2018,7 @@ b_gnatm.o : b_gnatm.c
ADA_INCLUDE_DIR = $(libsubdir)/adainclude
ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
-ADA_SHARE_MAKE_DIR = $(prefix)/share/make
+ADA_SHARE_MAKE_DIR = $(prefix)/share/gnat
# force no sibling call optimization on s-traceb.o so the number of stack
# frames to be skipped when computing a call chain is not modified by
Index: Makefile.prolog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.prolog,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -p -r1.2 -r1.3
--- Makefile.prolog 29 Oct 2003 10:26:14 -0000 1.2
+++ Makefile.prolog 12 Jan 2004 11:36:13 -0000 1.3
@@ -2,7 +2,24 @@
# to support compilation for multiple languages.
# See also Makefile.generic
#
-# Copyright (C) 2001-2002 ACT-Europe
+# Copyright (C) 2001-2004 Free Software Foundation, Inc.
+
+# This file is part of GCC.
+
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT 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
+# along with GCC; see the file COPYING. If not, write to
+# the Free Software Foundation, 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
# all reserved variables are saved in <VAR>.saved
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.66
diff -u -p -r1.66 Make-lang.in
--- Make-lang.in 6 Jan 2004 02:39:27 -0000 1.66
+++ Make-lang.in 12 Jan 2004 11:43:58 -0000
@@ -1391,14 +1391,14 @@ ada/checks.o : ada/ada.ads ada/a-except.
ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads
+ ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/comperr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/comperr.ads ada/comperr.adb \
@@ -1555,14 +1555,14 @@ ada/exp_aggr.o : ada/ada.ads ada/a-excep
ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
@@ -1679,23 +1679,19 @@ ada/exp_ch2.o : ada/ada.ads ada/a-except
ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
- ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
- ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \
- ada/exp_ch3.ads ada/exp_ch3.adb ada/exp_ch4.ads ada/exp_ch7.ads \
- ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_smem.ads \
- ada/exp_strm.ads ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \
- ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/itypes.ads \
- ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads \
- ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \
- ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads \
- ada/sem_intr.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \
+ ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch3.adb \
+ ada/exp_ch4.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \
+ ada/exp_dist.ads ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads \
+ ada/exp_tss.adb ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \
+ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads \
+ ada/sem_res.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
@@ -1749,16 +1745,17 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except
ada/sem_ch13.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \
ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
- ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads
+ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
+ ada/widechar.ads
ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
@@ -1969,13 +1966,13 @@ ada/exp_fixd.o : ada/ada.ads ada/a-excep
ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \
ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
- ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/urealp.adb
+ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/urealp.adb
ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
@@ -2132,14 +2129,14 @@ ada/exp_util.o : ada/ada.ads ada/a-excep
ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \
ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/urealp.adb ada/validsw.ads
+ ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads
ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
@@ -2870,34 +2867,31 @@ ada/sem.o : ada/ada.ads ada/a-except.ads
ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
- ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
- ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads \
- ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \
- ada/expander.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-speche.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
- ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \
- ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
- ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
- ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_aggr.adb \
- ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \
- ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
- ada/sem_elab.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \
- ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
- ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
- ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
- ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
- ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
- ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
- ada/validsw.ads ada/widechar.ads
+ ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
+ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch7.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-speche.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \
+ ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \
+ ada/sem_aggr.adb ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
+ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
+ ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
+ ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads ada/widechar.ads
ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
ada/a-except.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -3010,36 +3004,33 @@ ada/sem_ch11.o : ada/ada.ads ada/a-excep
ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads \
- ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
- ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
- ada/erroutc.ads ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \
- ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
- ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
- ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \
+ ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
+ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \
+ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
+ ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \
+ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
+ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch12.adb \
- ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \
- ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
- ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \
- ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
- ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
- ada/sinfo-cn.ads ada/sinput.ads ada/sinput-l.ads ada/snames.ads \
- ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \
- ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
- ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
- ada/s-htable.adb ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
- ada/widechar.ads
+ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \
+ ada/sem_ch8.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \
+ ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \
+ ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \
+ ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \
+ ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-htable.adb \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads
ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
@@ -3100,17 +3091,17 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except
ada/sem_mech.ads ada/sem_res.ads ada/sem_res.adb ada/sem_smem.ads \
ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
- ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \
- ada/widechar.ads
+ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
+ ada/validsw.ads ada/widechar.ads
ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
@@ -3142,65 +3133,61 @@ ada/sem_ch4.o : ada/ada.ads ada/a-except
ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
- ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
- ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
- ada/eval_fat.ads ada/exp_ch2.ads ada/exp_ch7.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \
- ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
- ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
- ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \
- ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads ada/sem_ch3.ads \
- ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb ada/sem_ch6.ads \
- ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \
- ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \
- ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \
- ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
- ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
- ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads ada/widechar.ads
-
-ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
- ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
- ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
- ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \
+ ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \
+ ada/exp_ch2.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \
ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \
- ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \
- ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
- ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch12.ads \
- ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \
- ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
- ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \
- ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \
- ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \
- ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-carun8.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \
+ ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_case.ads \
+ ada/sem_case.adb ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch5.ads \
+ ada/sem_ch5.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \
+ ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
+ ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads ada/widechar.ads
+ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
+ ada/widechar.ads
+
+ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
+ ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
+ ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch7.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \
+ ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \
+ ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
+ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
+ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
+ ada/scng.adb ada/sem.ads ada/sem_cat.ads ada/sem_ch12.ads \
+ ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \
+ ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \
+ ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \
+ ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
+ ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
+ ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads
ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
Index: par-ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch3.adb,v
retrieving revision 1.9
diff -u -p -r1.9 par-ch3.adb
--- par-ch3.adb 30 Oct 2003 11:50:12 -0000 1.9
+++ par-ch3.adb 12 Jan 2004 11:43:59 -0000
@@ -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- --
@@ -2018,10 +2018,11 @@ package body Ch3 is
-- Error recovery: can raise Error_Resync
function P_Array_Type_Definition return Node_Id is
- Array_Loc : Source_Ptr;
- Def_Node : Node_Id;
- Subs_List : List_Id;
- Scan_State : Saved_Scan_State;
+ Array_Loc : Source_Ptr;
+ CompDef_Node : Node_Id;
+ Def_Node : Node_Id;
+ Subs_List : List_Id;
+ Scan_State : Saved_Scan_State;
begin
Array_Loc := Token_Ptr;
@@ -2079,12 +2080,16 @@ package body Ch3 is
T_Right_Paren;
T_Of;
+ CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
+
if Token = Tok_Aliased then
- Set_Aliased_Present (Def_Node, True);
+ Set_Aliased_Present (CompDef_Node, True);
Scan; -- past ALIASED
end if;
- Set_Subtype_Indication (Def_Node, P_Subtype_Indication);
+ Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication);
+ Set_Component_Definition (Def_Node, CompDef_Node);
+
return Def_Node;
end P_Array_Type_Definition;
@@ -2728,11 +2733,12 @@ package body Ch3 is
-- items, do we need to add this capability sometime in the future ???
procedure P_Component_Items (Decls : List_Id) is
- Decl_Node : Node_Id;
- Scan_State : Saved_Scan_State;
- Num_Idents : Nat;
- Ident : Nat;
- Ident_Sloc : Source_Ptr;
+ CompDef_Node : Node_Id;
+ Decl_Node : Node_Id;
+ Scan_State : Saved_Scan_State;
+ Num_Idents : Nat;
+ Ident : Nat;
+ Ident_Sloc : Source_Ptr;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- This array holds the list of defining identifiers. The upper bound
@@ -2783,13 +2789,15 @@ package body Ch3 is
Scan;
end if;
+ 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_Aliased then
Scan; -- past ALIASED
- Set_Aliased_Present (Decl_Node, True);
+ Set_Aliased_Present (CompDef_Node, True);
end if;
if Token = Tok_Array then
@@ -2797,8 +2805,9 @@ package body Ch3 is
raise Error_Resync;
end if;
- Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
- Set_Expression (Decl_Node, Init_Expr_Opt);
+ Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication);
+ Set_Component_Definition (Decl_Node, CompDef_Node);
+ Set_Expression (Decl_Node, Init_Expr_Opt);
if Ident > 1 then
Set_Prev_Ids (Decl_Node, True);
Index: sem.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem.adb,v
retrieving revision 1.6
diff -u -p -r1.6 sem.adb
--- sem.adb 21 Oct 2003 13:42:18 -0000 1.6
+++ sem.adb 12 Jan 2004 11:43:59 -0000
@@ -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- --
@@ -574,6 +574,7 @@ package body Sem is
N_Compilation_Unit_Aux |
N_Component_Association |
N_Component_Clause |
+ N_Component_Definition |
N_Component_List |
N_Constrained_Array_Definition |
N_Decimal_Fixed_Point_Definition |
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -p -r1.30 -r1.31
--- sem_ch12.adb 5 Jan 2004 15:20:45 -0000 1.30
+++ sem_ch12.adb 12 Jan 2004 11:38:15 -0000 1.31
@@ -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- --
@@ -1214,12 +1214,13 @@ package body Sem_Ch12 is
Error_Msg_N ("premature usage of incomplete type", Def);
elsif Is_Internal (Component_Type (T))
- and then Nkind (Original_Node (Subtype_Indication (Def)))
+ and then Nkind (Original_Node
+ (Subtype_Indication (Component_Definition (Def))))
/= N_Attribute_Reference
then
Error_Msg_N
("only a subtype mark is allowed in a formal",
- Subtype_Indication (Def));
+ Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
@@ -1604,6 +1605,27 @@ package body Sem_Ch12 is
Gen_Id);
Restore_Env;
return;
+
+ elsif In_Open_Scopes (Gen_Unit) then
+ if Is_Compilation_Unit (Gen_Unit)
+ and then Is_Child_Unit (Current_Scope)
+ then
+ -- Special-case the error when the formal is a parent, and
+ -- continue analysis to minimize cascaded errors.
+
+ Error_Msg_N
+ ("generic parent cannot be used as formal package "
+ & "of a child unit",
+ Gen_Id);
+
+ else
+ Error_Msg_N
+ ("generic package cannot be used as a formal package "
+ & "within itself",
+ Gen_Id);
+ Restore_Env;
+ return;
+ end if;
end if;
-- Check for a formal package that is a package renaming.
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.27
diff -u -p -r1.27 sem_ch3.adb
--- sem_ch3.adb 17 Dec 2003 13:37:03 -0000 1.27
+++ sem_ch3.adb 12 Jan 2004 11:44:02 -0000
@@ -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- --
@@ -906,7 +906,8 @@ package body Sem_Ch3 is
begin
Generate_Definition (Id);
Enter_Name (Id);
- T := Find_Type_Of_Object (Subtype_Indication (N), N);
+ T := Find_Type_Of_Object (Subtype_Indication (Component_Definition (N)),
+ N);
-- If the subtype is a constrained subtype of the enclosing record,
-- (which must have a partial view) the back-end does not handle
@@ -916,15 +917,16 @@ package body Sem_Ch3 is
-- removed from discriminant constraints.
if Ekind (T) = E_Access_Subtype
- and then Is_Entity_Name (Subtype_Indication (N))
+ and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
and then Comes_From_Source (T)
and then Nkind (Parent (T)) = N_Subtype_Declaration
and then Etype (Directly_Designated_Type (T)) = Current_Scope
then
Rewrite
- (Subtype_Indication (N),
+ (Subtype_Indication (Component_Definition (N)),
New_Copy_Tree (Subtype_Indication (Parent (T))));
- T := Find_Type_Of_Object (Subtype_Indication (N), N);
+ T := Find_Type_Of_Object
+ (Subtype_Indication (Component_Definition (N)), N);
end if;
-- If the component declaration includes a default expression, then we
@@ -944,7 +946,7 @@ package body Sem_Ch3 is
if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
Error_Msg_N
("unconstrained subtype in component declaration",
- Subtype_Indication (N));
+ Subtype_Indication (Component_Definition (N)));
-- Components cannot be abstract, except for the special case of
-- the _Parent field (case of extending an abstract tagged type)
@@ -954,9 +956,9 @@ package body Sem_Ch3 is
end if;
Set_Etype (Id, T);
- Set_Is_Aliased (Id, Aliased_Present (N));
+ Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
- -- If the this component is private (or depends on a private type),
+ -- If this component is private (or depends on a private type),
-- flag the record type to indicate that some operations are not
-- available.
@@ -2727,7 +2729,7 @@ package body Sem_Ch3 is
----------------------------
procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
- Component_Def : constant Node_Id := Subtype_Indication (Def);
+ Component_Def : constant Node_Id := Component_Definition (Def);
Element_Type : Entity_Id;
Implicit_Base : Entity_Id;
Index : Node_Id;
@@ -2764,7 +2766,8 @@ package body Sem_Ch3 is
Nb_Index := Nb_Index + 1;
end loop;
- Element_Type := Process_Subtype (Component_Def, P, Related_Id, 'C');
+ Element_Type := Process_Subtype (Subtype_Indication (Component_Def),
+ P, Related_Id, 'C');
-- Constrained array case
@@ -2830,7 +2833,7 @@ package body Sem_Ch3 is
Set_Component_Type (Base_Type (T), Element_Type);
- if Aliased_Present (Def) then
+ if Aliased_Present (Component_Definition (Def)) then
Set_Has_Aliased_Components (Etype (T));
end if;
@@ -2874,12 +2877,13 @@ package body Sem_Ch3 is
if Is_Indefinite_Subtype (Element_Type) then
Error_Msg_N
- ("unconstrained element type in array declaration ",
- Component_Def);
+ ("unconstrained element type in array declaration",
+ Subtype_Indication (Component_Def));
elsif Is_Abstract (Element_Type) then
- Error_Msg_N ("The type of a component cannot be abstract ",
- Component_Def);
+ Error_Msg_N
+ ("The type of a component cannot be abstract",
+ Subtype_Indication (Component_Def));
end if;
end Array_Type_Declaration;
@@ -2900,15 +2904,15 @@ package body Sem_Ch3 is
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
-- an access to a self-referential type, e.g. a standard list
-- type with a next pointer. Will be reset after subtype is built.
- Set_Directly_Designated_Type (Derived_Type,
- Designated_Type (Parent_Type));
+ Set_Directly_Designated_Type
+ (Derived_Type, Designated_Type (Parent_Type));
Subt := Process_Subtype (S, N);
@@ -5592,10 +5596,10 @@ package body Sem_Ch3 is
if Discrim_Present then
null;
- elsif Nkind (Parent (Def)) = N_Component_Declaration
+ elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
and then
Has_Per_Object_Constraint
- (Defining_Identifier (Parent (Def)))
+ (Defining_Identifier (Parent (Parent (Def))))
then
null;
@@ -9525,11 +9529,18 @@ package body Sem_Ch3 is
Related_Nod : Node_Id) return Entity_Id
is
Def_Kind : constant Node_Kind := Nkind (Obj_Def);
- P : constant Node_Id := Parent (Obj_Def);
+ P : Node_Id := Parent (Obj_Def);
T : Entity_Id;
Nam : Name_Id;
begin
+ -- If the parent is a component_definition node we climb to the
+ -- component_declaration node
+
+ if Nkind (P) = N_Component_Definition then
+ P := Parent (P);
+ end if;
+
-- Case of an anonymous array subtype
if Def_Kind = N_Constrained_Array_Definition
Index: sem_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch7.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_ch7.adb
--- sem_ch7.adb 5 Jan 2004 15:20:46 -0000 1.10
+++ sem_ch7.adb 12 Jan 2004 11:44:03 -0000
@@ -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- --
@@ -1651,6 +1651,17 @@ package body Sem_Ch7 is
-- Local entities are not immediately visible outside of the package.
Set_Is_Immediately_Visible (Id, False);
+
+ -- If this is a private type with a full view (for example a local
+ -- subtype of a private type declared elsewhere), ensure that the
+ -- full view is also removed from visibility: it may be exposed when
+ -- swapping views in an instantiation.
+
+ if Is_Type (Id)
+ and then Present (Full_View (Id))
+ then
+ Set_Is_Immediately_Visible (Full_View (Id), False);
+ end if;
if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
Check_Abstract_Overriding (Id);
Index: sem_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_dist.adb,v
retrieving revision 1.6
diff -u -p -r1.6 sem_dist.adb
--- sem_dist.adb 21 Oct 2003 13:42:20 -0000 1.6
+++ sem_dist.adb 12 Jan 2004 11:44:03 -0000
@@ -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- --
@@ -427,44 +427,55 @@ package body Sem_Dist is
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Name_Ras),
- Subtype_Indication =>
- New_Occurrence_Of
- (RTE (RE_Unsigned_64), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Name_Origin),
- Subtype_Indication =>
- New_Reference_To
- (Standard_Integer,
- Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To
+ (Standard_Integer, Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Name_Receiver),
- Subtype_Indication =>
- New_Reference_To
- (RTE (RE_Unsigned_64), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To
+ (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Name_Subp_Id),
- Subtype_Indication =>
- New_Reference_To
- (Standard_Natural,
- Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To
+ (Standard_Natural, Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Name_Async),
- Subtype_Indication =>
- New_Reference_To
- (Standard_Boolean,
- Loc))))));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To
+ (Standard_Boolean, Loc)))))));
Insert_After (N, New_Type_Decl);
Set_Equivalent_Type (User_Type, Fat_Type);
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_prag.adb
--- sem_prag.adb 5 Jan 2004 15:20:46 -0000 1.16
+++ sem_prag.adb 12 Jan 2004 11:44:04 -0000
@@ -9375,7 +9375,7 @@ package body Sem_Prag is
declare
Sindic : constant Node_Id :=
- Subtype_Indication (Comp);
+ Subtype_Indication (Component_Definition (Comp));
begin
if Nkind (Sindic) = N_Subtype_Indication then
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_res.adb
--- sem_res.adb 5 Jan 2004 15:20:46 -0000 1.17
+++ sem_res.adb 12 Jan 2004 11:44:05 -0000
@@ -382,7 +382,7 @@ package body Sem_Res is
if Nkind (P) = N_Range_Constraint
and then Nkind (Parent (P)) = N_Subtype_Indication
- and then Nkind (Parent (Parent (P))) = N_Component_Declaration
+ and then Nkind (Parent (Parent (P))) = N_Component_Definition
then
Error_Msg_N ("discriminant cannot constrain scalar type", N);
@@ -409,7 +409,7 @@ package body Sem_Res is
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
and then
- (Nkind (Parent (Parent (P))) = N_Component_Declaration
+ (Nkind (Parent (Parent (P))) = N_Component_Definition
or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
@@ -559,7 +559,7 @@ package body Sem_Res is
if (Nkind (P) = N_Subtype_Indication
and then
- (Nkind (Parent (P)) = N_Component_Declaration
+ (Nkind (Parent (P)) = N_Component_Definition
or else
Nkind (Parent (P)) = N_Derived_Type_Definition)
and then D = Constraint (P))
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.18
diff -u -p -r1.18 sem_util.adb
--- sem_util.adb 5 Jan 2004 15:20:46 -0000 1.18
+++ sem_util.adb 12 Jan 2004 11:44:06 -0000
@@ -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- --
@@ -3219,8 +3219,9 @@ package body Sem_Util is
------------------------------
function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
- Comp_Decl : constant Node_Id := Parent (Comp);
- Subt_Indic : constant Node_Id := Subtype_Indication (Comp_Decl);
+ Comp_Decl : constant Node_Id := Parent (Comp);
+ Subt_Indic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp_Decl));
Constr : Node_Id;
Assn : Node_Id;
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sinfo.adb
--- sinfo.adb 24 Nov 2003 14:27:57 -0000 1.11
+++ sinfo.adb 12 Jan 2004 11:44:06 -0000
@@ -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- --
@@ -170,10 +170,8 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Constrained_Array_Definition
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ or else NT (N).Nkind = N_Component_Definition
+ or else NT (N).Nkind = N_Object_Declaration);
return Flag4 (N);
end Aliased_Present;
@@ -376,6 +374,16 @@ package body Sinfo is
return List3 (N);
end Component_Clauses;
+ function Component_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ return Node4 (N);
+ end Component_Definition;
+
function Component_Items
(N : Node_Id) return List_Id is
begin
@@ -2293,12 +2301,10 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Component_Definition
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ or else NT (N).Nkind = N_Subtype_Declaration);
return Node5 (N);
end Subtype_Indication;
@@ -2612,10 +2618,8 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Constrained_Array_Definition
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ or else NT (N).Nkind = N_Component_Definition
+ or else NT (N).Nkind = N_Object_Declaration);
Set_Flag4 (N, Val);
end Set_Aliased_Present;
@@ -2818,6 +2822,16 @@ package body Sinfo is
Set_List3_With_Parent (N, Val);
end Set_Component_Clauses;
+ procedure Set_Component_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Component_Definition;
+
procedure Set_Component_Items
(N : Node_Id; Val : List_Id) is
begin
@@ -4725,12 +4739,10 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Component_Definition
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ or else NT (N).Nkind = N_Subtype_Declaration);
Set_Node5_With_Parent (N, Val);
end Set_Subtype_Indication;
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.17
diff -u -p -r1.17 sinfo.ads
--- sinfo.ads 11 Dec 2003 16:21:39 -0000 1.17
+++ sinfo.ads 12 Jan 2004 11:44:08 -0000
@@ -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- --
@@ -2275,8 +2275,7 @@ package Sinfo is
-- N_Unconstrained_Array_Definition
-- Sloc points to ARRAY
-- Subtype_Marks (List2)
- -- Aliased_Present (Flag4) from component definition
- -- Subtype_Indication (Node5) from component definition
+ -- Component_Definition (Node4)
-----------------------------------
-- 3.6 Index Subtype Definition --
@@ -2304,8 +2303,7 @@ package Sinfo is
-- N_Constrained_Array_Definition
-- Sloc points to ARRAY
-- Discrete_Subtype_Definitions (List2)
- -- Aliased_Present (Flag4) from component definition
- -- Subtype_Indication (Node5) from component definition
+ -- Component_Definition (Node4)
--------------------------------------
-- 3.6 Discrete Subtype Definition --
@@ -2320,16 +2318,17 @@ package Sinfo is
-- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
- -- There is no explicit node in the tree for a component definition.
- -- Instead the subtype indication appears directly, and the ALIASED
- -- indication (Aliased_Present flag) is in the parent node.
-
-- 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.
+ -- N_Component_Definition
+ -- Sloc points to ALIASED or to first token of subtype mark
+ -- Aliased_Present (Flag4)
+ -- Subtype_Indication (Node5)
+
-----------------------------
-- 3.6.1 Index Constraint --
-----------------------------
@@ -2537,8 +2536,7 @@ package Sinfo is
-- N_Component_Declaration
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
- -- Aliased_Present (Flag4) from component definition
- -- Subtype_Indication (Node5) from component definition
+ -- Component_Definition (Node4)
-- Expression (Node3) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
@@ -6651,6 +6649,7 @@ package Sinfo is
N_Compilation_Unit,
N_Compilation_Unit_Aux,
N_Component_Association,
+ N_Component_Definition,
N_Component_List,
N_Derived_Type_Definition,
N_Decimal_Fixed_Point_Definition,
@@ -6968,6 +6967,9 @@ package Sinfo is
function Component_Clauses
(N : Node_Id) return List_Id; -- List3
+ function Component_Definition
+ (N : Node_Id) return Node_Id; -- Node4
+
function Component_Items
(N : Node_Id) return List_Id; -- List3
@@ -7748,6 +7750,9 @@ package Sinfo is
procedure Set_Component_Clauses
(N : Node_Id; Val : List_Id); -- List3
+ procedure Set_Component_Definition
+ (N : Node_Id; Val : Node_Id); -- Node4
+
procedure Set_Component_Items
(N : Node_Id; Val : List_Id); -- List3
@@ -8471,6 +8476,7 @@ package Sinfo is
pragma Inline (Compile_Time_Known_Aggregate);
pragma Inline (Component_Associations);
pragma Inline (Component_Clauses);
+ pragma Inline (Component_Definition);
pragma Inline (Component_Items);
pragma Inline (Component_List);
pragma Inline (Component_Name);
@@ -8728,6 +8734,7 @@ package Sinfo is
pragma Inline (Set_Compile_Time_Known_Aggregate);
pragma Inline (Set_Component_Associations);
pragma Inline (Set_Component_Clauses);
+ pragma Inline (Set_Component_Definition);
pragma Inline (Set_Component_Items);
pragma Inline (Set_Component_List);
pragma Inline (Set_Component_Name);
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sprint.adb
--- sprint.adb 5 Jan 2004 15:20:46 -0000 1.13
+++ sprint.adb 12 Jan 2004 11:44:08 -0000
@@ -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- --
@@ -949,15 +949,17 @@ package body Sprint is
Sprint_Node (Last_Bit (Node));
Write_Char (';');
+ when N_Component_Definition =>
+ Set_Debug_Sloc;
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
+ end if;
+ Sprint_Node (Subtype_Indication (Node));
+
when N_Component_Declaration =>
if Write_Indent_Identifiers_Sloc (Node) then
Write_Str (" : ");
-
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
-
- Sprint_Node (Subtype_Indication (Node));
+ Sprint_Node (Component_Definition (Node));
if Present (Expression (Node)) then
Write_Str (" := ");
@@ -1010,11 +1012,7 @@ package body Sprint is
Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
Write_Str (" of ");
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
-
- Sprint_Node (Subtype_Indication (Node));
+ Sprint_Node (Component_Definition (Node));
when N_Decimal_Fixed_Point_Definition =>
Write_Str_With_Col_Check_Sloc (" delta ");
@@ -2439,12 +2437,7 @@ package body Sprint is
end;
Write_Str (") of ");
-
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
-
- Sprint_Node (Subtype_Indication (Node));
+ Sprint_Node (Component_Definition (Node));
when N_Unused_At_Start | N_Unused_At_End =>
Write_Indent_Str ("***** Error, unused node encountered *****");
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.41
diff -u -p -r1.41 trans.c
--- trans.c 5 Jan 2004 15:20:47 -0000 1.41
+++ trans.c 12 Jan 2004 11:44:09 -0000
@@ -2805,9 +2805,8 @@ tree_transform (Node_Id gnat_node)
case N_Expanded_Name:
case N_Attribute_Reference:
if (Is_Eliminated (Entity (Name (gnat_node))))
- post_error_ne ("cannot call eliminated subprogram &!",
- gnat_node, Entity (Name (gnat_node)));
- }
+ Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
+ }
if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
gigi_abort (317);
Index: usage.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/usage.adb,v
retrieving revision 1.12
diff -u -p -r1.12 usage.adb
--- usage.adb 20 Nov 2003 09:54:03 -0000 1.12
+++ usage.adb 12 Jan 2004 11:44:09 -0000
@@ -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- --
@@ -339,7 +339,7 @@ begin
Write_Switch_Char ("wxx");
Write_Line ("Enable selected warning modes, xx = list of parameters:");
- Write_Line (" a turn on all optional warnings (except b,d,h,l)");
+ Write_Line (" a turn on all optional warnings (except d,h,l)");
Write_Line (" A turn off all optional warnings");
Write_Line (" c turn on warnings for constant conditional");
Write_Line (" C* turn off warnings for constant conditional");
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2004-01-05 15:24 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2004-01-05 15:24 UTC (permalink / raw)
To: gcc-patches
Happy New Year to all of you.
Some AdaCore people have been busy during the christmas/new year period
(I have not, been enjoying the warmth of the morocco desert instead!)
Tested on x86-linux
Arno
--
2004-01-05 Robert Dewar <dewar@gnat.com>
* 1ssecsta.ads: Default_Secondary_Stack is not a constant since it may
be modified by the binder generated main program if the -D switch is
used.
* 4onumaux.ads, 4znumaux.ads: Add Pure_Function pragmas for all
imported functions (since now we expect this to be done for imported
functions)
* 5vtaprop.adb: Add several ??? for sections requiring more comments
Minor reformatting throughout
* 5zinit.adb: Minor reformatting
Add 2004 to copyright date
Minor changes to avoid -gnatwa warnings
Correct some instances of using OR instead of OR ELSE (noted while
doing reformatting)
* sprint.adb: Minor updates to avoid -gnatwa warnings
* s-secsta.ads, s-secsta.adb:
(SS_Get_Max): New function to obtain high water mark for ss stack
Default_Secondary_Stack is not a constant since it may be modified by
the binder generated main program if the -D switch is used.
* switch-b.adb: New -Dnnn switch for binder
* switch-c.adb:
Make -gnatg imply all warnings currently in -gnatwa
* vms_conv.adb: Minor reformatting
Add 2004 to copyright notice
Add 2004 to printed copyright notice
* 3vexpect.adb, 4zsytaco.adb, 3wsocthi.adb, 3zsocthi.adb,
3zsocthi.adb, 56taprop.adb, 56tpopsp.adb, 5amastop.adb,
5aml-tgt.adb, 5ataprop.adb, 5ataprop.adb, 5atpopsp.adb,
5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gml-tgt.adb,
5gtaprop.adb, 5hml-tgt.adb, 5hml-tgt.adb, 5hml-tgt.adb,
5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5lml-tgt.adb,
5sml-tgt.adb, 5staprop.adb, 5staprop.adb, 5stpopsp.adb,
5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vtaprop.adb,
5vml-tgt.adb, 5vtaprop.adb, 5wosprim.adb, 5wtaprop.adb,
5zinterr.adb, 5zintman.adb, 5zml-tgt.adb, 5ztaprop.adb,
6vcpp.adb, 6vcstrea.adb, 7staprop.adb, 7stpopsp.adb,
vxaddr2line.adb, vxaddr2line.adb, xref_lib.adb, xr_tabls.adb,
xr_tabls.ads, s-tasdeb.adb, s-tasdeb.adb, sem_res.ads,
sem_util.adb, sem_util.adb, sem_util.ads, s-interr.adb,
checks.adb, clean.adb, cstand.adb, einfo.ads,
einfo.adb, exp_aggr.adb, exp_ch11.adb, exp_ch3.adb,
exp_ch4.adb, exp_ch5.adb, exp_ch7.adb, exp_ch9.adb,
prj-nmsc.adb, prj-pp.adb, prj-util.adb, sem_attr.adb,
sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, g-dirope.adb,
g-dirope.ads, gnatlbr.adb, i-cstrea.adb, inline.adb,
lib-xref.adb, sem_ch5.adb, sem_ch7.adb, sem_ch8.adb:
Minor reformatting and code clean ups.
Minor changes to prevent -gnatwa warnings
* ali.adb: Minor reformatting and cleanup of code
Acquire new SS indication of secondary stack use from ali files
* a-numaux.ads: Add Pure_Function pragmas for all imported functions
(since now we expect this to be done for imported functions)
* bindgen.adb: Generate call to modify default secondary stack size if
-Dnnn switch given
* bindusg.adb: Add line for new -D switch
* exp_aggr.adb (Type_May_Have_Bit_Aligned_Components): More appropriate
replacement name for Type_May_Have_Non_Bit_Aligned_Components!
Add circuitry for both records and arrays to avoid gigi
processing if the type involved has non-bit-aligned components
* exp_ch5.adb (Expand_Assign_Array): Avoid assumption that
N_String_Literal node always references an E_String_Literal_Subtype
entity. This may not be true in the future.
(Possible_Bit_Aligned_Component): Move processing of
Component_May_Be_Bit_Aligned from exp_ch5 to exp_util
* exp_ch6.adb (Expand_Thread_Body): Pick up
Default_Secondary_Stack_Size as variable so that we get value modified
by possible -Dnnn binder parameter.
* exp_util.adb (Component_May_Be_Bit_Aligned): New function.
(Type_May_Have_Bit_Aligned_Components): New function.
* exp_util.ads (Component_May_Be_Bit_Aligned): New function.
(Type_May_Have_Bit_Aligned_Components): New function.
* fe.h: (Set_Identifier_Casing): Fix prototype.
Add declaration for Sem_Elim.Eliminate_Error_Msg.
Minor reformatting.
* freeze.adb (Freeze_Entity): Add RM reference to error message about
importing constant atomic/volatile objects.
(Freeze_Subprogram): Reset Is_Pure indication for imported subprogram
unless explicit Pure_Function pragma given, to avoid insidious bug of
call to non-pure imported function getting eliminated.
* gnat1drv.adb, gnatbind.adb, gnatchop.adb, gnatfind.adb,
gnatls.adb, gnatlink.adb, gnatmem.adb, gnatname.adb, gnatsym.adb,
gnatxref.adb, gprcmd.adb, gprep.adb, make.adb: Minor reformatting
Add 2004 to printed copyright notice
* lib-writ.ads, lib-writ.adb: Put new SS flag in ali file if secondary
stack used.
* Makefile.rtl: Add entry for g-sestin.o
g-sestin.ads: New file.
* mdll.adb: Minor changes to avoid -gnatwa warnings
* mlib-tgt.adb: Minor reformatting
* opt.ads: New parameter Default_Secondary_Stack_Size (GNATBIND)
New switch Sec_Stack_Used (GNAT, GNATBIND)
Make Default_Secondary_Stack_Size a variable instead of a constant,
so that it can be modified by the new -Dnnn bind switch.
* rtsfind.adb (Load_Fail): Give full error message in configurable
run-time mode if all_errors mode is set. This was not done in the case
of a file not found, which was an oversight.
Note if secondary stack unit is used by compiler.
* sem_elab.adb (Check_A_Call): Rewrite to avoid trying to put
ineffective elaborate all pragmas on non-visible packages (this
happened when a renamed subprogram was called). Now the elaborate all
always goes on the package containing the renaming rather than the one
containing the renamed subprogram.
* sem_elim.ads, sem_elim.adb (Eliminate_Error_Msg): New procedure
(Process_Eliminate_Pragma): Add parameter to capture pragma location.
* sem_eval.adb (Eval_String_Literal): Do not assume that string literal
has an Etype that references an E_String_Literal.
(Eval_String_Literal): Avoid assumption that N_String_Literal node
always references an E_String_Literal_Subtype entity. This may not
be true in the future.
* sem_prag.adb (Process_Eliminate_Pragma): Add parameter to capture
pragma location.
* sem_res.adb (Resolve): Specialize msg for function name used in proc
call.
2004-01-05 Ed Falis <falis@gnat.com>
* g-debuti.adb: Replaced direct boolean operator with short-circuit
form.
2004-01-05 Vincent Celier <celier@gnat.com>
* bld.adb: Minor comment updates
(Process_Declarative_Items): Correct incorrect name (Index_Name instead
of Item_Name).
* make.adb (Gnatmake): Special process for files to compile/check when
-B is specified. Fail when there are only foreign mains in attribute
Main of the project file and -B is not specified. Do not skip bind/link
steps when -B is specified.
* makeusg.adb: Document new switch -B
* opt.ads (Build_Bind_And_Link_Full_Project): New Boolean flag
* switch-m.adb: (Scan_Make_Switches): Process -B switch
* vms_data.ads: Add new GNAT PRETTY qualifier
/FORM_FEED_AFTER_PRAGMA_PAGE for switch -ff
2004-01-05 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform, case N_Free_Statement): Handle thin pointer
case.
* misc.c (gnat_printable_name): If VERBOSITY is 2, call
Set_Identifier_Casing.
* decl.c (gnat_to_gnu_entity, E_Function): Give error if return type
has size that overflows.
2004-01-05 Gary Dismukes <dismukes@gnat.com>
* exp_ch4.adb (Expand_Array_Comparison): Add Boolean constant to avoid
-gnatwa warning on static condition.
2004-01-05 Doug Rupp <rupp@gnat.com>
* link.c: (shared_libgnat_default) [VMS]: Change to STATIC.
2004-01-05 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.in: Install ali files using INSTALL_DATA_DATE to preserve
all attributes, including read-only attribute.
2004-01-05 Pascal Obry <obry@gnat.com>
* bindgen.adb (Gen_Object_Files_Options): Generate the new shared
library naming scheme.
* mlib-prj.adb (Build_Library): Generate different names for the static
or dynamic version of the GNAT runtime. This is needed to support the
new shared library naming scheme.
(Process_Binder_File): Add detection of shared library in binder file
based on the new naming scheme.
* gnatlink.adb (Process_Binder_File): Properly detect the new naming
scheme for the shared runtime libraries.
* Makefile.in:
(LIBRARY_VERSION) [VMS]: Convert all . to _ to conform to new naming
scheme.
(install-gnatlib): Do not create symlinks for shared libraries.
(gnatlib-shared-default): Idem.
(gnatlib-shared-dual-win32): New target. Not used for now as the
auto-import feature does not support arrays/records.
(gnatlib-shared-win32): Do not create copy for the shared libraries.
(gnatlib-shared-vms): Fix shared runtime libraries names.
* osint.ads, osint.adb (Shared_Lib): New routine, returns the target
dependent runtime shared library name.
2004-01-05 Vasiliy Fofanov <fofanov@act-europe.fr>
* osint.adb (Read_Library_Info): Remove bogus check if ALI is older
than the object.
2004-01-05 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Analyze_Allocator): Check restriction on dynamic
protected objects when allocator has a subtype indication, not a
qualified expression. Note that qualified expressions may have to be
checked when limited aggregates are implemented.
* sem_prag.adb (Analyze_Pragma, case Import): If enclosing package is
pure, emit warning.
(Analyze_Pragma, case Pure_Function): If enclosing package is pure and
subprogram is imported, remove warning.
2004-01-05 Geert Bosch <bosch@gnat.com>
* s-poosiz.adb: Update copyright notice.
(Allocate): Use Task_Lock to protect against concurrent access.
(Deallocate): Likewise.
2004-01-05 Joel Brobecker <brobecker@gnat.com>
* s-stalib.adb (Elab_Final_Code): Add missing year in date inside ???
comment.
--
Index: 1ssecsta.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/1ssecsta.ads,v
retrieving revision 1.4
diff -u -p -r1.4 1ssecsta.ads
--- 1ssecsta.ads 24 Apr 2003 17:53:50 -0000 1.4
+++ 1ssecsta.ads 5 Jan 2004 13:15:36 -0000
@@ -39,8 +39,8 @@ package System.Secondary_Stack is
package SSE renames System.Storage_Elements;
- Default_Secondary_Stack_Size : constant := 10 * 1024;
- -- Default size of a secondary stack
+ Default_Secondary_Stack_Size : Natural := 10 * 1024;
+ -- Default size of a secondary stack. May be modified by binder -D switch
procedure SS_Init
(Stk : System.Address;
Index: 3vexpect.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vexpect.adb,v
retrieving revision 1.1
diff -u -p -r1.1 3vexpect.adb
--- 3vexpect.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 3vexpect.adb 5 Jan 2004 13:15:36 -0000
@@ -102,8 +102,7 @@ package body GNAT.Expect is
(Fds : System.Address;
Num_Fds : Integer;
Timeout : Integer;
- Is_Set : System.Address)
- return Integer;
+ Is_Set : System.Address) return Integer;
pragma Import (C, Poll, "__gnat_expect_poll");
-- Check whether there is any data waiting on the file descriptor
-- Out_fd, and wait if there is none, at most Timeout milliseconds
@@ -130,8 +129,7 @@ package body GNAT.Expect is
---------
function "+"
- (P : GNAT.Regpat.Pattern_Matcher)
- return Pattern_Matcher_Access
+ (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
is
begin
return new GNAT.Regpat.Pattern_Matcher'(P);
@@ -768,8 +766,7 @@ package body GNAT.Expect is
------------------
function Get_Error_Fd
- (Descriptor : Process_Descriptor)
- return GNAT.OS_Lib.File_Descriptor
+ (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
is
begin
return Descriptor.Error_Fd;
@@ -780,8 +777,7 @@ package body GNAT.Expect is
------------------
function Get_Input_Fd
- (Descriptor : Process_Descriptor)
- return GNAT.OS_Lib.File_Descriptor
+ (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
is
begin
return Descriptor.Input_Fd;
@@ -792,8 +788,7 @@ package body GNAT.Expect is
-------------------
function Get_Output_Fd
- (Descriptor : Process_Descriptor)
- return GNAT.OS_Lib.File_Descriptor
+ (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
is
begin
return Descriptor.Output_Fd;
@@ -804,8 +799,7 @@ package body GNAT.Expect is
-------------
function Get_Pid
- (Descriptor : Process_Descriptor)
- return Process_Id
+ (Descriptor : Process_Descriptor) return Process_Id
is
begin
return Descriptor.Pid;
@@ -848,8 +842,8 @@ package body GNAT.Expect is
function Get_Vfork_Jmpbuf return System.Address;
pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
- function Get_Current_Invo_Context (Addr : System.Address)
- return Process_Id;
+ function Get_Current_Invo_Context
+ (Addr : System.Address) return Process_Id;
pragma Import (C, Get_Current_Invo_Context,
"LIB$GET_CURRENT_INVO_CONTEXT");
@@ -1003,21 +997,23 @@ package body GNAT.Expect is
----------
procedure Send
- (Descriptor : in out Process_Descriptor;
- Str : String;
- Add_LF : Boolean := True;
+ (Descriptor : in out Process_Descriptor;
+ Str : String;
+ Add_LF : Boolean := True;
Empty_Buffer : Boolean := False)
is
- N : Natural;
Full_Str : constant String := Str & ASCII.LF;
Last : Natural;
Result : Expect_Match;
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+ Discard : Natural;
+ pragma Unreferenced (Discard);
+
begin
if Empty_Buffer then
- -- Force a read on the process if there is anything waiting.
+ -- Force a read on the process if there is anything waiting
Expect_Internal (Descriptors, Result,
Timeout => 0, Full_Buffer => False);
@@ -1036,9 +1032,10 @@ package body GNAT.Expect is
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
- N := Write (Descriptor.Input_Fd,
- Full_Str'Address,
- Last - Full_Str'First + 1);
+ Discard := Write (Descriptor.Input_Fd,
+ Full_Str'Address,
+ Last - Full_Str'First + 1);
+ -- Shouldn't we at least have a pragma Assert on the result ???
end Send;
-----------------
Index: 3wsocthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3wsocthi.adb,v
retrieving revision 1.4
diff -u -p -r1.4 3wsocthi.adb
--- 3wsocthi.adb 21 Oct 2003 13:41:51 -0000 1.4
+++ 3wsocthi.adb 5 Jan 2004 13:15:36 -0000
@@ -143,8 +143,8 @@ package body GNAT.Sockets.Thin is
is
pragma Warnings (Off, Exceptfds);
- RFS : Fd_Set_Access := Readfds;
- WFS : Fd_Set_Access := Writefds;
+ RFS : constant Fd_Set_Access := Readfds;
+ WFS : constant Fd_Set_Access := Writefds;
WFSC : Fd_Set_Access := No_Fd_Set;
EFS : Fd_Set_Access := Exceptfds;
Res : C.int;
@@ -190,10 +190,10 @@ package body GNAT.Sockets.Thin is
if EFS /= No_Fd_Set then
declare
- EFSC : Fd_Set_Access := New_Socket_Set (EFS);
+ EFSC : constant Fd_Set_Access := New_Socket_Set (EFS);
+ Flag : constant C.int := MSG_PEEK + MSG_OOB;
Buffer : Character;
Length : C.int;
- Flag : C.int := MSG_PEEK + MSG_OOB;
Fromlen : aliased C.int;
begin
Index: 3zsocthi.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3zsocthi.adb,v
retrieving revision 1.1
diff -u -p -r1.1 3zsocthi.adb
--- 3zsocthi.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 3zsocthi.adb 5 Jan 2004 13:15:36 -0000
@@ -45,7 +45,8 @@ with Unchecked_Conversion;
package body GNAT.Sockets.Thin is
- Non_Blocking_Sockets : Fd_Set_Access := New_Socket_Set (No_Socket_Set);
+ Non_Blocking_Sockets : constant Fd_Set_Access :=
+ New_Socket_Set (No_Socket_Set);
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
@@ -59,6 +60,7 @@ package body GNAT.Sockets.Thin is
-- When Thread_Blocking_IO is False, we set sockets in
-- non-blocking mode and we spend a period of time Quantum between
-- two attempts on a blocking operation.
+
Thread_Blocking_IO : Boolean := True;
-- The following types and variables are required to create a Hostent
@@ -66,17 +68,17 @@ package body GNAT.Sockets.Thin is
type In_Addr_Access_Array_Access is access In_Addr_Access_Array;
- Alias_Access : Chars_Ptr_Pointers.Pointer :=
+ Alias_Access : constant Chars_Ptr_Pointers.Pointer :=
new C.Strings.chars_ptr'(C.Strings.Null_Ptr);
- In_Addr_Access_Array_A : In_Addr_Access_Array_Access :=
+ In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access :=
new In_Addr_Access_Array'(new In_Addr, null);
- In_Addr_Access_Ptr : In_Addr_Access_Pointers.Pointer :=
+ In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer :=
In_Addr_Access_Array_A
(In_Addr_Access_Array_A'First)'Access;
- Local_Hostent : Hostent_Access := new Hostent;
+ Local_Hostent : constant Hostent_Access := new Hostent;
-----------------------
-- Local Subprograms --
@@ -87,30 +89,26 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int;
+ Addrlen : access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int;
+ Namelen : C.int) return C.int;
pragma Import (C, Syscall_Connect, "connect");
function Syscall_Ioctl
(S : C.int;
Req : C.int;
- Arg : Int_Access)
- return C.int;
+ Arg : Int_Access) return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
@@ -119,16 +117,14 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int;
+ Fromlen : access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int;
+ Flags : C.int) return C.int;
pragma Import (C, Syscall_Send, "send");
function Syscall_Sendto
@@ -137,15 +133,13 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int;
+ Tolen : C.int) return C.int;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
(Domain : C.int;
Typ : C.int;
- Protocol : C.int)
- return C.int;
+ Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
function Non_Blocking_Socket (S : C.int) return Boolean;
@@ -158,12 +152,13 @@ package body GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
- Addrlen : access C.int)
- return C.int
+ Addrlen : access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
+
Res : C.int;
+ pragma Unreferenced (Res);
begin
loop
@@ -184,6 +179,7 @@ package body GNAT.Sockets.Thin is
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ -- Is it OK to ignore result ???
end if;
return R;
@@ -196,8 +192,7 @@ package body GNAT.Sockets.Thin is
function C_Connect
(S : C.int;
Name : System.Address;
- Namelen : C.int)
- return C.int
+ Namelen : C.int) return C.int
is
Res : C.int;
@@ -260,8 +255,7 @@ package body GNAT.Sockets.Thin is
function C_Gethostbyaddr
(Addr : System.Address;
Len : C.int;
- Typ : C.int)
- return Hostent_Access
+ Typ : C.int) return Hostent_Access
is
pragma Warnings (Off, Len);
pragma Warnings (Off, Typ);
@@ -290,12 +284,10 @@ package body GNAT.Sockets.Thin is
---------------------
function C_Gethostbyname
- (Name : C.char_array)
- return Hostent_Access
+ (Name : C.char_array) return Hostent_Access
is
function VxWorks_Gethostbyname
- (Name : C.char_array)
- return C.int;
+ (Name : C.char_array) return C.int;
pragma Import (C, VxWorks_Gethostbyname, "hostGetByName");
Addr : C.int;
@@ -315,8 +307,7 @@ package body GNAT.Sockets.Thin is
function C_Getservbyname
(Name : C.char_array;
- Proto : C.char_array)
- return Servent_Access
+ Proto : C.char_array) return Servent_Access
is
pragma Warnings (Off, Name);
pragma Warnings (Off, Proto);
@@ -331,8 +322,7 @@ package body GNAT.Sockets.Thin is
function C_Getservbyport
(Port : C.int;
- Proto : C.char_array)
- return Servent_Access
+ Proto : C.char_array) return Servent_Access
is
pragma Warnings (Off, Port);
pragma Warnings (Off, Proto);
@@ -348,8 +338,7 @@ package body GNAT.Sockets.Thin is
function C_Ioctl
(S : C.int;
Req : C.int;
- Arg : Int_Access)
- return C.int
+ Arg : Int_Access) return C.int
is
begin
if not Thread_Blocking_IO
@@ -371,8 +360,7 @@ package body GNAT.Sockets.Thin is
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int
+ Flags : C.int) return C.int
is
Res : C.int;
@@ -399,8 +387,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
- Fromlen : access C.int)
- return C.int
+ Fromlen : access C.int) return C.int
is
Res : C.int;
@@ -425,8 +412,7 @@ package body GNAT.Sockets.Thin is
(S : C.int;
Msg : System.Address;
Len : C.int;
- Flags : C.int)
- return C.int
+ Flags : C.int) return C.int
is
Res : C.int;
@@ -453,8 +439,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
- Tolen : C.int)
- return C.int
+ Tolen : C.int) return C.int
is
Res : C.int;
@@ -478,12 +463,13 @@ package body GNAT.Sockets.Thin is
function C_Socket
(Domain : C.int;
Typ : C.int;
- Protocol : C.int)
- return C.int
+ Protocol : C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
+
Res : C.int;
+ pragma Unreferenced (Res);
begin
R := Syscall_Socket (Domain, Typ, Protocol);
@@ -495,6 +481,7 @@ package body GNAT.Sockets.Thin is
-- in non-blocking mode by user.
Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ -- Is it OK to ignore result ???
Set_Non_Blocking_Socket (R, False);
end if;
@@ -611,7 +598,6 @@ package body GNAT.Sockets.Thin is
if C_Msg = C.Strings.Null_Ptr then
return "Unknown system error";
-
else
return C.Strings.Value (C_Msg);
end if;
Index: 4onumaux.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/4onumaux.ads,v
retrieving revision 1.5
diff -u -p -r1.5 4onumaux.ads
--- 4onumaux.ads 21 Oct 2003 13:41:51 -0000 1.5
+++ 4onumaux.ads 5 Jan 2004 13:15:36 -0000
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version for x86) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -50,43 +50,59 @@ pragma Pure (Aux);
type Double is digits 18;
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure!
+
function Sin (X : Double) return Double;
pragma Import (C, Sin, "sinl");
+ pragma Pure_Function (Sin);
function Cos (X : Double) return Double;
pragma Import (C, Cos, "cosl");
+ pragma Pure_Function (Cos);
function Tan (X : Double) return Double;
pragma Import (C, Tan, "tanl");
+ pragma Pure_Function (Tan);
function Exp (X : Double) return Double;
pragma Import (C, Exp, "expl");
+ pragma Pure_Function (Exp);
function Sqrt (X : Double) return Double;
pragma Import (C, Sqrt, "sqrtl");
+ pragma Pure_Function (Sqrt);
function Log (X : Double) return Double;
pragma Import (C, Log, "logl");
+ pragma Pure_Function (Log);
function Acos (X : Double) return Double;
pragma Import (C, Acos, "acosl");
+ pragma Pure_Function (Acos);
function Asin (X : Double) return Double;
pragma Import (C, Asin, "asinl");
+ pragma Pure_Function (Asin);
function Atan (X : Double) return Double;
pragma Import (C, Atan, "atanl");
+ pragma Pure_Function (Atan);
function Sinh (X : Double) return Double;
pragma Import (C, Sinh, "sinhl");
+ pragma Pure_Function (Sinh);
function Cosh (X : Double) return Double;
pragma Import (C, Cosh, "coshl");
+ pragma Pure_Function (Cosh);
function Tanh (X : Double) return Double;
pragma Import (C, Tanh, "tanhl");
+ pragma Pure_Function (Tanh);
function Pow (X, Y : Double) return Double;
pragma Import (C, Pow, "powl");
+ pragma Pure_Function (Pow);
end Ada.Numerics.Aux;
Index: 4znumaux.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/4znumaux.ads,v
retrieving revision 1.4
diff -u -p -r1.4 4znumaux.ads
--- 4znumaux.ads 24 Apr 2003 17:53:51 -0000 1.4
+++ 4znumaux.ads 5 Jan 2004 13:15:36 -0000
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version, VxWorks) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -50,48 +50,61 @@ pragma Pure (Aux);
-- no libm.a library for VxWorks.
type Double is digits 15;
- pragma Float_Representation (IEEE_Float, Double);
- -- Type Double is the type used to call the C routines. Note that this
- -- is IEEE format even when running on VMS with Vax_Float representation
- -- since we use the IEEE version of the C library with VMS.
+ -- Type Double is the type used to call the C routines
+
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure!
function Sin (X : Double) return Double;
pragma Import (C, Sin, "sin");
+ pragma Pure_Function (Sin);
function Cos (X : Double) return Double;
pragma Import (C, Cos, "cos");
+ pragma Pure_Function (Cos);
function Tan (X : Double) return Double;
pragma Import (C, Tan, "tan");
+ pragma Pure_Function (Tan);
function Exp (X : Double) return Double;
pragma Import (C, Exp, "exp");
+ pragma Pure_Function (Exp);
function Sqrt (X : Double) return Double;
pragma Import (C, Sqrt, "sqrt");
+ pragma Pure_Function (Sqrt);
function Log (X : Double) return Double;
pragma Import (C, Log, "log");
+ pragma Pure_Function (Log);
function Acos (X : Double) return Double;
pragma Import (C, Acos, "acos");
+ pragma Pure_Function (Acos);
function Asin (X : Double) return Double;
pragma Import (C, Asin, "asin");
+ pragma Pure_Function (Asin);
function Atan (X : Double) return Double;
pragma Import (C, Atan, "atan");
+ pragma Pure_Function (Atan);
function Sinh (X : Double) return Double;
pragma Import (C, Sinh, "sinh");
+ pragma Pure_Function (Sinh);
function Cosh (X : Double) return Double;
pragma Import (C, Cosh, "cosh");
+ pragma Pure_Function (Cosh);
function Tanh (X : Double) return Double;
pragma Import (C, Tanh, "tanh");
+ pragma Pure_Function (Tanh);
function Pow (X, Y : Double) return Double;
pragma Import (C, Pow, "pow");
+ pragma Pure_Function (Pow);
end Ada.Numerics.Aux;
Index: 4zsytaco.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/4zsytaco.adb,v
retrieving revision 1.4
diff -u -p -r1.4 4zsytaco.adb
--- 4zsytaco.adb 24 Apr 2003 17:53:51 -0000 1.4
+++ 4zsytaco.adb 5 Jan 2004 13:15:36 -0000
@@ -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- --
@@ -52,8 +52,9 @@ package body Ada.Synchronous_Task_Contro
St := semTake (S.Sema, NO_WAIT);
+ -- If we took the semaphore, reset semaphore state to FULL
+
if St = OK then
- -- Took the semaphore. Reset semaphore state to FULL
Result := True;
St := semGive (S.Sema);
end if;
@@ -74,6 +75,7 @@ package body Ada.Synchronous_Task_Contro
-- empty (St = OK) or have left it empty.
St := semTake (S.Sema, NO_WAIT);
+ pragma Assert (St = OK);
end Set_False;
--------------
@@ -82,7 +84,7 @@ package body Ada.Synchronous_Task_Contro
procedure Set_True (S : in out Suspension_Object) is
St : STATUS;
-
+ pragma Unreferenced (St);
begin
St := semGive (S.Sema);
end Set_True;
@@ -136,7 +138,7 @@ package body Ada.Synchronous_Task_Contro
procedure Finalize (S : in out Suspension_Object) is
St : STATUS;
-
+ pragma Unreferenced (St);
begin
St := semDelete (S.Sema);
St := semDelete (S.Mutex);
Index: 56taprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/56taprop.adb,v
retrieving revision 1.1
diff -u -p -r1.1 56taprop.adb
--- 56taprop.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 56taprop.adb 5 Jan 2004 13:15:36 -0000
@@ -332,7 +332,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L.Mutex'Access);
pragma Assert (Result = 0);
@@ -340,7 +339,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -382,7 +380,6 @@ package body System.Task_Primitives.Oper
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -429,7 +426,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -439,7 +435,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -456,7 +451,6 @@ package body System.Task_Primitives.Oper
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
begin
@@ -468,7 +462,7 @@ package body System.Task_Primitives.Oper
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
- -- EINTR is not considered a failure.
+ -- EINTR is not considered a failure
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
@@ -654,7 +648,6 @@ package body System.Task_Primitives.Oper
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := clock_gettime
(clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
@@ -669,7 +662,6 @@ package body System.Task_Primitives.Oper
function RT_Resolution return Duration is
Res : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := clock_getres
(clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access);
@@ -683,9 +675,7 @@ package body System.Task_Primitives.Oper
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -697,7 +687,7 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
@@ -923,6 +913,7 @@ package body System.Task_Primitives.Oper
end if;
if Stack_Base_Available then
+
-- If Stack Checking is supported then allocate 2 additional pages:
--
-- In the worst case, stack is allocated at something like
@@ -1028,7 +1019,6 @@ package body System.Task_Primitives.Oper
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result := pthread_kill (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
@@ -1095,7 +1085,6 @@ package body System.Task_Primitives.Oper
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Suspend_Task;
@@ -1106,12 +1095,10 @@ package body System.Task_Primitives.Oper
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Resume_Task;
Index: 56tpopsp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/56tpopsp.adb,v
retrieving revision 1.1
diff -u -p -r1.1 56tpopsp.adb
--- 56tpopsp.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 56tpopsp.adb 5 Jan 2004 13:15:36 -0000
@@ -92,11 +92,14 @@ package body Specific is
-- tasks.
function Self return Task_ID is
- Result : Interfaces.C.int;
Value : aliased System.Address;
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+
begin
Result := st_getspecific (ATCB_Key, Value'Address);
+ -- Is it OK not to check this result???
-- If the key value is Null, then it is a non-Ada task.
Index: 5amastop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5amastop.adb,v
retrieving revision 1.4
diff -u -p -r1.4 5amastop.adb
--- 5amastop.adb 24 Apr 2003 17:53:51 -0000 1.4
+++ 5amastop.adb 5 Jan 2004 13:15:36 -0000
@@ -7,7 +7,7 @@
-- B o d y --
-- (Version for Alpha/Dec Unix) --
-- --
--- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 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- --
@@ -105,7 +105,8 @@ package body System.Machine_State_Operat
-- asm instruction takes 4 bytes. So we must remove this value from
-- c_get_code_loc to have the call point.
- Loc : Code_Loc := c_get_code_loc (M);
+ Loc : constant Code_Loc := c_get_code_loc (M);
+
begin
if Loc = 0 then
return 0;
Index: 5aml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5aml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5aml-tgt.adb
--- 5aml-tgt.adb 20 Nov 2003 09:53:57 -0000 1.2
+++ 5aml-tgt.adb 5 Jan 2004 13:15:36 -0000
@@ -189,7 +189,9 @@ package body MLib.Tgt is
Success : Boolean;
Oldpath : String (1 .. Lib_Version'Length + 1);
Newpath : String (1 .. Lib_File'Length + 1);
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
function Symlink
(Oldpath : System.Address;
Index: 5ataprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ataprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5ataprop.adb
--- 5ataprop.adb 21 Oct 2003 13:41:51 -0000 1.7
+++ 5ataprop.adb 5 Jan 2004 13:15:37 -0000
@@ -626,9 +626,7 @@ package body System.Task_Primitives.Oper
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -640,6 +638,7 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
@@ -972,7 +971,6 @@ package body System.Task_Primitives.Oper
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result :=
pthread_kill
@@ -1038,8 +1036,7 @@ package body System.Task_Primitives.Oper
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
pragma Warnings (Off, Thread_Self);
@@ -1054,8 +1051,7 @@ package body System.Task_Primitives.Oper
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
pragma Warnings (Off, Thread_Self);
@@ -1074,12 +1070,11 @@ package body System.Task_Primitives.Oper
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
+ -- Get interrupt state. Defined in a-init.c. The input argument is
+ -- the interrupt number, and the result is one of the following:
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
Index: 5atpopsp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5atpopsp.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5atpopsp.adb
--- 5atpopsp.adb 21 Oct 2003 13:41:51 -0000 1.7
+++ 5atpopsp.adb 5 Jan 2004 13:15:37 -0000
@@ -68,7 +68,6 @@ package body Specific is
procedure Set (Self_Id : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
pragma Assert (Result = 0);
Index: 5ftaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ftaprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5ftaprop.adb
--- 5ftaprop.adb 21 Oct 2003 13:41:51 -0000 1.7
+++ 5ftaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
--- This is a IRIX (pthread library) version of this package.
+-- This is a IRIX (pthread library) version of this package
-- This package contains all the GNULL primitives that interface directly
-- with the underlying OS.
@@ -222,7 +222,6 @@ package body System.Task_Primitives.Oper
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (On);
pragma Unreferenced (T);
-
begin
null;
end Stack_Guard;
@@ -332,7 +331,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -340,7 +338,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -356,13 +353,14 @@ package body System.Task_Primitives.Oper
Result := pthread_mutex_lock (L);
Ceiling_Violation := Result = EINVAL;
- -- assumes the cause of EINVAL is a priority ceiling violation
+ -- Assumes the cause of EINVAL is a priority ceiling violation
pragma Assert (Result = 0 or else Result = EINVAL);
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
@@ -396,7 +394,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
@@ -584,7 +581,6 @@ package body System.Task_Primitives.Oper
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
pragma Assert (Result = 0);
@@ -614,9 +610,7 @@ package body System.Task_Primitives.Oper
procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -628,7 +622,7 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
@@ -1069,9 +1063,8 @@ package body System.Task_Primitives.Oper
function State (Int : System.Interrupt_Management.Interrupt_ID)
return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
+ -- Get interrupt state. Defined in a-init.c. The input argument is
+ -- the interrupt number, and the result is one of the following:
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
Index: 5ginterr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ginterr.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5ginterr.adb
--- 5ginterr.adb 21 Oct 2003 13:41:51 -0000 1.6
+++ 5ginterr.adb 5 Jan 2004 13:15:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Free Software Fundation --
+-- Copyright (C) 1998-2003 Free Software Fundation --
-- --
-- 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- --
@@ -244,11 +244,9 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
+ (Object : access Dynamic_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -279,11 +277,9 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
+ (Object : access Static_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -320,8 +316,9 @@ package body System.Interrupts is
-- Current_Handler --
---------------------
- function Current_Handler (Interrupt : Interrupt_ID)
- return Parameterless_Handler is
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
begin
if Is_Reserved (Interrupt) then
raise Program_Error;
@@ -466,13 +463,15 @@ package body System.Interrupts is
---------------
function Reference (Interrupt : Interrupt_ID) return System.Address is
- Signal : System.Address :=
- System.Storage_Elements.To_Address
- (System.Storage_Elements.Integer_Address (Interrupt));
+ Signal : constant System.Address :=
+ System.Storage_Elements.To_Address
+ (System.Storage_Elements.Integer_Address (Interrupt));
begin
if Is_Reserved (Interrupt) then
- -- Only usable Interrupts can be used for binding it to an Entry.
+
+ -- Only usable Interrupts can be used for binding it to an Entry
+
raise Program_Error;
end if;
Index: 5gmastop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gmastop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5gmastop.adb
--- 5gmastop.adb 21 Oct 2003 13:41:51 -0000 1.7
+++ 5gmastop.adb 5 Jan 2004 13:15:37 -0000
@@ -108,18 +108,20 @@ package body System.Machine_State_Operat
-- ABI-Dependent Declarations --
--------------------------------
- o32 : constant Natural := Boolean'Pos (System.Word_Size = 32);
- n32 : constant Natural := Boolean'Pos (System.Word_Size = 64);
+ o32 : constant Boolean := System.Word_Size = 32;
+ n32 : constant Boolean := System.Word_Size = 64;
+ o32n : constant Natural := Boolean'Pos (o32);
+ n32n : constant Natural := Boolean'Pos (n32);
-- Flags to indicate which ABI is in effect for this compilation. For the
-- purposes of this unit, the n32 and n64 ABI's are identical.
- LSC : constant Character := Character'Val (o32 * Character'Pos ('w') +
- n32 * Character'Pos ('d'));
+ LSC : constant Character := Character'Val (o32n * Character'Pos ('w') +
+ n32n * Character'Pos ('d'));
-- This is 'w' for o32, and 'd' for n32/n64, used for constructing the
-- load/store instructions used to save/restore machine instructions.
- Roff : constant Character := Character'Val (o32 * Character'Pos ('4') +
- n32 * Character'Pos (' '));
+ Roff : constant Character := Character'Val (o32n * Character'Pos ('4') +
+ n32n * Character'Pos (' '));
-- Offset from first byte of a __uint64 register save location where
-- the register value is stored. For n32/64 we store the entire 64
-- bit register into the uint64. For o32, only 32 bits are stored
@@ -156,7 +158,7 @@ package body System.Machine_State_Operat
function To_I_Type_Ptr is new
Unchecked_Conversion (Address_Int, I_Type_Ptr);
- Ret_Ins : I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC));
+ Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC));
GP_Ptr : Uns32_Ptr;
begin
@@ -311,12 +313,11 @@ package body System.Machine_State_Operat
Scp.SC_PC := 0;
else
-
-- Set the GP to restore to the caller value (not callee value)
-- This is done only in o32 mode. In n32/n64 mode, GP is a normal
-- callee save register
- if o32 = 1 then
+ if o32 then
Update_GP (Scp);
end if;
Index: 5gml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5gml-tgt.adb
--- 5gml-tgt.adb 20 Nov 2003 09:53:57 -0000 1.2
+++ 5gml-tgt.adb 5 Jan 2004 13:15:37 -0000
@@ -172,7 +172,9 @@ package body MLib.Tgt is
Success : Boolean;
Oldpath : String (1 .. Lib_Version'Length + 1);
Newpath : String (1 .. Lib_File'Length + 1);
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
function Symlink
(Oldpath : System.Address;
Index: 5gtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gtaprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5gtaprop.adb
--- 5gtaprop.adb 21 Oct 2003 13:41:51 -0000 1.7
+++ 5gtaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -534,7 +534,6 @@ package body System.Task_Primitives.Oper
Reason : System.Tasking.Task_States)
is
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -878,8 +877,7 @@ package body System.Task_Primitives.Oper
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= Thread_Self then
@@ -895,8 +893,7 @@ package body System.Task_Primitives.Oper
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= Thread_Self then
Index: 5hml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5hml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5hml-tgt.adb
--- 5hml-tgt.adb 20 Nov 2003 09:53:57 -0000 1.2
+++ 5hml-tgt.adb 5 Jan 2004 13:15:37 -0000
@@ -125,7 +125,8 @@ package body MLib.Tgt is
Init_Fini : Argument_List_Access := Empty_Argument_List;
- Common_Options : Argument_List := Options & new String'(PIC_Option);
+ Common_Options : constant Argument_List :=
+ Options & new String'(PIC_Option);
-- Common set of options to the gcc command performing the link.
-- On HPUX, this command eventually resorts to collect2, which may
-- generate a C file and compile it on the fly. This compilation shall
@@ -177,12 +178,13 @@ package body MLib.Tgt is
Success : Boolean;
Oldpath : String (1 .. Lib_Version'Length + 1);
Newpath : String (1 .. Lib_File'Length + 1);
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
function Symlink
(Oldpath : System.Address;
- Newpath : System.Address)
- return Integer;
+ Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
begin
Index: 5htaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5htaprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5htaprop.adb
--- 5htaprop.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5htaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -600,7 +600,7 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
Index: 5htraceb.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5htraceb.adb,v
retrieving revision 1.5
diff -u -p -r1.5 5htraceb.adb
--- 5htraceb.adb 21 Oct 2003 13:41:52 -0000 1.5
+++ 5htraceb.adb 5 Jan 2004 13:15:37 -0000
@@ -221,8 +221,7 @@ package body System.Traceback is
(Pc : Address;
Space : Address;
Table_Start : Address;
- Table_End : Address)
- return Address;
+ Table_End : Address) return Address;
pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
-- Given the bounds of an unwind table, return the address of the
-- unwind descriptor associated with a code location/space. In the case
@@ -254,8 +253,7 @@ package body System.Traceback is
function U_get_previous_frame_x
(current_frame : access CFD;
previous_frame : access PFD;
- previous_size : Integer)
- return Integer;
+ previous_size : Integer) return Integer;
pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
-- Fetch the data describing the "previous" frame relatively to the
-- "current" one. "previous_size" should be the size of the "previous"
@@ -270,9 +268,8 @@ package body System.Traceback is
------------------
function C_Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural)
- return Natural
+ (Traceback : System.Address;
+ Max_Len : Natural) return Natural
is
Val : Natural;
@@ -530,10 +527,12 @@ package body System.Traceback is
and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
then
declare
- Shlib_UWT : UWT := U_get_shLib_unwind_table (Frame.cur_r19);
- Shlib_Start : Address := U_get_shLib_text_addr (Frame.cur_r19);
- Rlo_Offset : Address := Frame.cur_rlo - Shlib_Start;
-
+ Shlib_UWT : constant UWT :=
+ U_get_shLib_unwind_table (Frame.cur_r19);
+ Shlib_Start : constant Address :=
+ U_get_shLib_text_addr (Frame.cur_r19);
+ Rlo_Offset : constant Address :=
+ Frame.cur_rlo - Shlib_Start;
begin
UWD_Address := U_get_unwind_entry (Rlo_Offset,
Frame.cur_rls,
Index: 5itaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5itaprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5itaprop.adb
--- 5itaprop.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5itaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -656,9 +656,7 @@ package body System.Task_Primitives.Oper
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -671,7 +669,6 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
pragma Unreferenced (Result);
-
begin
if Do_Yield then
Result := sched_yield;
@@ -988,8 +985,7 @@ package body System.Task_Primitives.Oper
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= Thread_Self then
@@ -1005,8 +1001,7 @@ package body System.Task_Primitives.Oper
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= Thread_Self then
Index: 5lml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5lml-tgt.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5lml-tgt.adb
--- 5lml-tgt.adb 20 Nov 2003 09:53:57 -0000 1.6
+++ 5lml-tgt.adb 5 Jan 2004 13:15:37 -0000
@@ -175,12 +175,13 @@ package body MLib.Tgt is
Success : Boolean;
Oldpath : String (1 .. Lib_Version'Length + 1);
Newpath : String (1 .. Lib_File'Length + 1);
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
function Symlink
(Oldpath : System.Address;
- Newpath : System.Address)
- return Integer;
+ Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
begin
Index: 5sml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5sml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5sml-tgt.adb
--- 5sml-tgt.adb 20 Nov 2003 09:53:58 -0000 1.2
+++ 5sml-tgt.adb 5 Jan 2004 13:15:37 -0000
@@ -171,7 +171,9 @@ package body MLib.Tgt is
Success : Boolean;
Oldpath : String (1 .. Lib_Version'Length + 1);
Newpath : String (1 .. Lib_File'Length + 1);
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
function Symlink
(Oldpath : System.Address;
Index: 5staprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5staprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5staprop.adb
--- 5staprop.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5staprop.adb 5 Jan 2004 13:15:37 -0000
@@ -275,14 +275,11 @@ package body System.Task_Primitives.Oper
------------
Check_Count : Integer := 0;
- Old_Owner : Task_ID;
Lock_Count : Integer := 0;
Unlock_Count : Integer := 0;
function To_Lock_Ptr is
new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
- function To_Task_ID is
- new Unchecked_Conversion (Owner_ID, Task_ID);
function To_Owner_ID is
new Unchecked_Conversion (Task_ID, Owner_ID);
@@ -300,9 +297,11 @@ package body System.Task_Primitives.Oper
pragma Unreferenced (Context);
Self_ID : Task_ID := Self;
- Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+
begin
-- It is not safe to raise an exception when using ZCX and the GCC
-- exception handling mechanism.
@@ -758,7 +757,9 @@ package body System.Task_Primitives.Oper
is
pragma Unreferenced (Loss_Of_Inheritance);
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+
Param : aliased struct_pcparms;
use Task_Info;
@@ -1605,7 +1606,6 @@ package body System.Task_Primitives.Oper
if Unlock_Count - Check_Count > 1000 then
Check_Count := Unlock_Count;
- Old_Owner := To_Task_ID (Single_RTS_Lock.Owner);
end if;
-- Check that caller is abort-deferred
Index: 5stpopsp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5stpopsp.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5stpopsp.adb
--- 5stpopsp.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5stpopsp.adb 5 Jan 2004 13:15:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, 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- --
@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
--- This is a version for Solaris native threads.
+-- This is a version for Solaris native threads
separate (System.Task_Primitives.Operations)
package body Specific is
@@ -54,11 +54,9 @@ package body Specific is
function Is_Valid_Task return Boolean is
Unknown_Task : aliased System.Address;
Result : Interfaces.C.int;
-
begin
Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
pragma Assert (Result = 0);
-
return Unknown_Task /= System.Null_Address;
end Is_Valid_Task;
Index: 5vasthan.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vasthan.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5vasthan.adb
--- 5vasthan.adb 21 Oct 2003 13:41:52 -0000 1.6
+++ 5vasthan.adb 5 Jan 2004 13:15:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -320,6 +320,7 @@ package body System.AST_Handling is
procedure Allocate_New_AST_Server is
Dummy : AST_Server_Task_Ptr;
+ pragma Unreferenced (Dummy);
begin
if Num_AST_Servers = Max_AST_Servers then
@@ -454,8 +455,7 @@ package body System.AST_Handling is
function Create_AST_Handler
(Taskid : ATID.Task_Id;
- Entryno : Natural)
- return System.Aux_DEC.AST_Handler
+ Entryno : Natural) return System.Aux_DEC.AST_Handler
is
Attr_Ref : Attribute_Handle;
@@ -465,7 +465,7 @@ package body System.AST_Handling is
function To_Descriptor_Ref is new Ada.Unchecked_Conversion
(AST_Handler, Descriptor_Ref);
- Original_Descriptor_Ref : Descriptor_Ref :=
+ Original_Descriptor_Ref : constant Descriptor_Ref :=
To_Descriptor_Ref (Process_AST_Ptr);
begin
Index: 5vinmaop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vinmaop.adb,v
retrieving revision 1.5
diff -u -p -r1.5 5vinmaop.adb
--- 5vinmaop.adb 21 Oct 2003 13:41:52 -0000 1.5
+++ 5vinmaop.adb 5 Jan 2004 13:15:37 -0000
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 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- --
@@ -119,7 +119,7 @@ package body System.Interrupt_Management
function Interrupt_Wait (Mask : access Interrupt_Mask)
return Interrupt_ID
is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
Iosb : IO_Status_Block_Type := (0, 0, 0);
Status : Cond_Value_Type;
Index: 5vinterr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vinterr.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5vinterr.adb
--- 5vinterr.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5vinterr.adb 5 Jan 2004 13:15:37 -0000
@@ -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- --
@@ -219,17 +219,18 @@ package body System.Interrupts is
pragma Volatile_Components (User_Entry);
-- Holds the task and entry index (if any) for each interrupt
- Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
- pragma Volatile_Components (Blocked);
+ Blocked : constant array (Interrupt_ID'Range) of Boolean :=
+ (others => False);
+-- ??? pragma Volatile_Components (Blocked);
-- True iff the corresponding interrupt is blocked in the process level
Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
pragma Volatile_Components (Ignored);
-- True iff the corresponding interrupt is blocked in the process level
- Last_Unblocker :
- array (Interrupt_ID'Range) of Task_ID := (others => Null_Task);
- pragma Volatile_Components (Last_Unblocker);
+ Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID :=
+ (others => Null_Task);
+-- ??? pragma Volatile_Components (Last_Unblocker);
-- Holds the ID of the last Task which Unblocked this Interrupt.
-- It contains Null_Task if no tasks have ever requested the
-- Unblocking operation or the Interrupt is currently Blocked.
@@ -324,7 +325,7 @@ package body System.Interrupts is
Ptr := Registered_Handler_Head;
- while (Ptr /= null) loop
+ while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
@@ -726,8 +727,6 @@ package body System.Interrupts is
(Interrupt : Interrupt_ID;
Static : Boolean)
is
- Old_Handler : Parameterless_Handler;
-
begin
if User_Entry (Interrupt).T /= Null_Task then
-- In case we have an Interrupt Entry installed.
@@ -754,8 +753,6 @@ package body System.Interrupts is
Ignored (Interrupt) := False;
- Old_Handler := User_Handler (Interrupt).H;
-
-- The new handler
User_Handler (Interrupt).H := null;
@@ -959,7 +956,6 @@ package body System.Interrupts is
Tmp_ID : Task_ID;
Tmp_Entry_Index : Task_Entry_Index;
Intwait_Mask : aliased IMNG.Interrupt_Mask;
- Ret_Interrupt : IMNG.Interrupt_ID;
begin
-- By making this task independent of master, when the process
@@ -1016,7 +1012,6 @@ package body System.Interrupts is
else
Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
- Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access);
Self_ID.Common.State := Runnable;
if not (Self_ID.Deferral_Level = 0
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5vml-tgt.adb
--- 5vml-tgt.adb 20 Nov 2003 09:53:58 -0000 1.2
+++ 5vml-tgt.adb 5 Jan 2004 13:15:37 -0000
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003, Ada Core Technologies, Inc. --
+-- Copyright (C) 2003-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- --
@@ -25,10 +25,7 @@
-- --
------------------------------------------------------------------------------
--- This package provides a set of target dependent routines to build
--- static, dynamic and shared libraries.
-
--- This is the VMS version of the body.
+-- This is the VMS version of the body
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;
@@ -142,8 +139,6 @@ package body MLib.Tgt is
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
-
-
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
@@ -152,7 +147,8 @@ package body MLib.Tgt is
Last_Opt : Natural := Opts'Last;
Opts2 : Argument_List (Options'Range);
Last_Opt2 : Natural := Opts2'First - 1;
- Inter : Argument_List := Interfaces;
+
+ Inter : constant Argument_List := Interfaces;
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
@@ -172,9 +168,10 @@ package body MLib.Tgt is
function Is_Interface (Obj_File : String) return Boolean is
ALI : constant String :=
- Fil.Ext_To
- (Filename => To_Lower (Base_Name (Obj_File)),
- New_Ext => "ali");
+ Fil.Ext_To
+ (Filename => To_Lower (Base_Name (Obj_File)),
+ New_Ext => "ali");
+
begin
if Inter'Length = 0 then
return True;
@@ -203,7 +200,6 @@ package body MLib.Tgt is
begin
if Symbol_Data.Symbol_File = No_Name then
return "symvec.opt";
-
else
return Get_Name_String (Symbol_Data.Symbol_File);
end if;
@@ -239,9 +235,11 @@ package body MLib.Tgt is
end Version_String;
Opt_File_Name : constant String := Option_File_Name;
+ Version : constant String := Version_String;
For_Linker_Opt : constant String_Access :=
new String'("--for-linker=" & Opt_File_Name);
- Version : constant String := Version_String;
+
+ -- Start of processing for Build_Dynamic_Library
begin
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
@@ -423,6 +421,7 @@ package body MLib.Tgt is
declare
Index : Natural := Opts'First;
Opt : String_Access;
+
begin
while Index <= Last_Opt loop
Opt := Opts (Index);
Index: 5vtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vtaprop.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5vtaprop.adb
--- 5vtaprop.adb 21 Oct 2003 13:41:52 -0000 1.6
+++ 5vtaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -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- --
@@ -127,11 +127,11 @@ package body System.Task_Primitives.Oper
procedure Set (Self_Id : Task_ID);
pragma Inline (Set);
- -- Set the self id for the current task.
+ -- Set the self id for the current task
function Self return Task_ID;
pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task.
+ -- Return a pointer to the Ada Task Control Block of the calling task
end Specific;
@@ -143,7 +143,7 @@ package body System.Task_Primitives.Oper
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
- -- Allocate and Initialize a new ATCB for the current Thread.
+ -- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
@@ -160,17 +160,17 @@ package body System.Task_Primitives.Oper
-- Signal the condition variable when AST fires.
procedure Timer_Sleep_AST (ID : Address) is
- Result : Interfaces.C.int;
- Self_ID : Task_ID := To_Task_ID (ID);
-
+ Result : Interfaces.C.int;
+ Self_ID : Task_ID := To_Task_ID (ID);
begin
Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
end Timer_Sleep_AST;
- -------------------
- -- Stack_Guard --
- -------------------
+ -----------------
+ -- Stack_Guard --
+ -----------------
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
@@ -179,7 +179,6 @@ package body System.Task_Primitives.Oper
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
@@ -281,7 +280,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L.L'Access);
pragma Assert (Result = 0);
@@ -289,7 +287,6 @@ package body System.Task_Primitives.Oper
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -308,7 +305,7 @@ package body System.Task_Primitives.Oper
begin
Current_Prio := Get_Priority (Self_ID);
- -- If there is no other tasks, no need to check priorities.
+ -- If there is no other tasks, no need to check priorities
if All_Tasks_Link /= Null_Task
and then L.Prio < Interfaces.C.int (Current_Prio)
@@ -331,7 +328,6 @@ package body System.Task_Primitives.Oper
Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -341,7 +337,6 @@ package body System.Task_Primitives.Oper
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -364,7 +359,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
@@ -372,7 +366,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -382,7 +375,6 @@ package body System.Task_Primitives.Oper
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -410,7 +402,7 @@ package body System.Task_Primitives.Oper
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
- -- EINTR is not considered a failure.
+ -- EINTR is not considered a failure
pragma Assert (Result = 0 or else Result = EINTR);
@@ -440,6 +432,8 @@ package body System.Task_Primitives.Oper
Result : Interfaces.C.int;
Status : Cond_Value_Type;
+ -- The body below requires more comments ???
+
begin
Timedout := False;
Yielded := False;
@@ -465,10 +459,12 @@ package body System.Task_Primitives.Oper
if Single_Lock then
Result := pthread_cond_wait
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ pragma Assert (Result = 0);
else
Result := pthread_cond_wait
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end if;
Yielded := True;
@@ -504,6 +500,8 @@ package body System.Task_Primitives.Oper
Lock_RTS;
end if;
+ -- More comments required in body below ???
+
SSL.Abort_Defer.all;
Write_Lock (Self_ID);
@@ -538,9 +536,11 @@ package body System.Task_Primitives.Oper
if Single_Lock then
Result := pthread_cond_wait
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ pragma Assert (Result = 0);
else
Result := pthread_cond_wait
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end if;
Yielded := True;
@@ -560,6 +560,7 @@ package body System.Task_Primitives.Oper
if not Yielded then
Result := sched_yield;
+ pragma Assert (Result = 0);
end if;
SSL.Abort_Undefer.all;
@@ -601,7 +602,7 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
@@ -712,11 +713,13 @@ package body System.Task_Primitives.Oper
----------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
- Cond_Attr : aliased pthread_condattr_t;
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
begin
+ -- More comments required in body below ???
+
if not Single_Lock then
Result := pthread_mutexattr_init (Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@@ -960,8 +963,7 @@ package body System.Task_Primitives.Oper
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
@@ -976,12 +978,10 @@ package body System.Task_Primitives.Oper
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Resume_Task;
@@ -994,7 +994,7 @@ package body System.Task_Primitives.Oper
begin
Environment_Task_ID := Environment_Task;
- -- Initialize the lock used to synchronize chain of all ATCBs.
+ -- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
Index: 5wosprim.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wosprim.adb,v
retrieving revision 1.5
diff -u -p -r1.5 5wosprim.adb
--- 5wosprim.adb 21 Oct 2003 13:41:52 -0000 1.5
+++ 5wosprim.adb 5 Jan 2004 13:15:37 -0000
@@ -93,28 +93,28 @@ package body System.OS_Primitives is
-- Use to have indirect access to multi-word variables
Tick_Frequency : aliased LARGE_INTEGER;
- TFA : LIA := Tick_Frequency'Access;
+ TFA : constant LIA := Tick_Frequency'Access;
-- Holds frequency of high-performance counter used by Clock
-- Windows NT uses a 1_193_182 Hz counter on PCs.
Base_Ticks : aliased LARGE_INTEGER;
- BTA : LIA := Base_Ticks'Access;
+ BTA : constant LIA := Base_Ticks'Access;
-- Holds the Tick count for the base time.
Base_Monotonic_Ticks : aliased LARGE_INTEGER;
- BMTA : LIA := Base_Monotonic_Ticks'Access;
- -- Holds the Tick count for the base monotonic time.
+ BMTA : constant LIA := Base_Monotonic_Ticks'Access;
+ -- Holds the Tick count for the base monotonic time
Base_Clock : aliased Duration;
- BCA : DA := Base_Clock'Access;
+ BCA : constant DA := Base_Clock'Access;
-- Holds the current clock for the standard clock's base time
Base_Monotonic_Clock : aliased Duration;
- BMCA : DA := Base_Monotonic_Clock'Access;
+ BMCA : constant DA := Base_Monotonic_Clock'Access;
-- Holds the current clock for monotonic clock's base time
Base_Time : aliased Long_Long_Integer;
- BTiA : LLIA := Base_Time'Access;
+ BTiA : constant LLIA := Base_Time'Access;
-- Holds the base time used to check for system time change, used with
-- the standard clock.
Index: 5wtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wtaprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5wtaprop.adb
--- 5wtaprop.adb 27 Nov 2003 11:40:45 -0000 1.8
+++ 5wtaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -1012,7 +1012,8 @@ package body System.Task_Primitives.Oper
----------------
procedure Initialize (Environment_Task : Task_ID) is
- Res : BOOL;
+ Discard : BOOL;
+ pragma Unreferenced (Discard);
begin
Environment_Task_ID := Environment_Task;
@@ -1022,7 +1023,7 @@ package body System.Task_Primitives.Oper
-- Here we need Annex E semantics, switch the current process to the
-- High_Priority_Class.
- Res :=
+ Discard :=
OS_Interface.SetPriorityClass
(GetCurrentProcess, High_Priority_Class);
Index: 5zinit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zinit.adb,v
retrieving revision 1.3
diff -u -p -r1.3 5zinit.adb
--- 5zinit.adb 11 Dec 2003 16:21:39 -0000 1.3
+++ 5zinit.adb 5 Jan 2004 13:15:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
@@ -31,18 +31,16 @@
-- --
------------------------------------------------------------------------------
--- This is the VxWorks version of this package
+-- This is the Level A cert version of this package for AE653
with Interfaces.C;
--- used for int and other types
+-- Used for int and other types
with Ada.Exceptions;
--- used for Raise_Exception
+-- Used for Raise_Exception
package body System.Init is
- -- This unit contains initialization circuits that are system dependent.
-
use Ada.Exceptions;
use Interfaces.C;
@@ -52,6 +50,7 @@ package body System.Init is
NSIG : constant := 32;
-- Number of signals on the target OS
+
type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
SIGILL : constant := 4; -- illegal instruction (not reset)
@@ -137,9 +136,9 @@ package body System.Init is
Already_Called : Boolean := False;
Handler_Installed : Integer := 0;
+ pragma Export (C, Handler_Installed, "__gnat_handler_installed");
-- Indication of whether synchronous signal handlers have already been
-- installed by a previous call to Install_Handler.
- pragma Export (C, Handler_Installed, "__gnat_handler_installed");
------------------------
-- Local procedures --
@@ -154,8 +153,10 @@ package body System.Init is
------------------------
procedure GNAT_Error_Handler (Sig : Signal) is
- Mask : aliased sigset_t;
+ Mask : aliased sigset_t;
+
Result : int;
+ pragma Unreferenced (Result);
begin
-- VxWorks will always mask out the signal during the signal
@@ -210,23 +211,24 @@ package body System.Init is
Num_Interrupt_States : Integer;
Unreserve_All_Interrupts : Integer;
Exception_Tracebacks : Integer;
- Zero_Cost_Exceptions : Integer) is
+ Zero_Cost_Exceptions : Integer)
+ is
begin
-- If this procedure has been already called once, check that the
-- arguments in this call are consistent with the ones in the
-- previous calls. Otherwise, raise a Program_Error exception.
- --
+
-- We do not check for consistency of the wide character encoding
-- method. This default affects only Wide_Text_IO where no
-- explicit coding method is given, and there is no particular
-- reason to let this default be affected by the source
-- representation of a library in any case.
- --
+
-- We do not check either for the consistency of exception tracebacks,
-- because exception tracebacks are not normally set in Stand-Alone
-- libraries. If a library or the main program set the exception
-- tracebacks, then they are never reset afterwards (see below).
- --
+
-- The value of main_priority is meaningful only when we are
-- invoked from the main program elaboration routine of an Ada
-- application. Checking the consistency of this parameter should
@@ -238,16 +240,16 @@ package body System.Init is
-- that the case where the main program is not written in Ada is
-- also properly handled, since the default value will then be
-- used for this parameter.
- --
+
-- For identical reasons, the consistency of time_slice_val should
-- not be checked.
if Already_Called then
- if (Gl_Locking_Policy /= Locking_Policy) or
- (Gl_Queuing_Policy /= Queuing_Policy) or
- (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or
- (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or
- (Gl_Exception_Tracebacks /= Exception_Tracebacks) or
+ if (Gl_Locking_Policy /= Locking_Policy) or else
+ (Gl_Queuing_Policy /= Queuing_Policy) or else
+ (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or else
+ (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or else
+ (Gl_Exception_Tracebacks /= Exception_Tracebacks) or else
(Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions)
then
raise Program_Error;
@@ -285,7 +287,9 @@ package body System.Init is
procedure Install_Handler is
Mask : aliased sigset_t;
Signal_Action : aliased struct_sigaction;
- Result : Interfaces.C.int;
+
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
begin
-- Set up signal handler to map synchronous signals to appropriate
Index: 5zinterr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zinterr.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5zinterr.adb
--- 5zinterr.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5zinterr.adb 5 Jan 2004 13:15:37 -0000
@@ -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- --
@@ -422,12 +422,15 @@ package body System.Interrupts is
--------------------------------
-- Restore default handlers for interrupt servers.
+
-- This is called by the Interrupt_Manager task when it receives the abort
-- signal during program finalization.
procedure Finalize_Interrupt_Servers is
+ HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
+
begin
- if HW_Interrupt'Last >= 0 then
+ if HW_Interrupts then
for Int in HW_Interrupt loop
if Server_ID (Interrupt_ID (Int)) /= null
and then
@@ -527,11 +530,16 @@ package body System.Interrupts is
is
use Interfaces.VxWorks;
- Vec : constant Interrupt_Vector :=
- INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
+ Vec : constant Interrupt_Vector :=
+ INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
+
Old_Handler : constant VOIDFUNCPTR :=
- intVecGet (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)));
+ intVecGet
+ (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)));
+
Stat : Interfaces.VxWorks.STATUS;
+ pragma Unreferenced (Stat);
+ -- ??? shouldn't we test Stat at least in a pragma Assert?
begin
-- Only install umbrella handler when no Ada handler has already been
@@ -541,7 +549,7 @@ package body System.Interrupts is
if Default_Handler (Interrupt) = null then
Stat :=
- intConnect (Vec, VOIDFUNCPTR (Handler), System.Address (Interrupt));
+ intConnect (Vec, Handler, System.Address (Interrupt));
Default_Handler (Interrupt) := Old_Handler;
end if;
end Install_Umbrella_Handler;
@@ -611,7 +619,7 @@ package body System.Interrupts is
Ptr := Registered_Handler_Head;
- while (Ptr /= null) loop
+ while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
@@ -653,8 +661,10 @@ package body System.Interrupts is
-- server task deletes its semaphore and terminates.
procedure Notify_Interrupt (Param : System.Address) is
- Interrupt : Interrupt_ID := Interrupt_ID (Param);
+ Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
+
Discard_Result : STATUS;
+ pragma Unreferenced (Discard_Result);
begin
Discard_Result := semGive (Semaphore_ID_Map (Interrupt));
Index: 5zintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zintman.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5zintman.adb
--- 5zintman.adb 11 Dec 2003 16:21:39 -0000 1.8
+++ 5zintman.adb 5 Jan 2004 13:15:37 -0000
@@ -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- --
@@ -86,8 +86,10 @@ package body System.Interrupt_Management
procedure Notify_Exception (signo : Signal) is
Mask : aliased sigset_t;
- Result : int;
My_Id : t_id;
+
+ Result : int;
+ pragma Unreferenced (Result);
begin
Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
Index: 5zml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5zml-tgt.adb
--- 5zml-tgt.adb 20 Nov 2003 09:53:58 -0000 1.2
+++ 5zml-tgt.adb 5 Jan 2004 13:15:37 -0000
@@ -67,7 +67,7 @@ package body MLib.Tgt is
-- Archive_Ext --
-----------------
- function Archive_Ext return String is
+ function Archive_Ext return String is
begin
return "a";
end Archive_Ext;
@@ -150,11 +150,13 @@ package body MLib.Tgt is
-----------------------------
function Get_Target_Suffix return String is
- Target_Name : String_Ptr := Sdefault.Target_Name;
+ Target_Name : constant String_Ptr := Sdefault.Target_Name;
Index : Positive := Target_Name'First;
+
begin
- while ((Index < Target_Name'Last) and then
- (Target_Name (Index + 1) /= '-')) loop
+ while Index < Target_Name'Last
+ and then Target_Name (Index + 1) /= '-'
+ loop
Index := Index + 1;
end loop;
Index: 5ztaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ztaprop.adb,v
retrieving revision 1.9
diff -u -p -r1.9 5ztaprop.adb
--- 5ztaprop.adb 24 Nov 2003 14:27:57 -0000 1.9
+++ 5ztaprop.adb 5 Jan 2004 13:15:37 -0000
@@ -717,9 +717,8 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
pragma Unreferenced (Do_Yield);
-
Result : int;
-
+ pragma Unreferenced (Result);
begin
Result := taskDelay (0);
end Yield;
Index: 6vcpp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/6vcpp.adb,v
retrieving revision 1.6
diff -u -p -r1.6 6vcpp.adb
--- 6vcpp.adb 21 Oct 2003 13:41:53 -0000 1.6
+++ 6vcpp.adb 5 Jan 2004 13:15:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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,7 +31,7 @@
-- --
------------------------------------------------------------------------------
--- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package.
+-- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package
with Ada.Tags; use Ada.Tags;
with System; use System;
@@ -102,14 +102,14 @@ package body Interfaces.CPP is
function Displaced_This
(Current_This : System.Address;
Vptr : Vtable_Ptr;
- Position : Positive)
- return System.Address
+ Position : Positive) return System.Address
is
pragma Warnings (Off, Vptr);
pragma Warnings (Off, Position);
begin
return Current_This;
--- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
+ -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
+ -- why is above line commented out ???
end Displaced_This;
-----------------------
@@ -118,8 +118,7 @@ package body Interfaces.CPP is
function CPP_CW_Membership
(Obj_Tag : Vtable_Ptr;
- Typ_Tag : Vtable_Ptr)
- return Boolean
+ Typ_Tag : Vtable_Ptr) return Boolean
is
Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
begin
@@ -153,14 +152,24 @@ package body Interfaces.CPP is
return T.TSD.Idepth;
end CPP_Get_Inheritance_Depth;
- -------------------------
+ -----------------------
+ -- CPP_Get_RC_Offset --
+ -----------------------
+
+ function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
+ pragma Warnings (Off, T);
+ begin
+ return 0;
+ end CPP_Get_RC_Offset;
+
+ -----------------------------
-- CPP_Get_Prim_Op_Address --
- -------------------------
+ -----------------------------
function CPP_Get_Prim_Op_Address
(T : Vtable_Ptr;
- Position : Positive)
- return Address is
+ Position : Positive) return Address
+ is
begin
return T.Prims_Ptr (Position).Pfn;
end CPP_Get_Prim_Op_Address;
@@ -189,14 +198,14 @@ package body Interfaces.CPP is
--------------------
procedure CPP_Inherit_DT
- (Old_T : Vtable_Ptr;
- New_T : Vtable_Ptr;
+ (Old_T : Vtable_Ptr;
+ New_T : Vtable_Ptr;
Entry_Count : Natural)
is
begin
if Old_T /= null then
- New_T.Prims_Ptr (1 .. Entry_Count)
- := Old_T.Prims_Ptr (1 .. Entry_Count);
+ New_T.Prims_Ptr (1 .. Entry_Count) :=
+ Old_T.Prims_Ptr (1 .. Entry_Count);
end if;
end CPP_Inherit_DT;
@@ -208,8 +217,8 @@ package body Interfaces.CPP is
(Old_TSD : Address;
New_Tag : Vtable_Ptr)
is
- TSD : constant Type_Specific_Data_Ptr
- := To_Type_Specific_Data_Ptr (Old_TSD);
+ TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (Old_TSD);
New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
@@ -268,6 +277,17 @@ package body Interfaces.CPP is
T.Prims_Ptr (Position).Pfn := Value;
end CPP_Set_Prim_Op_Address;
+ -----------------------
+ -- CPP_Set_RC_Offset --
+ -----------------------
+
+ procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Value);
+ begin
+ null;
+ end CPP_Set_RC_Offset;
+
-------------------------------
-- CPP_Set_Remotely_Callable --
-------------------------------
@@ -293,8 +313,7 @@ package body Interfaces.CPP is
-------------------
function Expanded_Name (T : Vtable_Ptr) return String is
- Result : Cstring_Ptr := T.TSD.Expanded_Name;
-
+ Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
begin
return Result (1 .. Length (Result));
end Expanded_Name;
@@ -304,8 +323,7 @@ package body Interfaces.CPP is
------------------
function External_Tag (T : Vtable_Ptr) return String is
- Result : Cstring_Ptr := T.TSD.External_Tag;
-
+ Result : constant Cstring_Ptr := T.TSD.External_Tag;
begin
return Result (1 .. Length (Result));
end External_Tag;
@@ -325,16 +343,4 @@ package body Interfaces.CPP is
return Len - 1;
end Length;
- procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Value);
- begin
- null;
- end CPP_Set_RC_Offset;
-
- function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
- pragma Warnings (Off, T);
- begin
- return 0;
- end CPP_Get_RC_Offset;
end Interfaces.CPP;
Index: 6vcstrea.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/6vcstrea.adb,v
retrieving revision 1.8
diff -u -p -r1.8 6vcstrea.adb
--- 6vcstrea.adb 15 Dec 2003 11:51:00 -0000 1.8
+++ 6vcstrea.adb 5 Jan 2004 13:15:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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,14 @@ 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.???
+
+ -- 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.???
+
------------
-- fread --
------------
@@ -46,31 +54,36 @@ package body Interfaces.C_Streams is
(buffer : voids;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
Get_Count : size_t := 0;
+
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
- BA : Buffer_Access := To_BA (buffer);
+
+ BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
- begin
+ begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 .. count loop
for S in 1 .. size loop
Ch := fgetc (stream);
+
if Ch = EOF then
return Get_Count;
end if;
+
BA.all (C, S) := Character'Val (Ch);
end loop;
+
Get_Count := Get_Count + 1;
end loop;
+
return Get_Count;
end fread;
@@ -83,31 +96,36 @@ package body Interfaces.C_Streams is
index : size_t;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
Get_Count : size_t := 0;
+
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
- BA : Buffer_Access := To_BA (buffer);
+
+ BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
- begin
+ begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 + index .. count + index loop
for S in 1 .. size loop
Ch := fgetc (stream);
+
if Ch = EOF then
return Get_Count;
end if;
+
BA.all (C, S) := Character'Val (Ch);
end loop;
+
Get_Count := Get_Count + 1;
end loop;
+
return Get_Count;
end fread;
@@ -119,17 +137,18 @@ package body Interfaces.C_Streams is
(buffer : voids;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
Put_Count : size_t := 0;
+
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
- BA : Buffer_Access := To_BA (buffer);
- begin
+ BA : constant Buffer_Access := To_BA (buffer);
+
+ begin
-- Fwrite on VMS has the undesirable effect of always generating at
-- least one record of output per call, regardless of buffering. To
-- get around this, we do multiple fputc calls instead.
@@ -140,8 +159,10 @@ package body Interfaces.C_Streams is
return Put_Count;
end if;
end loop;
+
Put_Count := Put_Count + 1;
end loop;
+
return Put_Count;
end fwrite;
@@ -153,12 +174,11 @@ package body Interfaces.C_Streams is
(stream : FILEs;
buffer : chars;
mode : int;
- size : size_t)
- return int
+ size : size_t) return int
is
use type System.Address;
- begin
+ begin
-- In order for the above fwrite hack to work, we must always buffer
-- stdout and stderr. Is_regular_file on VMS cannot detect when
-- these are redirected to a file, so checking for that condition
Index: 7staprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7staprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 7staprop.adb
--- 7staprop.adb 21 Oct 2003 13:41:53 -0000 1.7
+++ 7staprop.adb 5 Jan 2004 13:15:38 -0000
@@ -725,7 +725,7 @@ package body System.Task_Primitives.Oper
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
Index: 7stpopsp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7stpopsp.adb,v
retrieving revision 1.5
diff -u -p -r1.5 7stpopsp.adb
--- 7stpopsp.adb 21 Oct 2003 13:41:53 -0000 1.5
+++ 7stpopsp.adb 5 Jan 2004 13:15:38 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Fundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Fundation, 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- --
@@ -43,7 +43,6 @@ package body Specific is
procedure Initialize (Environment_Task : Task_ID) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
-
begin
Result := pthread_key_create (ATCB_Key'Access, null);
pragma Assert (Result = 0);
@@ -64,7 +63,6 @@ package body Specific is
procedure Set (Self_Id : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
pragma Assert (Result = 0);
Index: ali.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ali.adb,v
retrieving revision 1.11
diff -u -p -r1.11 ali.adb
--- ali.adb 21 Oct 2003 13:41:58 -0000 1.11
+++ ali.adb 5 Jan 2004 13:15:38 -0000
@@ -92,7 +92,6 @@ package body ALI is
Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False;
Zero_Cost_Exceptions_Specified := False;
-
end Initialize_ALI;
--------------
@@ -143,8 +142,9 @@ package body ALI is
function Getc return Character;
-- Get next character, bumping P past the character obtained
- function Get_Name (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id;
+ function Get_Name
+ (Lower : Boolean := False;
+ Ignore_Spaces : Boolean := False) return Name_Id;
-- Skip blanks, then scan out a name (name is left in Name_Buffer with
-- length in Name_Len, as well as being returned in Name_Id form).
-- If Lower is set to True then the Name_Buffer will be converted to
@@ -175,6 +175,10 @@ package body ALI is
procedure Skip_Space;
-- Skip past white space (blanks or horizontal tab)
+ procedure Skipc;
+ -- Skip past next character, does not affect value in C. This call
+ -- is like calling Getc and ignoring the returned result.
+
---------------------
-- At_End_Of_Field --
---------------------
@@ -480,6 +484,17 @@ package body ALI is
end loop;
end Skip_Space;
+ -----------
+ -- Skipc --
+ -----------
+
+ procedure Skipc is
+ begin
+ if P /= T'Last then
+ P := P + 1;
+ end if;
+ end Skipc;
+
-- Start of processing for Scan_ALI
begin
@@ -706,6 +721,8 @@ package body ALI is
Normalize_Scalars_Specified := True;
NS_Found := True;
+ -- Invalid switch starting with N
+
else
Fatal_Error;
end if;
@@ -716,11 +733,26 @@ package body ALI is
Queuing_Policy_Specified := Getc;
ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
- -- Processing for SL
+ -- Processing fir flags starting with S
elsif C = 'S' then
- Checkc ('L');
- ALIs.Table (Id).Interface := True;
+ C := Getc;
+
+ -- Processing for SL
+
+ if C = 'L' then
+ ALIs.Table (Id).Interface := True;
+
+ -- Processing for SS
+
+ elsif C = 'S' then
+ Opt.Sec_Stack_Used := True;
+
+ -- Invalid switch starting with S
+
+ else
+ Fatal_Error;
+ end if;
-- Processing for Tx
@@ -729,18 +761,25 @@ package body ALI is
ALIs.Table (Id).Task_Dispatching_Policy :=
Task_Dispatching_Policy_Specified;
- -- Processing for UA
+ -- Processing for switch starting with U
elsif C = 'U' then
- if Nextc = 'A' then
+ C := Getc;
+
+ -- Processing for UA
+
+ if C = 'A' then
Unreserve_All_Interrupts_Specified := True;
- C := Getc;
-- Processing for UX
- else
- Checkc ('X');
+ elsif C = 'X' then
ALIs.Table (Id).Unit_Exception_Table := True;
+
+ -- Invalid switches starting with U
+
+ else
+ Fatal_Error;
end if;
-- Processing for ZX
@@ -1487,11 +1526,9 @@ package body ALI is
Xref_Entity.Increment_Last;
Read_Refs_For_One_Entity : declare
-
XE : Xref_Entity_Record renames
Xref_Entity.Table (Xref_Entity.Last);
-
- N : Nat;
+ N : Nat;
procedure Read_Instantiation_Reference;
-- Acquire instantiation reference. Caller has checked
@@ -1621,7 +1658,6 @@ package body ALI is
declare
Nested_Brackets : Natural := 0;
- C : Character;
begin
loop
@@ -1636,7 +1672,7 @@ package body ALI is
end if;
end case;
- C := Getc;
+ Skipc;
end loop;
end;
@@ -1680,7 +1716,6 @@ package body ALI is
Current_File_Num := XR.File_Num;
P := P + 1;
N := Get_Nat;
-
else
XR.File_Num := Current_File_Num;
end if;
@@ -1710,7 +1745,6 @@ package body ALI is
XE.Last_Xref := Xref.Last;
C := Nextc;
-
end Read_Refs_For_One_Entity;
end loop;
Index: a-numaux.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-numaux.ads,v
retrieving revision 1.4
diff -u -p -r1.4 a-numaux.ads
--- a-numaux.ads 24 Apr 2003 17:53:53 -0000 1.4
+++ a-numaux.ads 5 Jan 2004 13:15:38 -0000
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version, non-x86) --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -39,9 +39,11 @@
-- One advantage of using this package is that it will interface directly to
-- hardware instructions, such as the those provided on the Intel x86.
--- Note: there are two versions of this package. One using the normal IEEE
--- 64-bit double format (which is this version), and one using 80-bit x86
--- long double (see file 4onumaux.ads).
+-- This version is for use with normal Unix math functions. Alternative
+-- packages are used on OpenVMS (different import names), VxWorks (no
+-- need for the -lm Linker_Options), and on the x86 (where we have two
+-- versions one using inline ASM, and one importing from the C long
+-- routines that take 80-bit arguments).
package Ada.Numerics.Aux is
pragma Pure (Aux);
@@ -49,48 +51,61 @@ pragma Pure (Aux);
pragma Linker_Options ("-lm");
type Double is digits 15;
- pragma Float_Representation (IEEE_Float, Double);
- -- Type Double is the type used to call the C routines. Note that this
- -- is IEEE format even when running on VMS with Vax_Float representation
- -- since we use the IEEE version of the C library with VMS.
+ -- Type Double is the type used to call the C routines
+
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure!
function Sin (X : Double) return Double;
pragma Import (C, Sin, "sin");
+ pragma Pure_Function (Sin);
function Cos (X : Double) return Double;
pragma Import (C, Cos, "cos");
+ pragma Pure_Function (Cos);
function Tan (X : Double) return Double;
pragma Import (C, Tan, "tan");
+ pragma Pure_Function (Tan);
function Exp (X : Double) return Double;
pragma Import (C, Exp, "exp");
+ pragma Pure_Function (Exp);
function Sqrt (X : Double) return Double;
pragma Import (C, Sqrt, "sqrt");
+ pragma Pure_Function (Sqrt);
function Log (X : Double) return Double;
pragma Import (C, Log, "log");
+ pragma Pure_Function (Log);
function Acos (X : Double) return Double;
pragma Import (C, Acos, "acos");
+ pragma Pure_Function (Acos);
function Asin (X : Double) return Double;
pragma Import (C, Asin, "asin");
+ pragma Pure_Function (Asin);
function Atan (X : Double) return Double;
pragma Import (C, Atan, "atan");
+ pragma Pure_Function (Atan);
function Sinh (X : Double) return Double;
pragma Import (C, Sinh, "sinh");
+ pragma Pure_Function (Sinh);
function Cosh (X : Double) return Double;
pragma Import (C, Cosh, "cosh");
+ pragma Pure_Function (Cosh);
function Tanh (X : Double) return Double;
pragma Import (C, Tanh, "tanh");
+ pragma Pure_Function (Tanh);
function Pow (X, Y : Double) return Double;
pragma Import (C, Pow, "pow");
+ pragma Pure_Function (Pow);
end Ada.Numerics.Aux;
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.17
diff -u -p -r1.17 bindgen.adb
--- bindgen.adb 8 Dec 2003 10:33:14 -0000 1.17
+++ bindgen.adb 5 Jan 2004 13:15:38 -0000
@@ -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- --
@@ -518,9 +518,10 @@ package body Bindgen is
Write_Statement_Buffer;
-- Generate call to Install_Handler
+
WBI ("");
WBI (" if Handler_Installed = 0 then");
- WBI (" Install_Handler;");
+ WBI (" Install_Handler;");
WBI (" end if;");
end if;
@@ -536,6 +537,17 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
+ -- Generate assignment of default secondary stack size if set
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI ("");
+ Set_String (" System.Secondary_Stack.");
+ Set_String ("Default_Secondary_Stack_Size := ");
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ Set_Char (';');
+ Write_Statement_Buffer;
+ end if;
+
-- Generate elaboration calls
WBI ("");
@@ -613,6 +625,13 @@ package body Bindgen is
Set_String (""";");
Write_Statement_Buffer;
+ -- Generate declaration for secondary stack default if needed
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI (" extern int system__secondary_stack__" &
+ "default_secondary_stack_size;");
+ end if;
+
WBI ("");
-- Code for normal case (standard library not suppressed)
@@ -742,6 +761,17 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
+ -- Generate assignment of default secondary stack size if set
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI ("");
+ Set_String (" system__secondary_stack__");
+ Set_String ("default_secondary_stack_size = ");
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ Set_Char (';');
+ Write_Statement_Buffer;
+ end if;
+
-- Generate elaboration calls
WBI ("");
@@ -1862,12 +1892,24 @@ package body Bindgen is
if With_GNARL then
Name_Len := 0;
- Add_Str_To_Name_Buffer ("-lgnarl");
+
+ if Opt.Shared_Libgnat then
+ Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
+ else
+ Add_Str_To_Name_Buffer ("-lgnarl");
+ end if;
+
Write_Linker_Option;
end if;
Name_Len := 0;
- Add_Str_To_Name_Buffer ("-lgnat");
+
+ if Opt.Shared_Libgnat then
+ Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
+ else
+ Add_Str_To_Name_Buffer ("-lgnat");
+ end if;
+
Write_Linker_Option;
end if;
@@ -1983,6 +2025,12 @@ package body Bindgen is
WBI ("with System.Scalar_Values;");
end if;
+ -- Generate with of System.Secondary_Stack if active
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI ("with System.Secondary_Stack;");
+ end if;
+
Resolve_Binder_Options;
if not Suppress_Standard_Library_On_Target then
@@ -2698,7 +2746,6 @@ package body Bindgen is
----------------------------
procedure Public_Version_Warning is
-
Time : constant Int := Time_From_Last_Bind;
-- Constants to help defining periods
@@ -2738,12 +2785,17 @@ package body Bindgen is
-- Do not emit the message if the last message was emitted in the
-- specified period taking into account the number of units.
+ pragma Warnings (Off);
+ -- Turn off warning of constant condition, which may happen here
+ -- depending on the choice of constants in the above declarations.
+
if Nb_Unit < Large and then Time <= Period_Small then
return;
-
elsif Time <= Period_Large then
return;
end if;
+
+ pragma Warnings (On);
Write_Eol;
Write_Str ("IMPORTANT NOTICE:");
Index: bindusg.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindusg.adb,v
retrieving revision 1.8
diff -u -p -r1.8 bindusg.adb
--- bindusg.adb 21 Oct 2003 13:41:58 -0000 1.8
+++ bindusg.adb 5 Jan 2004 13:15:38 -0000
@@ -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- --
@@ -71,6 +71,11 @@ begin
-- Line for C switch
Write_Str (" -C Generate binder program in C");
+ Write_Eol;
+
+ -- Line for D switch
+
+ Write_Str (" -Dnnn Default secondary stack size = nnn bytes");
Write_Eol;
-- Line for -e switch
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.4
diff -u -p -r1.4 bld.adb
--- bld.adb 21 Nov 2003 10:46:37 -0000 1.4
+++ bld.adb 5 Jan 2004 13:15:38 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -66,12 +66,12 @@ package body Bld is
Copyright_Displayed : Boolean := False;
-- To avoid displaying the Copyright line several times
- Usage_Displayed : Boolean := False;
+ Usage_Displayed : Boolean := False;
-- To avoid displaying the usage several times
type Expression_Kind_Type is (Undecided, Static_String, Other);
- Expression_Kind : Expression_Kind_Type := Undecided;
+ Expression_Kind : Expression_Kind_Type := Undecided;
-- After procedure Expression has been called, this global variable
-- indicates if the expression is a static string or not.
-- If it is a static string, then Expression_Value (1 .. Expression_Last)
@@ -110,16 +110,14 @@ package body Bld is
-- The following variables are used to controlled what attributes
-- Default_Switches and Switches are allowed in expressions.
- Default_Switches_Project : Project_Node_Id := Empty_Node;
- Default_Switches_Package : Name_Id := No_Name;
- Default_Switches_Language : Name_Id := No_Name;
-
- Switches_Project : Project_Node_Id := Empty_Node;
+ Default_Switches_Package : Name_Id := No_Name;
+ Default_Switches_Language : Name_Id := No_Name;
Switches_Package : Name_Id := No_Name;
Switches_Language : Source_Kind_Type := Unknown;
-- Other attribute references are only allowed in attribute declarations
-- of the same package and of the same name.
+
-- Other_Attribute is True only during attribute declarations other than
-- Switches or Default_Switches.
@@ -383,8 +381,7 @@ package body Bld is
(Static : Boolean;
Value : String_Access;
Last : Natural;
- Default : String)
- return String;
+ Default : String) return String;
-- Returns the current suffix, if it is statically known, or ""
-- if it is not statically known. Used on C_Suffix, Cxx_Suffix,
-- Ada_Body_Suffix and Ada_Spec_Suffix.
@@ -435,7 +432,7 @@ package body Bld is
Copyright_Displayed := True;
Write_Str ("GPR2MAKE ");
Write_Str (Gnatvsn.Gnat_Version_String);
- Write_Str (" Copyright 2002-2003 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 2002-2004 Free Software Foundation, Inc.");
Write_Eol;
Write_Eol;
end if;
@@ -1175,12 +1172,10 @@ package body Bld is
Current_Declarative_Item := Next_Declarative_Item
(Current_Declarative_Item);
- -- By default, indicate that Default_Switches and Switches
- -- attribute references are not allowed in expressions.
+ -- By default, indicate that we are not declaring attribute
+ -- Default_Switches or Switches.
- Default_Switches_Project := Empty_Node;
- Switches_Project := Empty_Node;
- Other_Attribute := False;
+ Other_Attribute := False;
-- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
@@ -1345,7 +1340,6 @@ package body Bld is
-- in expressions.
if Item_Name = Snames.Name_Default_Switches then
- Default_Switches_Project := Project;
Default_Switches_Package := Pkg;
Default_Switches_Language := Index;
@@ -1354,7 +1348,6 @@ package body Bld is
-- Switches attribute references are allowed in expressions.
elsif Item_Name = Snames.Name_Switches then
- Switches_Project := Project;
Switches_Package := Pkg;
Switches_Language := Source_Kind_Of (Index);
@@ -1862,7 +1855,7 @@ package body Bld is
end if;
end if;
- elsif Item_Name = Snames.Name_Ada then
+ elsif Index_Name = Snames.Name_Ada then
-- For "Ada", we set the variable ADA_BODY
@@ -1897,9 +1890,9 @@ package body Bld is
else
Ada_Body_Suffix_Static :=
Expression_Value
- (1 .. Expression_Last) =
- Ada_Body_Suffix
- (1 .. Ada_Body_Suffix_Last);
+ (1 .. Expression_Last) =
+ Ada_Body_Suffix
+ (1 .. Ada_Body_Suffix_Last);
end if;
end if;
end if;
@@ -3511,8 +3504,7 @@ package body Bld is
(Static : Boolean;
Value : String_Access;
Last : Natural;
- Default : String)
- return String
+ Default : String) return String
is
begin
if Static then
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.14
diff -u -p -r1.14 checks.adb
--- checks.adb 17 Dec 2003 13:37:03 -0000 1.14
+++ checks.adb 5 Jan 2004 13:15:38 -0000
@@ -463,13 +463,16 @@ package body Checks is
Expr : Node_Id;
Loc : Source_Ptr;
+ Alignment_Required : constant Boolean := Maximum_Alignment > 1;
+ -- Constant to show whether target requires alignment checks
+
begin
-- See if check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed
if No (AC)
or else not Check_Address_Alignment (AC)
- or else Maximum_Alignment = 1
+ or else not Alignment_Required
then
return;
end if;
@@ -1191,7 +1194,7 @@ package body Checks is
N_Full_Type_Declaration
then
declare
- Type_Def : Node_Id :=
+ Type_Def : constant Node_Id :=
Type_Definition
(Original_Node (Parent (T_Typ)));
begin
Index: clean.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/clean.adb,v
retrieving revision 1.1
diff -u -p -r1.1 clean.adb
--- clean.adb 21 Oct 2003 13:41:58 -0000 1.1
+++ clean.adb 5 Jan 2004 13:15:38 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
@@ -370,9 +370,6 @@ package body Clean is
Source_File : File_Name_Type;
-- Current source file
- Full_Source_File : File_Name_Type;
- -- Full name of the current source file
-
Lib_File : File_Name_Type;
-- Current library file
@@ -401,9 +398,8 @@ package body Clean is
while not Empty_Q loop
Sources.Set_Last (0);
Extract_From_Q (Source_File);
- Full_Source_File := Osint.Full_Source_Name (Source_File);
- Lib_File := Osint.Lib_File_Name (Source_File);
- Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
+ Lib_File := Osint.Lib_File_Name (Source_File);
+ Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
-- If we have an existing ALI file that is not read-only,
-- process it.
@@ -925,7 +921,7 @@ package body Clean is
if not Copyright_Displayed then
Copyright_Displayed := True;
Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String
- & " Copyright 2003 Free Software Foundation, Inc.");
+ & " Copyright 2003-2004 Free Software Foundation, Inc.");
end if;
end Display_Copyright;
@@ -1156,9 +1152,7 @@ package body Clean is
-- Insert_Q --
--------------
- procedure Insert_Q
- (Source_File : File_Name_Type)
- is
+ procedure Insert_Q (Source_File : File_Name_Type) is
begin
-- Do not insert an empty name or an already marked source
@@ -1180,6 +1174,7 @@ package body Clean is
function Object_File_Name (Source : Name_Id) return String is
Src : constant String := Get_Name_String (Source);
+
begin
-- If the source name has an extension, then replace it with
-- the Object suffix.
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.13
diff -u -p -r1.13 cstand.adb
--- cstand.adb 17 Dec 2003 13:37:03 -0000 1.13
+++ cstand.adb 5 Jan 2004 13:15:39 -0000
@@ -258,10 +258,10 @@ package body CStand is
-- by Initialize_Standard in the semantics module.
procedure Create_Standard is
- Decl_S : List_Id := New_List;
+ Decl_S : constant List_Id := New_List;
-- List of declarations in Standard
- Decl_A : List_Id := New_List;
+ Decl_A : constant List_Id := New_List;
-- List of declarations in ASCII
Decl : Node_Id;
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.23
diff -u -p -r1.23 decl.c
--- decl.c 18 Nov 2003 10:00:42 -0000 1.23
+++ decl.c 5 Jan 2004 13:15:39 -0000
@@ -3255,6 +3255,21 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
each. While doing this, build a copy-out structure if
we need one. */
+ /* If the return type has a size that overflows, we cannot have
+ a function that returns that type. This usage doesn't make
+ sense anyway, so give an error here. */
+ if (TYPE_SIZE_UNIT (gnu_return_type)
+ && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
+ {
+ post_error ("cannot return type whose size overflows",
+ gnat_entity);
+ gnu_return_type = copy_node (gnu_return_type);
+ TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
+ TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
+ TYPE_NEXT_VARIANT (gnu_return_type) = 0;
+ }
+
for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
Index: einfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.adb,v
retrieving revision 1.11
diff -u -p -r1.11 einfo.adb
--- einfo.adb 4 Nov 2003 12:51:45 -0000 1.11
+++ einfo.adb 5 Jan 2004 13:15:39 -0000
@@ -4660,7 +4660,7 @@ package body Einfo is
end Entry_Index_Type;
---------------------
- -- First_Component --
+ -- 1 --
---------------------
function First_Component (Id : E) return E is
@@ -4671,7 +4671,6 @@ package body Einfo is
(Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
Comp_Id := First_Entity (Id);
-
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id);
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.17
diff -u -p -r1.17 einfo.ads
--- einfo.ads 20 Nov 2003 09:53:58 -0000 1.17
+++ einfo.ads 5 Jan 2004 13:15:39 -0000
@@ -521,7 +521,7 @@ package Einfo is
-- representation clause is present for the corresponding record
-- type a that specifies a position for the component, then the
-- Component_Clause field of the E_Component entity points to the
--- N_Component_Claue node. Set to Empty if no record representation
+-- N_Component_Clause node. Set to Empty if no record representation
-- clause was present, or if there was no specification for this
-- component.
@@ -2581,6 +2581,7 @@ package Einfo is
-- Present in components and discriminants. Indicates the normalized
-- value of First_Bit for the component, i.e. the offset within the
-- lowest addressed storage unit containing part or all of the field.
+-- Set to No_Uint if no first bit position is assigned yet.
-- Normalized_Position (Uint14)
-- Present in components and discriminants. Indicates the normalized
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_aggr.adb
--- exp_aggr.adb 8 Dec 2003 10:33:14 -0000 1.11
+++ exp_aggr.adb 5 Jan 2004 13:15:40 -0000
@@ -264,6 +264,8 @@ package body Exp_Aggr is
-- 5. The array component type is tagged, which may necessitate
-- reassignment of proper tags.
+ -- 6. The array component type might have unaligned bit components
+
function Backend_Processing_Possible (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (N);
-- Typ is the correct constrained array subtype of the aggregate.
@@ -317,7 +319,7 @@ package body Exp_Aggr is
return False;
end if;
- -- Checks 4 (array must not be multi-dimensional Fortran case)
+ -- Checks 4 (array must not be multi-dimensional Fortran case)
if Convention (Typ) = Convention_Fortran
and then Number_Dimensions (Typ) > 1
@@ -350,6 +352,12 @@ package body Exp_Aggr is
return False;
end if;
+ -- Checks 6 (component type must not have bit aligned components)
+
+ if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
+ return False;
+ end if;
+
-- Backend processing is possible
Set_Compile_Time_Known_Aggregate (N, True);
@@ -1924,7 +1932,7 @@ package body Exp_Aggr is
-- by Build_Task_Allocate_Block_With_Init_Stmts)
declare
- Ctype : Entity_Id := Etype (Selector);
+ Ctype : constant Entity_Id := Etype (Selector);
Inside_Allocator : Boolean := False;
P : Node_Id := Parent (N);
@@ -3520,7 +3528,8 @@ package body Exp_Aggr is
function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
is
- Obj_Type : Entity_Id := Etype (Defining_Identifier (Parent (N)));
+ Obj_Type : constant Entity_Id :=
+ Etype (Defining_Identifier (Parent (N)));
L1, L2, H1, H2 : Node_Id;
@@ -4341,6 +4350,12 @@ package body Exp_Aggr is
-- size of the data.
elsif Has_Mutable_Components (Typ) then
+ Convert_To_Assignments (N, Typ);
+
+ -- If the type involved has any non-bit aligned components, then
+ -- we are not sure that the back end can handle this case correctly.
+
+ elsif Type_May_Have_Bit_Aligned_Components (Typ) then
Convert_To_Assignments (N, Typ);
-- In all other cases we generate a proper aggregate that
Index: exp_ch11.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch11.adb,v
retrieving revision 1.7
diff -u -p -r1.7 exp_ch11.adb
--- exp_ch11.adb 21 Oct 2003 13:41:59 -0000 1.7
+++ exp_ch11.adb 5 Jan 2004 13:15:40 -0000
@@ -721,7 +721,7 @@ package body Exp_Ch11 is
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
declare
- H : Node_Id := Handler;
+ H : constant Node_Id := Handler;
begin
Next_Non_Pragma (Handler);
Remove (H);
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch3.adb
--- exp_ch3.adb 8 Dec 2003 10:33:14 -0000 1.11
+++ exp_ch3.adb 5 Jan 2004 13:15:40 -0000
@@ -2882,7 +2882,7 @@ package body Exp_Ch3 is
begin
-- Don't do anything for deferred constants. All proper actions will
- -- be expanded during the redeclaration.
+ -- be expanded during the full declaration.
if No (Expr) and Constant_Present (N) then
return;
@@ -3018,7 +3018,7 @@ package body Exp_Ch3 is
-- When we have the appropriate type of aggregate in the
-- expression (it has been determined during analysis of the
-- aggregate by setting the delay flag), let's perform in
- -- place assignment and thus avoid creating a temporay.
+ -- place assignment and thus avoid creating a temporary.
if Is_Delayed_Aggregate (Expr_Q) then
Convert_Aggr_In_Object_Decl (N);
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_ch4.adb
--- exp_ch4.adb 1 Dec 2003 13:29:27 -0000 1.13
+++ exp_ch4.adb 5 Jan 2004 13:15:40 -0000
@@ -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- --
@@ -654,6 +654,8 @@ package body Exp_Ch4 is
Comp : RE_Id;
+ Stg_Unit_Is_Byte : constant Boolean := System_Storage_Unit = Byte'Size;
+
function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
-- Returns True if the length of the given operand is known to be
-- less than 4. Returns False if this length is known to be four
@@ -705,7 +707,7 @@ package body Exp_Ch4 is
-- addressing of array components.
if not Is_Bit_Packed_Array (Typ1)
- and then System_Storage_Unit = Byte'Size
+ and then Stg_Unit_Is_Byte
and then not Java_VM
then
-- The call we generate is:
@@ -5471,8 +5473,8 @@ package body Exp_Ch4 is
then
return;
- elsif (Nkind (Parent (N)) = N_Attribute_Reference
- and then Attribute_Name (Parent (N)) = Name_Address)
+ elsif Nkind (Parent (N)) = N_Attribute_Reference
+ and then Attribute_Name (Parent (N)) = Name_Address
then
return;
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_ch5.adb
--- exp_ch5.adb 3 Dec 2003 11:47:52 -0000 1.12
+++ exp_ch5.adb 5 Jan 2004 13:15:41 -0000
@@ -48,6 +48,7 @@ with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
@@ -75,8 +76,7 @@ package body Exp_Ch5 is
L_Type : Entity_Id;
R_Type : Entity_Id;
Ndim : Pos;
- Rev : Boolean)
- return Node_Id;
+ Rev : Boolean) return Node_Id;
-- N is an assignment statement which assigns an array value. This routine
-- expands the assignment into a loop (or nested loops for the case of a
-- multi-dimensional array) to do the assignment component by component.
@@ -104,32 +104,11 @@ package body Exp_Ch5 is
function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
- -- indexed component. The back end can handle such assignments fine
- -- if the objects involved are small (64-bits or less) records or
- -- scalar items (including bit-packed arrays represented with modular
- -- types) or are both aligned on a byte boundary (starting on a byte
- -- boundary, and occupying an integral number of bytes).
- --
- -- However, problems arise for records larger than 64 bits, or for
- -- arrays (other than bit-packed arrays represented with a modular
- -- type) if the component starts on a non-byte boundary, or does
- -- not occupy an integral number of bytes (i.e. there are some bits
- -- possibly shared with fields at the start or beginning of the
- -- component). The back end cannot handle loading and storing such
- -- components in a single operation.
- --
- -- This function is used to detect the troublesome situation. it is
- -- conservative in the sense that it produces True unless it knows
- -- for sure that the component is safe (as outlined in the first
- -- paragraph above). The code generation for record and array
- -- assignment checks for trouble using this function, and if so
- -- the assignment is generated component-wise, which the back end
- -- is required to handle correctly.
- --
- -- Note that in GNAT 3, the back end will reject such components
- -- anyway, so the hard work in checking for this case is wasted
- -- in GNAT 3, but it's harmless, so it is easier to do it in
- -- all cases, rather than conditionalize it in GNAT 5 or beyond.
+ -- indexed component. The argument N is either the left hand or right
+ -- hand side of an assignment, and this function determines if there
+ -- is a record component reference where the record may be bit aligned
+ -- in a manner that causes trouble for the back end (see description
+ -- of Sem_Util.Component_May_Be_Bit_Aligned for further details).
------------------------------
-- Change_Of_Representation --
@@ -508,9 +487,12 @@ package body Exp_Ch5 is
-- statement, a length check has already been emitted to verify that
-- the range of the left-hand side is empty.
+ -- Note that this code is not executed if we had an assignment of
+ -- a string literal to a non-bit aligned component of a record, a
+ -- case which cannot be handled by the backend
+
elsif Nkind (Rhs) = N_String_Literal then
- if Ekind (R_Type) = E_String_Literal_Subtype
- and then String_Literal_Length (R_Type) = 0
+ if String_Length (Strval (Rhs)) = 0
and then Is_Bit_Packed_Array (L_Type)
then
Rewrite (N, Make_Null_Statement (Loc));
@@ -731,8 +713,8 @@ package body Exp_Ch5 is
elsif Restrictions (No_Implicit_Conditionals) then
declare
- T : constant Entity_Id := Make_Defining_Identifier (Loc,
- Chars => Name_T);
+ T : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => Name_T);
begin
Rewrite (N,
@@ -881,8 +863,7 @@ package body Exp_Ch5 is
L_Type : Entity_Id;
R_Type : Entity_Id;
Ndim : Pos;
- Rev : Boolean)
- return Node_Id
+ Rev : Boolean) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
@@ -2244,8 +2225,8 @@ package body Exp_Ch5 is
and then List_Length (Else_Statements (N)) = 1
then
declare
- Then_Stm : Node_Id := First (Then_Statements (N));
- Else_Stm : Node_Id := First (Else_Statements (N));
+ Then_Stm : constant Node_Id := First (Then_Statements (N));
+ Else_Stm : constant Node_Id := First (Else_Statements (N));
begin
if Nkind (Then_Stm) = N_Return_Statement
@@ -3277,39 +3258,10 @@ package body Exp_Ch5 is
-- unless it is forced to do so. In the clear means we need
-- only the recursive test on the prefix.
- if No (Component_Clause (Comp)) then
- return Possible_Bit_Aligned_Component (P);
-
- -- Otherwise we have a component clause, which means that
- -- the Esize and Normalized_First_Bit fields are set and
- -- contain static values known at compile time.
-
+ if Component_May_Be_Bit_Aligned (Comp) then
+ return True;
else
- -- If we know that we have a small (64 bits or less) record
- -- or bit-packed array, then everything is fine, since the
- -- back end can handle these cases correctly.
-
- if Esize (Comp) <= 64
- and then (Is_Record_Type (Etype (Comp))
- or else
- Is_Bit_Packed_Array (Etype (Comp)))
- then
- return False;
-
- -- Otherwise if the component is not byte aligned, we
- -- know we have the nasty unaligned case.
-
- elsif Normalized_First_Bit (Comp) /= Uint_0
- or else Esize (Comp) mod System_Storage_Unit /= Uint_0
- then
- return True;
-
- -- If we are large and byte aligned, then OK at this level
- -- but we still need to test our prefix recursively.
-
- else
- return Possible_Bit_Aligned_Component (P);
- end if;
+ return Possible_Bit_Aligned_Component (P);
end if;
end;
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.16
diff -u -p -r1.16 exp_ch6.adb
--- exp_ch6.adb 15 Dec 2003 11:51:00 -0000 1.16
+++ exp_ch6.adb 5 Jan 2004 13:15:41 -0000
@@ -59,7 +59,6 @@ with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
-with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -2989,10 +2988,7 @@ package body Exp_Ch6 is
Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
else
Sec_Stack_Len :=
- Make_Integer_Literal (Loc,
- Intval =>
- Expr_Value
- (Constant_Value (RTE (RE_Default_Secondary_Stack_Size))));
+ New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc);
end if;
Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
@@ -3120,7 +3116,16 @@ package body Exp_Ch6 is
-- If this is a Pure function which has any parameters whose root
-- type is System.Address, reset the Pure indication, since it will
- -- likely cause incorrect code to be generated.
+ -- likely cause incorrect code to be generated as the parameter is
+ -- probably a pointer, and the fact that the same pointer is passed
+ -- does not mean that the same value is being referenced.
+
+ -- Note that if the programmer gave an explicit Pure_Function pragma,
+ -- then we believe the programmer, and leave the subprogram Pure.
+
+ -- This code should probably be at the freeze point, so that it
+ -- happens even on a -gnatc (or more importantly -gnatt) compile
+ -- so that the semantic tree has Is_Pure set properly ???
if Is_Pure (Spec_Id)
and then Is_Subprogram (Spec_Id)
Index: exp_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch7.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_ch7.adb
--- exp_ch7.adb 11 Dec 2003 16:21:39 -0000 1.10
+++ exp_ch7.adb 5 Jan 2004 13:15:41 -0000
@@ -508,7 +508,7 @@ package body Exp_Ch7 is
return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
- Index_List : List_Id := New_List;
+ Index_List : constant List_Id := New_List;
function Free_Component return List_Id;
-- Generate the code to finalize the task or protected subcomponents
@@ -524,7 +524,7 @@ package body Exp_Ch7 is
function Free_Component return List_Id is
Stmts : List_Id := New_List;
Tsk : Node_Id;
- C_Typ : Entity_Id := Component_Type (Typ);
+ C_Typ : constant Entity_Id := Component_Type (Typ);
begin
-- Component type is known to contain tasks or protected objects
@@ -608,8 +608,8 @@ package body Exp_Ch7 is
Loc : constant Source_Ptr := Sloc (N);
Tsk : Node_Id;
Comp : Entity_Id;
- Stmts : List_Id := New_List;
- U_Typ : constant Entity_Id := Underlying_Type (Typ);
+ Stmts : constant List_Id := New_List;
+ U_Typ : constant Entity_Id := Underlying_Type (Typ);
begin
if Has_Discriminants (U_Typ)
@@ -696,13 +696,12 @@ package body Exp_Ch7 is
------------------------------------
procedure Clean_Simple_Protected_Objects (N : Node_Id) is
+ Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N));
+ Stmt : Node_Id := Last (Stmts);
E : Entity_Id;
- Stmts : List_Id := Statements (Handled_Statement_Sequence (N));
- Stmt : Node_Id := Last (Stmts);
begin
E := First_Entity (Current_Scope);
-
while Present (E) loop
if (Ekind (E) = E_Variable
or else Ekind (E) = E_Constant)
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.9
diff -u -p -r1.9 exp_ch9.adb
--- exp_ch9.adb 8 Dec 2003 10:33:15 -0000 1.9
+++ exp_ch9.adb 5 Jan 2004 13:15:41 -0000
@@ -8211,14 +8211,13 @@ package body Exp_Ch9 is
and then Chars (Ritem) = Name_Attach_Handler
then
declare
- Handler : constant Node_Id :=
- First (Pragma_Argument_Associations (Ritem));
- Interrupt : constant Node_Id :=
- Next (Handler);
- Expr : Node_Id := Expression (Interrupt);
+ Handler : constant Node_Id :=
+ First (Pragma_Argument_Associations (Ritem));
- begin
+ Interrupt : constant Node_Id := Next (Handler);
+ Expr : constant Node_Id := Expression (Interrupt);
+ begin
Append_To (Table,
Make_Aggregate (Loc, Expressions => New_List (
Unchecked_Convert_To
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.16
diff -u -p -r1.16 exp_util.adb
--- exp_util.adb 24 Nov 2003 14:27:57 -0000 1.16
+++ exp_util.adb 5 Jan 2004 13:15:42 -0000
@@ -898,6 +898,52 @@ package body Exp_Util is
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
+ ----------------------------------
+ -- Component_May_Be_Bit_Aligned --
+ ----------------------------------
+
+ function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
+ begin
+ -- If no component clause, then everything is fine, since the
+ -- back end never bit-misaligns by default, even if there is
+ -- a pragma Packed for the record.
+
+ if No (Component_Clause (Comp)) then
+ return False;
+ end if;
+
+ -- It is only array and record types that cause trouble
+
+ if not Is_Record_Type (Etype (Comp))
+ and then not Is_Array_Type (Etype (Comp))
+ then
+ return False;
+
+ -- If we know that we have a small (64 bits or less) record
+ -- or bit-packed array, then everything is fine, since the
+ -- back end can handle these cases correctly.
+
+ elsif Esize (Comp) <= 64
+ and then (Is_Record_Type (Etype (Comp))
+ or else Is_Bit_Packed_Array (Etype (Comp)))
+ then
+ return False;
+
+ -- Otherwise if the component is not byte aligned, we
+ -- know we have the nasty unaligned case.
+
+ elsif Normalized_First_Bit (Comp) /= Uint_0
+ or else Esize (Comp) mod System_Storage_Unit /= Uint_0
+ then
+ return True;
+
+ -- If we are large and byte aligned, then OK at this level
+
+ else
+ return False;
+ end if;
+ end Component_May_Be_Bit_Aligned;
+
-------------------------------
-- Convert_To_Actual_Subtype --
-------------------------------
@@ -3876,6 +3922,53 @@ package body Exp_Util is
and then Esize (Left_Typ) = Esize (Right_Typ)
and then Esize (Left_Typ) = Esize (Result_Typ);
end Target_Has_Fixed_Ops;
+
+ ------------------------------------------
+ -- Type_May_Have_Bit_Aligned_Components --
+ ------------------------------------------
+
+ function Type_May_Have_Bit_Aligned_Components
+ (Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- Array type, check component type
+
+ if Is_Array_Type (Typ) then
+ return
+ Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
+
+ -- Record type, check components
+
+ elsif Is_Record_Type (Typ) then
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Typ);
+ while Present (E) loop
+ if Ekind (E) = E_Component
+ or else Ekind (E) = E_Discriminant
+ then
+ if Component_May_Be_Bit_Aligned (E)
+ or else
+ Type_May_Have_Bit_Aligned_Components (Etype (E))
+ then
+ return True;
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return False;
+ end;
+
+ -- Type other than array or record is always OK
+
+ else
+ return False;
+ end if;
+ end Type_May_Have_Bit_Aligned_Components;
----------------------------
-- Wrap_Cleanup_Procedure --
Index: exp_util.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.ads,v
retrieving revision 1.9
diff -u -p -r1.9 exp_util.ads
--- exp_util.ads 21 Oct 2003 13:41:59 -0000 1.9
+++ exp_util.ads 5 Jan 2004 13:15:42 -0000
@@ -208,6 +208,36 @@ package Exp_Util is
-- computes the image without using concatenation, and one for the
-- variable that holds the result.
+ function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
+ -- This function is in charge of detecting record components that may
+ -- cause trouble in the back end if an attempt is made to assign the
+ -- component. The back end can handle such assignments with no problem
+ -- if the components involved are small (64-bits or less) records or
+ -- scalar items (including bit-packed arrays represented with modular
+ -- types) or are both aligned on a byte boundary (starting on a byte
+ -- boundary, and occupying an integral number of bytes).
+ --
+ -- However, problems arise for records larger than 64 bits, or for
+ -- arrays (other than bit-packed arrays represented with a modular
+ -- type) if the component starts on a non-byte boundary, or does
+ -- not occupy an integral number of bytes (i.e. there are some bits
+ -- possibly shared with fields at the start or beginning of the
+ -- component). The back end cannot handle loading and storing such
+ -- components in a single operation.
+ --
+ -- This function is used to detect the troublesome situation. it is
+ -- conservative in the sense that it produces True unless it knows
+ -- for sure that the component is safe (as outlined in the first
+ -- paragraph above). The code generation for record and array
+ -- assignment checks for trouble using this function, and if so
+ -- the assignment is generated component-wise, which the back end
+ -- is required to handle correctly.
+ --
+ -- Note that in GNAT 3, the back end will reject such components
+ -- anyway, so the hard work in checking for this case is wasted
+ -- in GNAT 3, but it's harmless, so it is easier to do it in
+ -- all cases, rather than conditionalize it in GNAT 5 or beyond.
+
procedure Convert_To_Actual_Subtype (Exp : Node_Id);
-- The Etype of an expression is the nominal type of the expression,
-- not the actual subtype. Often these are the same, but not always.
@@ -511,6 +541,14 @@ package Exp_Util is
-- for fixed-by-fixed multiplications and divisions for the given
-- operand and result types. This is called in package Exp_Fixd to
-- determine whether to expand such operations.
+
+ function Type_May_Have_Bit_Aligned_Components
+ (Typ : Entity_Id) return Boolean;
+ -- Determines if Typ is a composite type that has within it (looking
+ -- down recursively at any subcomponents), a record type which has a
+ -- component that may be bit aligned (see Possible_Bit_Aligned_Component).
+ -- The result is conservative, in that a result of False is decisive.
+ -- A result of True means that such a component may or may not be present.
procedure Wrap_Cleanup_Procedure (N : Node_Id);
-- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer
Index: fe.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fe.h,v
retrieving revision 1.5
diff -u -p -r1.5 fe.h
--- fe.h 21 Oct 2003 13:41:59 -0000 1.5
+++ fe.h 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
* *
* C Header 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- *
@@ -86,7 +86,7 @@ extern Node_Id Get_Attribute_Definition_
extern void Error_Msg_N (Fat_Pointer, Node_Id);
extern void Error_Msg_NE (Fat_Pointer, Node_Id, Entity_Id);
-extern void Set_Identifier_Casing (Char, Char);
+extern void Set_Identifier_Casing (Char *, Char *);
/* err_vars: */
@@ -98,7 +98,6 @@ extern Entity_Id Error_Msg_N
extern Uint Error_Msg_Uint_1;
extern Uint Error_Msg_Uint_2;
-
/* exp_code: */
#define Asm_Input_Constraint exp_code__asm_input_constraint
@@ -168,6 +167,12 @@ extern Boolean No_Exception_Handlers_Set
extern void Check_No_Implicit_Heap_Alloc (Node_Id);
extern void Check_Elaboration_Code_Allowed (Node_Id);
extern void Check_No_Implicit_Heap_Alloc (Node_Id);
+
+/* sem_elim: */
+
+#define Eliminate_Error_Msg sem_elim__eliminate_error_msg
+
+extern void Eliminate_Error_Msg (Node_Id, Entity_Id);
/* sem_eval: */
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.10
diff -u -p -r1.10 freeze.adb
--- freeze.adb 17 Nov 2003 14:58:15 -0000 1.10
+++ freeze.adb 5 Jan 2004 13:15:42 -0000
@@ -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- --
@@ -2130,14 +2130,21 @@ package body Freeze is
-- inherited the indication from elsewhere (e.g. an address
-- clause, which is not good enough in RM terms!)
- if Present (Get_Rep_Pragma (E, Name_Atomic)) or else
- Present (Get_Rep_Pragma (E, Name_Atomic_Components)) or else
- Present (Get_Rep_Pragma (E, Name_Volatile)) or else
- Present (Get_Rep_Pragma (E, Name_Volatile_Components))
+ if Present (Get_Rep_Pragma (E, Name_Atomic))
+ or else
+ Present (Get_Rep_Pragma (E, Name_Atomic_Components))
then
Error_Msg_N
- ("stand alone atomic/volatile constant must be imported",
- E);
+ ("stand alone atomic constant must be " &
+ "imported ('R'M 'C.6(13))", E);
+
+ elsif Present (Get_Rep_Pragma (E, Name_Volatile))
+ or else
+ Present (Get_Rep_Pragma (E, Name_Volatile_Components))
+ then
+ Error_Msg_N
+ ("stand alone volatile constant must be " &
+ "imported ('R'M 'C.6(13))", E);
end if;
end if;
@@ -4171,6 +4178,20 @@ package body Freeze is
"for imported subprogram",
Name (Address_Clause (E)));
end if;
+ end if;
+
+ -- Reset the Pure indication on an imported subprogram unless an
+ -- explicit Pure_Function pragma was present. We do this because
+ -- otherwise it is an insidious error to call a non-pure function
+ -- from a pure unit and have calls mysteriously optimized away.
+ -- What happens here is that the Import can bypass the normal
+ -- check to ensure that pure units call only pure subprograms.
+
+ if Is_Imported (E)
+ and then Is_Pure (E)
+ and then not Has_Pragma_Pure_Function (E)
+ then
+ Set_Is_Pure (E, False);
end if;
-- For non-foreign convention subprograms, this is where we create
Index: g-debuti.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-debuti.adb,v
retrieving revision 1.5
diff -u -p -r1.5 g-debuti.adb
--- g-debuti.adb 17 Nov 2003 14:58:15 -0000 1.5
+++ g-debuti.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-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- --
@@ -153,7 +153,7 @@ package body GNAT.Debug_Utilities is
-- Ada form based literal
- elsif C = '#' or C = ':' then
+ elsif C = '#' or else C = ':' then
Base := Res;
Res := 0;
Index: g-dirope.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-dirope.adb,v
retrieving revision 1.12
diff -u -p -r1.12 g-dirope.adb
--- g-dirope.adb 27 Oct 2003 14:27:17 -0000 1.12
+++ g-dirope.adb 5 Jan 2004 13:15:42 -0000
@@ -60,8 +60,7 @@ package body GNAT.Directory_Operations i
function Base_Name
(Path : Path_Name;
- Suffix : String := "")
- return String
+ Suffix : String := "") return String
is
function Get_File_Names_Case_Sensitive return Integer;
pragma Import
@@ -73,8 +72,7 @@ package body GNAT.Directory_Operations i
function Basename
(Path : Path_Name;
- Suffix : String := "")
- return String;
+ Suffix : String := "") return String;
-- This function does the job. The only difference between Basename
-- and Base_Name (the parent function) is that the former is case
-- sensitive, while the latter is not. Path and Suffix are adjusted
@@ -87,8 +85,7 @@ package body GNAT.Directory_Operations i
function Basename
(Path : Path_Name;
- Suffix : String := "")
- return String
+ Suffix : String := "") return String
is
Cut_Start : Natural :=
Strings.Fixed.Index
@@ -227,8 +224,7 @@ package body GNAT.Directory_Operations i
function Expand_Path
(Path : Path_Name;
- Mode : Environment_Style := System_Default)
- return Path_Name
+ Mode : Environment_Style := System_Default) return Path_Name
is
Environment_Variable_Char : Character;
pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
@@ -519,8 +515,7 @@ package body GNAT.Directory_Operations i
function Format_Pathname
(Path : Path_Name;
- Style : Path_Style := System_Default)
- return String
+ Style : Path_Style := System_Default) return String
is
N_Path : String := Path;
K : Positive := N_Path'First;
@@ -636,8 +631,7 @@ package body GNAT.Directory_Operations i
C_File_Name : constant String := Dir_Name & ASCII.NUL;
function opendir
- (File_Name : String)
- return Dir_Type_Value;
+ (File_Name : String) return Dir_Type_Value;
pragma Import (C, opendir, "opendir");
begin
@@ -668,8 +662,7 @@ package body GNAT.Directory_Operations i
function readdir_gnat
(Directory : System.Address;
- Buffer : System.Address)
- return System.Address;
+ Buffer : System.Address) return System.Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
function strlen (S : Address) return Integer;
Index: g-dirope.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-dirope.ads,v
retrieving revision 1.6
diff -u -p -r1.6 g-dirope.ads
--- g-dirope.ads 21 Oct 2003 13:42:00 -0000 1.6
+++ g-dirope.ads 5 Jan 2004 13:15:42 -0000
@@ -122,8 +122,7 @@ package GNAT.Directory_Operations is
function Base_Name
(Path : Path_Name;
- Suffix : String := "")
- return String;
+ Suffix : String := "") return String;
-- Any directory prefix is removed. If Suffix is non-empty and is a
-- suffix of Path, it is removed. This is equivalent to the UNIX basename
-- command. The following rule is always true:
@@ -158,8 +157,7 @@ package GNAT.Directory_Operations is
function Format_Pathname
(Path : Path_Name;
- Style : Path_Style := System_Default)
- return Path_Name;
+ Style : Path_Style := System_Default) return Path_Name;
-- Removes all double directory separator and converts all '\' to '/' if
-- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This
-- function will help to provide a consistent naming scheme running for
@@ -187,8 +185,7 @@ package GNAT.Directory_Operations is
function Expand_Path
(Path : Path_Name;
- Mode : Environment_Style := System_Default)
- return Path_Name;
+ Mode : Environment_Style := System_Default) return Path_Name;
-- Returns Path with environment variables (or logical names on OpenVMS)
-- replaced by the current environment variable value. For example,
-- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment
Index: gnat1drv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat1drv.adb,v
retrieving revision 1.9
diff -u -p -r1.9 gnat1drv.adb
--- gnat1drv.adb 10 Nov 2003 17:29:59 -0000 1.9
+++ gnat1drv.adb 5 Jan 2004 13:15:42 -0000
@@ -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- --
@@ -78,9 +78,6 @@ procedure Gnat1drv is
Main_Unit_Node : Node_Id;
-- Compilation unit node for main unit
- Main_Unit_Entity : Node_Id;
- -- Compilation unit entity for main unit
-
Main_Kind : Node_Kind;
-- Kind of main compilation unit node.
@@ -193,7 +190,7 @@ begin
Write_Eol;
Write_Str ("GNAT ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1992-2003 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1992-2004 Free Software Foundation, Inc.");
Write_Eol;
end if;
@@ -277,7 +274,6 @@ begin
Original_Operating_Mode := Operating_Mode;
Frontend;
Main_Unit_Node := Cunit (Main_Unit);
- Main_Unit_Entity := Cunit_Entity (Main_Unit);
Main_Kind := Nkind (Unit (Main_Unit_Node));
-- Check for suspicious or incorrect body present if we are doing
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.8
diff -u -p -r1.8 gnatbind.adb
--- gnatbind.adb 8 Dec 2003 10:33:15 -0000 1.8
+++ gnatbind.adb 5 Jan 2004 13:15:42 -0000
@@ -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- --
@@ -379,7 +379,7 @@ begin
Write_Eol;
Write_Str ("GNATBIND ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc.");
Write_Eol;
end if;
Index: gnatchop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatchop.adb,v
retrieving revision 1.11
diff -u -p -r1.11 gnatchop.adb
--- gnatchop.adb 15 Dec 2003 11:51:00 -0000 1.11
+++ gnatchop.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-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- --
@@ -375,7 +375,8 @@ procedure Gnatchop is
if not Is_Duplicated (SNum) then
declare
- Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum));
+ Info : constant Unit_Info :=
+ Unit.Table (Sorted_Units.Table (SNum));
begin
if Is_Writable_File (Info.File_Name.all) then
@@ -587,10 +588,10 @@ procedure Gnatchop is
----------------
function Parse_File (Num : File_Num) return Boolean is
- Chop_Name : constant String_Access := File.Table (Num).Name;
+ Chop_Name : constant String_Access := File.Table (Num).Name;
+ Save_Stdout : constant File_Descriptor := dup (Standout);
Offset_Name : Temp_File_Name;
Offset_FD : File_Descriptor;
- Save_Stdout : File_Descriptor := dup (Standout);
Buffer : String_Access;
Success : Boolean;
Failure : exception;
@@ -690,9 +691,9 @@ procedure Gnatchop is
(Chop_File : File_Num;
Source : access String)
is
- First_Unit : Unit_Num := Unit.Last + 1;
- Bufferg : String_Access := null;
- Parse_Ptr : File_Offset := Source'First;
+ First_Unit : constant Unit_Num := Unit.Last + 1;
+ Bufferg : String_Access := null;
+ Parse_Ptr : File_Offset := Source'First;
Token_Ptr : File_Offset;
Info : Unit_Info;
@@ -1147,7 +1148,7 @@ procedure Gnatchop is
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
Put_Line
(Standard_Error,
- " Copyright 1998-2000, Ada Core Technologies Inc.");
+ " Copyright 1998-2004, Ada Core Technologies Inc.");
when 'w' =>
Overwrite_Files := True;
@@ -1736,7 +1737,7 @@ begin
if Warning_Count > 0 then
declare
- Warnings_Msg : String := Warning_Count'Img & " warning(s)";
+ Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
begin
Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
end;
Index: gnatfind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatfind.adb,v
retrieving revision 1.6
diff -u -p -r1.6 gnatfind.adb
--- gnatfind.adb 21 Oct 2003 13:42:07 -0000 1.6
+++ gnatfind.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -24,10 +24,10 @@
-- --
------------------------------------------------------------------------------
-with Xr_Tabls; use Xr_Tabls;
-with Xref_Lib; use Xref_Lib;
-with Osint; use Osint;
-with Types; use Types;
+with Xr_Tabls; use Xr_Tabls;
+with Xref_Lib; use Xref_Lib;
+with Osint; use Osint;
+with Types; use Types;
with Gnatvsn;
with Opt;
@@ -41,7 +41,6 @@ with GNAT.Strings; use GNAT.Strings
---------------
procedure Gnatfind is
-
Output_Ref : Boolean := False;
Pattern : Xref_Lib.Search_Pattern;
Local_Symbols : Boolean := True;
@@ -240,7 +239,7 @@ procedure Gnatfind is
procedure Write_Usage is
begin
Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String
- & " Copyright 1998-2003, Ada Core Technologies Inc.");
+ & " Copyright 1998-2004, Ada Core Technologies Inc.");
Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] "
& "[file1 file2 ...]");
New_Line;
Index: gnatlbr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlbr.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnatlbr.adb
--- gnatlbr.adb 3 Dec 2003 11:47:52 -0000 1.10
+++ gnatlbr.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
@@ -77,10 +77,9 @@ begin
exit when Next_Arg > Argument_Count;
Process_One_Arg : declare
- Arg : String := Argument (Next_Arg);
+ Arg : constant String := Argument (Next_Arg);
begin
-
if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then
if Mode = None then
Mode := Create;
@@ -192,28 +191,29 @@ begin
--
Include_Dirs := 0;
Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
- Get_Next_Dir_In_Path_Init (String_Access (Include_Dir_Name));
+ Get_Next_Dir_In_Path_Init (Include_Dir_Name);
loop
declare
- Dir : String_Access := String_Access
- (Get_Next_Dir_In_Path (String_Access (Include_Dir_Name)));
+ Dir : constant String_Access := String_Access
+ (Get_Next_Dir_In_Path (Include_Dir_Name));
begin
exit when Dir = null;
Include_Dirs := Include_Dirs + 1;
- Include_Dir (Include_Dirs)
- := String_Access (Normalize_Directory_Name (Dir.all));
+ Include_Dir (Include_Dirs) :=
+ String_Access (Normalize_Directory_Name (Dir.all));
end;
end loop;
Object_Dirs := 0;
Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
- Get_Next_Dir_In_Path_Init (String_Access (Object_Dir_Name));
+ Get_Next_Dir_In_Path_Init (Object_Dir_Name);
loop
declare
- Dir : String_Access := String_Access
- (Get_Next_Dir_In_Path (String_Access (Object_Dir_Name)));
+ Dir : constant String_Access :=
+ String_Access
+ (Get_Next_Dir_In_Path (Object_Dir_Name));
begin
exit when Dir = null;
Object_Dirs := Object_Dirs + 1;
@@ -225,7 +225,6 @@ begin
-- "Make" an alternate sublibrary for each default sublibrary.
for Dirs in 1 .. Object_Dirs loop
-
Make_Args (1) :=
new String'("-C");
@@ -269,13 +268,14 @@ begin
Make_Path := Locate_Exec_On_Path (Make);
Put (Make);
- for I in 1 .. Make_Args'Last loop
+ for J in 1 .. Make_Args'Last loop
Put (" ");
- Put (Make_Args (I).all);
+ Put (Make_Args (J).all);
end loop;
New_Line;
Spawn (Make_Path.all, Make_Args, Success);
+
if not Success then
Put_Line (Standard_Error, "Error: Make failed");
Exit_Program (E_Fatal);
@@ -285,7 +285,7 @@ begin
when Set =>
- -- Validate arguments.
+ -- Validate arguments
if Lib_Dir = null then
Put_Line (Standard_Error,
@@ -311,7 +311,7 @@ begin
Exit_Program (E_Fatal);
end if;
- -- Give instructions.
+ -- Give instructions
Put_Line ("Copy the contents of "
& ADC_File.all & " into your GNAT.ADC file");
@@ -332,7 +332,7 @@ begin
when Delete =>
- -- Give instructions.
+ -- Give instructions
Put_Line ("GNAT Librarian DELETE not yet implemented.");
Put_Line ("Use appropriate system tools to remove library");
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.11
diff -u -p -r1.11 gnatlink.adb
--- gnatlink.adb 15 Dec 2003 11:51:00 -0000 1.11
+++ gnatlink.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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,7 +26,6 @@
-- Gnatlink usage: please consult the gnat documentation
-with Ada.Exceptions; use Ada.Exceptions;
with ALI; use ALI;
with Gnatvsn; use Gnatvsn;
with Hostparm;
@@ -40,6 +39,7 @@ with Table;
with Types;
with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Exceptions; use Ada.Exceptions;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.CRTL;
@@ -234,9 +234,10 @@ procedure Gnatlink is
procedure Delete (Name : in String) is
Status : int;
-
+ pragma Unreferenced (Status);
begin
Status := unlink (Name'Address);
+ -- Is it really right to ignore an error here ???
end Delete;
---------------
@@ -602,6 +603,9 @@ procedure Gnatlink is
Nfirst : Integer;
-- Current line slice (the slice does not contain line terminator)
+ Last : Integer;
+ -- Current line last character for shared libraries (without version)
+
Objs_Begin : Integer := 0;
-- First object file index in Linker_Objects table
@@ -986,20 +990,45 @@ procedure Gnatlink is
elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat"
or else Next_Line (Nfirst .. Nlast) = "-lgnarl"
or else Next_Line (Nfirst .. Nlast) = "-lgnat"
+ or else Next_Line
+ (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) =
+ Shared_Lib ("gnarl")
+ or else Next_Line
+ (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) =
+ Shared_Lib ("gnat")
then
+ -- If it is a shared library, remove the library version.
+ -- We will be looking for the static version of the library
+ -- as it is in the same directory as the shared version.
+
+ if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast)
+ = Library_Version
+ then
+ -- Set Last to point to last character before the
+ -- library version.
+
+ Last := Nlast - Library_Version'Length - 1;
+ else
+ Last := Nlast;
+ end if;
+
-- Given a Gnat standard library, search the
-- library path to find the library location
declare
File_Path : String_Access;
+
Object_Lib_Extension : constant String :=
- Value (Object_Library_Ext_Ptr);
+ Value (Object_Library_Ext_Ptr);
+
File_Name : constant String := "lib" &
- Next_Line (Nfirst + 2 .. Nlast) &
- Object_Lib_Extension;
+ Next_Line (Nfirst + 2 .. Last) &
+ Object_Lib_Extension;
+
Run_Path_Opt : constant String :=
Value (Run_Path_Option_Ptr);
- GCC_Index : Natural;
+
+ GCC_Index : Natural;
Run_Path_Opt_Index : Natural := 0;
begin
@@ -1189,7 +1218,7 @@ procedure Gnatlink is
Write_Eol;
Write_Str ("GNATLINK ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc");
+ Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc");
Write_Eol;
end if;
end Write_Header;
@@ -1586,7 +1615,7 @@ begin
-- Remove duplicate IDENTIFICATION directives (VMS)
if Linker_Options.Table (J)'Length > 27
- and then Linker_Options.Table (J) (1 .. 27)
+ and then Linker_Options.Table (J) (1 .. 28)
= "--for-linker=IDENTIFICATION="
then
if IDENT_Op then
Index: gnatls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatls.adb,v
retrieving revision 1.11
diff -u -p -r1.11 gnatls.adb
--- gnatls.adb 24 Oct 2003 14:39:55 -0000 1.11
+++ gnatls.adb 5 Jan 2004 13:15:42 -0000
@@ -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- --
@@ -75,11 +75,8 @@ procedure Gnatls is
Main_File : File_Name_Type;
Ali_File : File_Name_Type;
-
- Text : Text_Buffer_Ptr;
- Id : ALI_Id;
-
- Next_Arg : Positive;
+ Text : Text_Buffer_Ptr;
+ Next_Arg : Positive;
Too_Long : Boolean := False;
-- When True, lines are too long for multi-column output and each
@@ -219,9 +216,8 @@ procedure Gnatls is
------------------------------
function Corresponding_Sdep_Entry
- (A : ALI_Id;
- U : Unit_Id)
- return Sdep_Id
+ (A : ALI_Id;
+ U : Unit_Id) return Sdep_Id
is
begin
for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
@@ -253,7 +249,6 @@ procedure Gnatls is
-- Compute maximum of each column
for Id in ALIs.First .. ALIs.Last loop
-
Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
if Also_Predef or else not Is_Internal_Unit then
@@ -829,7 +824,6 @@ begin
Scan_Args : while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
-
begin
Fill_Arg (Next_Argv'Address, Next_Arg);
Scan_Ls_Arg (Next_Argv, And_Save => True);
@@ -866,7 +860,7 @@ begin
Write_Eol;
Write_Str ("GNATLS ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1997-2003 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1997-2004 Free Software Foundation, Inc.");
Write_Eol;
Write_Eol;
Write_Str ("Source Search Path:");
@@ -942,9 +936,16 @@ begin
if Get_Name_Table_Info (Ali_File) = 0 then
Text := Read_Library_Info (Ali_File, True);
- Id :=
- Scan_ALI
- (Ali_File, Text, Ignore_ED => False, Err => False);
+
+ declare
+ Discard : ALI_Id;
+ pragma Unreferenced (Discard);
+ begin
+ Discard :=
+ Scan_ALI
+ (Ali_File, Text, Ignore_ED => False, Err => False);
+ end;
+
Free (Text);
end if;
end if;
@@ -1029,9 +1030,8 @@ begin
end;
end loop;
- -- All done. Set proper exit status.
+ -- All done. Set proper exit status
Namet.Finalize;
Exit_Program (E_Success);
-
end Gnatls;
Index: gnatmem.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatmem.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnatmem.adb
--- gnatmem.adb 20 Nov 2003 09:53:58 -0000 1.10
+++ gnatmem.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2003, Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-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- --
@@ -53,14 +53,18 @@
-- execution generating memory allocation where data is collected (such as
-- number of allocations, amount of memory allocated, high water mark, etc.)
-with GNAT.Command_Line; use GNAT.Command_Line;
+with Gnatvsn; use Gnatvsn;
+
+
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Float_Text_IO;
with Ada.Integer_Text_IO;
-with Gnatvsn; use Gnatvsn;
+
+with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Heap_Sort_G;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.HTable; use GNAT.HTable;
+
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
@@ -230,7 +234,7 @@ procedure Gnatmem is
New_Line;
Put ("GNATMEM ");
Put (Gnat_Version_String);
- Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc.");
+ Put_Line (" Copyright 1997-2004 Free Software Foundation, Inc.");
New_Line;
Put_Line ("Usage: gnatmem switches [depth] exename");
@@ -287,20 +291,20 @@ procedure Gnatmem is
when 's' =>
declare
- S : String (Sort_Order'Range) := Parameter;
+ S : constant String (Sort_Order'Range) := Parameter;
+
begin
for J in Sort_Order'Range loop
- if S (J) = 'n' or else S (J) = 'w'
- or else S (J) = 'h' then
+ if S (J) = 'n' or else
+ S (J) = 'w' or else
+ S (J) = 'h'
+ then
Sort_Order (J) := S (J);
else
- raise Constraint_Error;
+ Put_Line ("Invalid sort criteria string.");
+ GNAT.OS_Lib.OS_Exit (1);
end if;
end loop;
- exception
- when Constraint_Error =>
- Put_Line ("Invalid sort criteria string.");
- GNAT.OS_Lib.OS_Exit (1);
end;
when others =>
@@ -606,6 +610,8 @@ begin
end Apply_Sort_Criterion;
Result : Integer;
+
+ -- Start of processing for Lt
begin
for S in Sort_Order'Range loop
Index: gnatname.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatname.adb,v
retrieving revision 1.5
diff -u -p -r1.5 gnatname.adb
--- gnatname.adb 21 Oct 2003 13:42:08 -0000 1.5
+++ gnatname.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -66,7 +66,7 @@ procedure Gnatname is
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Gnatname.Excluded_Patterns");
- -- Table to accumulate the negative patterns.
+ -- Table to accumulate the negative patterns
package Foreign_Patterns is new Table.Table
(Table_Component_Type => String_Access,
@@ -75,7 +75,7 @@ procedure Gnatname is
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Gnatname.Foreign_Patterns");
- -- Table to accumulate the foreign patterns.
+ -- Table to accumulate the foreign patterns
package Patterns is new Table.Table
(Table_Component_Type => String_Access,
@@ -84,7 +84,7 @@ procedure Gnatname is
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Gnatname.Patterns");
- -- Table to accumulate the name patterns.
+ -- Table to accumulate the name patterns
package Source_Directories is new Table.Table
(Table_Component_Type => String_Access,
@@ -170,7 +170,7 @@ procedure Gnatname is
Output.Write_Str ("GNATNAME ");
Output.Write_Str (Gnatvsn.Gnat_Version_String);
Output.Write_Line
- (" Copyright 2001-2003 Free Software Foundation, Inc.");
+ (" Copyright 2001-2004 Free Software Foundation, Inc.");
end if;
end Output_Version;
@@ -261,7 +261,6 @@ procedure Gnatname is
exception
when Invalid_Switch =>
Fail ("invalid switch " & Full_Switch);
-
end Scan_Args;
-----------
Index: gnatsym.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatsym.adb,v
retrieving revision 1.2
diff -u -p -r1.2 gnatsym.adb
--- gnatsym.adb 20 Nov 2003 09:53:58 -0000 1.2
+++ gnatsym.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
@@ -55,7 +55,7 @@ with Table;
procedure Gnatsym is
Empty_String : aliased String := "";
- Empty : constant String_Access := Empty_String'Unchecked_Access;
+ Empty : constant String_Access := Empty_String'Unchecked_Access;
-- To initialize variables Reference and Version_String
Copyright_Displayed : Boolean := False;
@@ -111,7 +111,7 @@ procedure Gnatsym is
Write_Eol;
Write_Str ("GNATSYMB ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 2003 Free Software Foundation, Inc");
+ Write_Str (" Copyright 2003-2004 Free Software Foundation, Inc");
Write_Eol;
Copyright_Displayed := True;
end if;
@@ -224,8 +224,7 @@ begin
Write_Line ("""");
end if;
- -- Initialize the symbol file and, if specified, read the reference
- -- file.
+ -- Initialize symbol file and, if specified, read reference file
Symbols.Initialize
(Symbol_File => Symbol_File_Name.all,
Index: gnatxref.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatxref.adb,v
retrieving revision 1.7
diff -u -p -r1.7 gnatxref.adb
--- gnatxref.adb 21 Nov 2003 10:46:37 -0000 1.7
+++ gnatxref.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -72,7 +72,7 @@ procedure Gnatxref is
when ASCII.NUL =>
exit;
- when 'a' =>
+ when 'a' =>
if GNAT.Command_Line.Full_Switch = "a" then
Read_Only := True;
@@ -83,49 +83,49 @@ procedure Gnatxref is
Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
end if;
- when 'd' =>
+ when 'd' =>
Der_Info := True;
- when 'f' =>
+ when 'f' =>
Full_Path_Name := True;
- when 'g' =>
+ when 'g' =>
Local_Symbols := False;
- when 'h' =>
+ when 'h' =>
Write_Usage;
- when 'I' =>
+ when 'I' =>
Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
- when 'n' =>
+ when 'n' =>
if GNAT.Command_Line.Full_Switch = "nostdinc" then
Opt.No_Stdinc := True;
elsif GNAT.Command_Line.Full_Switch = "nostlib" then
Opt.No_Stdlib := True;
end if;
- when 'p' =>
+ when 'p' =>
declare
S : constant String := GNAT.Command_Line.Parameter;
-
begin
Prj_File_Length := S'Length;
Prj_File (1 .. Prj_File_Length) := S;
end;
- when 'u' =>
+ when 'u' =>
Search_Unused := True;
Vi_Mode := False;
- when 'v' =>
+ when 'v' =>
Vi_Mode := True;
Search_Unused := False;
-- The only switch starting with -- recognized is --RTS
- when '-' =>
+ when '-' =>
+
-- Check that it is the first time we see this switch
if RTS_Specified = null then
@@ -210,7 +210,7 @@ procedure Gnatxref is
procedure Write_Usage is
begin
Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String
- & " Copyright 1998-2003, Ada Core Technologies Inc.");
+ & " Copyright 1998-2004, Ada Core Technologies Inc.");
Put_Line ("Usage: gnatxref [switches] file1 file2 ...");
New_Line;
Put_Line (" file ... list of source files to xref, " &
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.4
diff -u -p -r1.4 gprcmd.adb
--- gprcmd.adb 21 Nov 2003 10:46:37 -0000 1.4
+++ gprcmd.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -249,7 +249,7 @@ procedure Gprcmd is
procedure Extend (Dir : String) is
procedure Recursive_Extend (D : String);
- -- Recursively display all subdirectories of D.
+ -- Recursively display all subdirectories of D
----------------------
-- Recursive_Extend --
@@ -355,7 +355,7 @@ begin
Put (Standard_Error, "GPRCMD ");
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
Put_Line (Standard_Error,
- " Copyright 2002-2003, Free Software Fundation, Inc.");
+ " Copyright 2002-2004, Free Software Fundation, Inc.");
Usage;
elsif Cmd = "pwd" then
@@ -437,8 +437,8 @@ begin
Find_Program_Name;
declare
- Path : String_Access :=
- Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
+ Path : constant String_Access :=
+ Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
Index : Natural;
begin
@@ -454,7 +454,7 @@ begin
and then Path (Index - 3 .. Index - 1) = "bin"
and then Path (Index - 4) = Directory_Separator
then
- -- We have found the <prefix>, return it.
+ -- We have found the <prefix>, return it
Put (Path (Path'First .. Index - 5));
end if;
Index: gprep.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprep.adb,v
retrieving revision 1.1
diff -u -p -r1.1 gprep.adb
--- gprep.adb 21 Oct 2003 13:42:08 -0000 1.1
+++ gprep.adb 5 Jan 2004 13:15:42 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -24,8 +24,6 @@
-- --
------------------------------------------------------------------------------
-with Ada.Text_IO; use Ada.Text_IO;
-
with Csets;
with Err_Vars; use Err_Vars;
with Errutil;
@@ -41,8 +39,9 @@ with Snames;
with Stringt; use Stringt;
with Types; use Types;
+with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GPrep is
@@ -57,11 +56,11 @@ package body GPrep is
Outfile_Name : String_Access;
Deffile_Name : String_Access;
- Source_Ref_Pragma : Boolean := False; -- Set if -r switch set
- -- Record command line options
+ Source_Ref_Pragma : Boolean := False;
+ -- Record command line options (set if -r switch set)
Text_Outfile : aliased Ada.Text_IO.File_Type;
- Outfile : File_Access := Text_Outfile'Access;
+ Outfile : constant File_Access := Text_Outfile'Access;
-----------------
-- Subprograms --
@@ -87,11 +86,11 @@ package body GPrep is
procedure Put_Char_To_Outfile (C : Character);
-- Output one character to the output file.
- -- Used to initialize the preprocessor..
+ -- Used to initialize the preprocessor.
procedure New_EOL_To_Outfile;
-- Output a new line to the output file.
- -- used to initialize the preprocessor.
+ -- Used to initialize the preprocessor.
procedure Scan_Command_Line;
-- Scan the switches and the file names
@@ -108,7 +107,7 @@ package body GPrep is
if not Copyright_Displayed then
Write_Line ("GNAT Preprocessor " &
Gnatvsn.Gnat_Version_String &
- " Copyright 1996-2003 Free Software Foundation, Inc.");
+ " Copyright 1996-2004 Free Software Foundation, Inc.");
Copyright_Displayed := True;
end if;
end Display_Copyright;
Index: i-cstrea.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/i-cstrea.adb,v
retrieving revision 1.5
diff -u -p -r1.5 i-cstrea.adb
--- i-cstrea.adb 15 Dec 2003 11:51:00 -0000 1.5
+++ i-cstrea.adb 5 Jan 2004 13:15:42 -0000
@@ -41,6 +41,31 @@ package body Interfaces.C_Streams is
use type System.CRTL.size_t;
+ ----------------------------
+ -- Interfaced C functions --
+ ----------------------------
+
+ function C_fread
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t;
+ pragma Import (C, C_fread, "fread");
+
+ function C_fwrite
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t;
+ pragma Import (C, C_fwrite, "fwrite");
+
+ function C_setvbuf
+ (stream : FILEs;
+ buffer : chars;
+ mode : int;
+ size : size_t) return int;
+ pragma Import (C, C_setvbuf, "setvbuf");
+
------------
-- fread --
------------
@@ -49,17 +74,8 @@ package body Interfaces.C_Streams is
(buffer : voids;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
- function C_fread
- (buffer : voids;
- size : size_t;
- count : size_t;
- stream : FILEs)
- return size_t;
- pragma Import (C, C_fread, "fread");
-
begin
return C_fread (buffer, size, count, stream);
end fread;
@@ -68,31 +84,25 @@ package body Interfaces.C_Streams is
-- fread --
------------
+ -- The following declarations should really be nested within fread, but
+ -- limitations in front end inlining make this undesirable right now ???
+
+ type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8;
+ -- This should really be 0 .. size_t'last, but there is a problem
+ -- in gigi in handling such types (introduced in GCC 3 Sep 2001)
+ -- since the size in bytes of this array overflows ???
+
+ type Acc_Bytes is access all Byte_Buffer;
+
+ function To_Acc_Bytes is new Unchecked_Conversion (voids, Acc_Bytes);
+
function fread
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
- function C_fread
- (buffer : voids;
- size : size_t;
- count : size_t;
- stream : FILEs)
- return size_t;
- pragma Import (C, C_fread, "fread");
-
- type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8;
- -- This should really be 0 .. size_t'last, but there is a problem
- -- in gigi in handling such types (introduced in GCC 3 Sep 2001)
- -- since the size in bytes of this array overflows ???
-
- type Acc_Bytes is access all Byte_Buffer;
-
- function To_Acc_Bytes is new Unchecked_Conversion (voids, Acc_Bytes);
-
begin
return C_fread
(To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream);
@@ -106,17 +116,8 @@ package body Interfaces.C_Streams is
(buffer : voids;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
- function C_fwrite
- (buffer : voids;
- size : size_t;
- count : size_t;
- stream : FILEs)
- return size_t;
- pragma Import (C, C_fwrite, "fwrite");
-
begin
return C_fwrite (buffer, size, count, stream);
end fwrite;
@@ -129,17 +130,8 @@ package body Interfaces.C_Streams is
(stream : FILEs;
buffer : chars;
mode : int;
- size : size_t)
- return int
+ size : size_t) return int
is
- function C_setvbuf
- (stream : FILEs;
- buffer : chars;
- mode : int;
- size : size_t)
- return int;
- pragma Import (C, C_setvbuf, "setvbuf");
-
begin
return C_setvbuf (stream, buffer, mode, size);
end setvbuf;
Index: inline.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/inline.adb,v
retrieving revision 1.7
diff -u -p -r1.7 inline.adb
--- inline.adb 21 Oct 2003 13:42:09 -0000 1.7
+++ inline.adb 5 Jan 2004 13:15:42 -0000
@@ -370,7 +370,7 @@ package body Inline is
----------------------------
function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
- Decl : Node_Id := Unit_Declaration_Node (Subp);
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Body_Ent : Entity_Id;
Ent : Entity_Id;
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.11
diff -u -p -r1.11 lib-writ.adb
--- lib-writ.adb 3 Dec 2003 11:47:52 -0000 1.11
+++ lib-writ.adb 5 Jan 2004 13:15:42 -0000
@@ -881,6 +881,10 @@ package body Lib.Writ is
Write_Info_Str (" NS");
end if;
+ if Sec_Stack_Used then
+ Write_Info_Str (" SS");
+ end if;
+
if Unreserve_All_Interrupts then
Write_Info_Str (" UA");
end if;
Index: lib-writ.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.ads,v
retrieving revision 1.8
diff -u -p -r1.8 lib-writ.ads
--- lib-writ.ads 21 Oct 2003 13:42:09 -0000 1.8
+++ lib-writ.ads 5 Jan 2004 13:15:42 -0000
@@ -176,6 +176,9 @@ package Lib.Writ is
-- compiler, but is added by the Project Manager in gnatmake
-- when an Interface ALI file is copied to the library
-- directory.
+
+ -- SS This unit references System.Secondary_Stack (that is,
+ -- the unit makes use of the secondary stack facilities).
--
-- Tx A valid Task_Dispatching_Policy pragma applies to all
-- the units in this file, where x is the first character
Index: lib-xref.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-xref.adb,v
retrieving revision 1.11
diff -u -p -r1.11 lib-xref.adb
--- lib-xref.adb 21 Oct 2003 13:42:09 -0000 1.11
+++ lib-xref.adb 5 Jan 2004 13:15:43 -0000
@@ -776,9 +776,8 @@ package body Lib.Xref is
and then Ent = Base_Type (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
-
declare
- Op_List : Elist_Id := Primitive_Operations (Ent);
+ Op_List : constant Elist_Id := Primitive_Operations (Ent);
Op : Elmt_Id;
Prim : Entity_Id;
@@ -787,11 +786,10 @@ package body Lib.Xref is
-- through several derivations.
function Parent_Op (E : Entity_Id) return Entity_Id is
- Orig_Op : Entity_Id := Alias (E);
+ Orig_Op : constant Entity_Id := Alias (E);
begin
if No (Orig_Op) then
return Empty;
-
elsif not Comes_From_Source (E)
and then not Has_Xref_Entry (Orig_Op)
and then Comes_From_Source (Orig_Op)
@@ -804,9 +802,7 @@ package body Lib.Xref is
begin
Op := First_Elmt (Op_List);
-
while Present (Op) loop
-
Prim := Parent_Op (Node (Op));
if Present (Prim) then
Index: link.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/link.c,v
retrieving revision 1.6
diff -u -p -r1.6 link.c
--- link.c 18 Nov 2003 10:00:43 -0000 1.6
+++ link.c 5 Jan 2004 13:15:43 -0000
@@ -139,7 +139,7 @@ const char *object_library_extension = "
#elif defined (VMS)
const char *object_file_option = "";
const char *run_path_option = "";
-char shared_libgnat_default = SHARED;
+char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.27
diff -u -p -r1.27 make.adb
--- make.adb 3 Dec 2003 11:47:53 -0000 1.27
+++ make.adb 5 Jan 2004 13:15:43 -0000
@@ -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- --
@@ -55,16 +55,17 @@ with Sinput.P;
with Snames; use Snames;
with Switch; use Switch;
with Switch.M; use Switch.M;
-with System.HTable;
with Targparm;
with Tempdir;
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Case_Util; use GNAT.Case_Util;
+with System.HTable;
+
package body Make is
use ASCII;
@@ -3265,7 +3266,7 @@ package body Make is
--------------------------
procedure Enter_Into_Obsoleted (F : Name_Id) is
- Name : String := Get_Name_String (F);
+ Name : constant String := Get_Name_String (F);
First : Natural := Name'Last;
F2 : Name_Id := F;
@@ -3398,7 +3399,55 @@ package body Make is
Opt.Check_Object_Consistency := False;
end if;
- if Main_Project /= No_Project then
+ -- Special case when switch -B was specified
+
+ if Build_Bind_And_Link_Full_Project then
+
+ -- When switch -B is specified, there must be a project file
+
+ if Main_Project = No_Project then
+ Make_Failed ("-B cannot be used without a project file");
+
+ -- No main program may be specified on the command line
+
+ elsif Osint.Number_Of_Files /= 0 then
+ Make_Failed ("-B cannot be used with a main specified on " &
+ "the command line");
+
+ -- And the project file cannot be a library project file
+
+ elsif Projects.Table (Main_Project).Library then
+ Make_Failed ("-B cannot be used for a library project file");
+
+ else
+ Insert_Project_Sources
+ (The_Project => Main_Project,
+ All_Projects => Unique_Compile_All_Projects,
+ Into_Q => False);
+
+ -- If there are no sources to compile, we fail
+
+ if Osint.Number_Of_Files = 0 then
+ Make_Failed ("no sources to compile");
+ end if;
+
+ -- Specify -n for gnatbind and add the ALI files of all the
+ -- sources, except the one which is a fake main subprogram:
+ -- this is the one for the binder generated file and it will be
+ -- transmitted to gnatlink. These sources are those that are
+ -- in the queue.
+
+ Add_Switch ("-n", Binder, And_Save => True);
+
+ for J in Q.First .. Q.Last - 1 loop
+ Add_Switch
+ (Get_Name_String
+ (Lib_File_Name (Q.Table (J).File)),
+ Binder, And_Save => True);
+ end loop;
+ end if;
+
+ elsif Main_Project /= No_Project then
-- If the main project file is a library project file, main(s)
-- cannot be specified on the command line.
@@ -3602,9 +3651,10 @@ package body Make is
-- all the sources of the project.
declare
- Data : Project_Data := Projects.Table (Main_Project);
+ Data : constant Project_Data :=
+ Projects.Table (Main_Project);
- Languages : Variable_Value :=
+ Languages : constant Variable_Value :=
Prj.Util.Value_Of
(Name_Languages, Data.Decl.Attributes);
@@ -3661,31 +3711,12 @@ package body Make is
end loop;
-- If we did not get any main, it means that all mains
- -- in attribute Mains are in a foreign language. So,
- -- we put all sources of the main project in the Q.
+ -- in attribute Mains are in a foreign language and -B
+ -- was not specified to gnatmake; so, we fail.
if not At_Least_One_Main then
-
- -- First make sure that the binder and the linker
- -- will not be invoked if -z is not used.
-
- if not No_Main_Subprogram then
- Do_Bind_Step := False;
- Do_Link_Step := False;
- end if;
-
- -- Put all the sources in the queue
-
- Insert_Project_Sources
- (The_Project => Main_Project,
- All_Projects => Unique_Compile_All_Projects,
- Into_Q => False);
-
- -- If there are no sources to compile, we fail
-
- if Osint.Number_Of_Files = 0 then
- Make_Failed ("no sources to compile");
- end if;
+ Make_Failed
+ ("no Ada mains; use -B to build foreign main");
end if;
end;
@@ -3698,7 +3729,7 @@ package body Make is
Write_Eol;
Write_Str ("GNATMAKE ");
Write_Str (Gnatvsn.Gnat_Version_String);
- Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc.");
Write_Eol;
end if;
@@ -4563,6 +4594,7 @@ package body Make is
or not Do_Bind_Step
or not Is_Main_Unit)
and then not No_Main_Subprogram
+ and then not Build_Bind_And_Link_Full_Project
then
if Osint.Number_Of_Files = 1 then
exit Multiple_Main_Loop;
@@ -5995,7 +6027,7 @@ package body Make is
else
declare
- Name : String := Get_Name_String (F);
+ Name : constant String := Get_Name_String (F);
First : Natural := Name'Last;
F2 : Name_Id := F;
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.61
diff -u -p -r1.61 Makefile.in
--- Makefile.in 15 Dec 2003 11:51:00 -0000 1.61
+++ Makefile.in 5 Jan 2004 13:15:43 -0000
@@ -1207,6 +1207,7 @@ endif
# This command transforms (YYYYMMDD) into YY,MMDD
GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
+ LIBRARY_VERSION := $(subst .,_,$(LIB_VERSION))
endif
ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
@@ -1241,6 +1242,8 @@ ifeq ($(strip $(filter-out cygwin32% min
EXTRA_GNATMAKE_OBJS = mdll.o mdll-utl.o mdll-fil.o
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
soext = .dll
+# ??? This will be replaced by gnatlib-shared-dual-win32 when GNAT auto-import
+# support for array/record will be done.
GNATLIB_SHARED = gnatlib-shared-win32
LIBRARY_VERSION := $(LIB_VERSION)
endif
@@ -1688,7 +1691,7 @@ install-gnatlib: ../stamp-gnatlib
-$(INSTALL_DATA) rts/Makefile.prolog $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
-$(INSTALL_DATA) rts/Makefile.generic $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
for file in rts/*.ali; do \
- $(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
+ $(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
-$(INSTALL_DATA) rts/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-for file in rts/*$(arext);do \
@@ -1707,11 +1710,6 @@ else
$(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
endif
- if [ -f rts/libgnat-*$(soext) ]; then \
- (cd $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
- $(LN_S) libgnat-*$(soext) libgnat$(soext) && \
- $(LN_S) libgnarl-*$(soext) libgnarl$(soext)) \
- fi
# This copy must be done preserving the date on the original file.
for file in rts/*.adb rts/*.ads; do \
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
@@ -1898,8 +1896,6 @@ gnatlib-shared-default:
-o libgnarl-$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_TASKING_OBJS) \
$(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB)
- cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
- cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
gnatlib-shared-dual:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1916,10 +1912,25 @@ gnatlib-shared-dual:
gnatlib
$(MV) libgna*$(soext) rts
-# Note that on Win32 the auto-import does not work for DLL, so on the
-# platform we have a specific setup. The libgnat.dll contains only
-# non-tasking objects and libgnarl.dll contains tasking and non-tasking
-# objects. A tasking program must be linked with libgnarl.dll only.
+gnatlib-shared-dual-win32:
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib-shared-win32
+ $(MV) rts/libgna*$(soext) .
+ $(RM) ../stamp-gnatlib2
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib
+ $(MV) libgna*$(soext) rts
+
+# ??? we need to add the option to support auto-import of arrays/records to
+# the GNATLIBFLAGS when this will be supported by GNAT. At this point we will
+# use the gnatlib-shared-dual-win32 target to build the GNAT runtimes on
+# Windows.
gnatlib-shared-win32:
$(MAKE) $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
@@ -1936,8 +1947,6 @@ gnatlib-shared-win32:
$(GNATRTL_TASKING_OBJS) \
$(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \
$(THREADSLIB) -Wl,libgnat-$(LIBRARY_VERSION)$(soext)
- cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
- cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
gnatlib-shared-vms:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1951,7 +1960,7 @@ gnatlib-shared-vms:
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
- -o libgnat_s$(soext) libgnat.a \
+ -o libgnat_$(LIBRARY_VERSION)$(soext) libgnat.a \
sys\$$library:trace.exe \
--for-linker=/noinform \
--for-linker=SYMVEC_$$$$.opt \
@@ -1961,8 +1970,8 @@ gnatlib-shared-vms:
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
- -o libgnarl_s$(soext) \
- libgnarl.a libgnat_s$(soext) \
+ -o libgnarl_$(LIBRARY_VERSION)$(soext) \
+ libgnarl.a libgnat_$(LIBRARY_VERSION)$(soext) \
sys\$$library:trace.exe \
--for-linker=/noinform \
--for-linker=SYMVEC_$$$$.opt \
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.4
diff -u -p -r1.4 Makefile.rtl
--- Makefile.rtl 15 Dec 2003 11:51:00 -0000 1.4
+++ Makefile.rtl 5 Jan 2004 13:15:43 -0000
@@ -18,7 +18,7 @@
#the Free Software Foundation, 59 Temple Place - Suite 330,
#Boston, MA 02111-1307, USA.
-# This makefile fragment is included into the ada Makefile (both Unix
+# This makefile fragment is included in the ada Makefile (both Unix
# and NT and VMS versions).
# It's purpose is to allow the separate maintainence of the list of
@@ -236,6 +236,7 @@ GNATRTL_NONTASKING_OBJS= \
g-pehage$(objext) \
g-regexp$(objext) \
g-regpat$(objext) \
+ g-sestin$(objext) \
g-soccon$(objext) \
g-socket$(objext) \
g-socthi$(objext) \
Index: makeusg.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/makeusg.adb,v
retrieving revision 1.8
diff -u -p -r1.8 makeusg.adb
--- makeusg.adb 21 Oct 2003 13:42:09 -0000 1.8
+++ makeusg.adb 5 Jan 2004 13:15:43 -0000
@@ -61,6 +61,11 @@ begin
Write_Str (" -b Bind only");
Write_Eol;
+ -- Line for -B
+
+ Write_Str (" -B Build, bind and link full project");
+ Write_Eol;
+
-- Line for -c
Write_Str (" -c Compile only");
Index: mdll.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mdll.adb,v
retrieving revision 1.7
diff -u -p -r1.7 mdll.adb
--- mdll.adb 21 Oct 2003 13:42:09 -0000 1.7
+++ mdll.adb 5 Jan 2004 13:15:43 -0000
@@ -59,12 +59,12 @@ package body MDLL is
Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename);
- Def_File : aliased String := Def_Filename;
- Jnk_File : aliased String := Base_Filename & ".jnk";
- Bas_File : aliased String := Base_Filename & ".base";
- Dll_File : aliased String := Base_Filename & ".dll";
- Exp_File : aliased String := Base_Filename & ".exp";
- Lib_File : aliased String := "lib" & Base_Filename & ".a";
+ Def_File : aliased constant String := Def_Filename;
+ Jnk_File : aliased String := Base_Filename & ".jnk";
+ Bas_File : aliased constant String := Base_Filename & ".base";
+ Dll_File : aliased String := Base_Filename & ".dll";
+ Exp_File : aliased String := Base_Filename & ".exp";
+ Lib_File : aliased constant String := "lib" & Base_Filename & ".a";
Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File;
Lib_Opt : aliased String := "-mdll";
@@ -187,10 +187,13 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : OS_Lib.Argument_List :=
- Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access &
- Lib_Opt'Unchecked_Access &
- Bas_Opt'Unchecked_Access & Ofiles & All_Options;
+ Params : constant OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access &
+ Jnk_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Bas_Opt'Unchecked_Access &
+ Ofiles &
+ All_Options;
begin
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
@@ -207,13 +210,14 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : OS_Lib.Argument_List :=
- Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access &
- Lib_Opt'Unchecked_Access &
- Bas_Opt'Unchecked_Access &
- Exp_File'Unchecked_Access &
- Ofiles &
- All_Options;
+ Params : constant OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access &
+ Jnk_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Bas_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Ofiles &
+ All_Options;
begin
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
@@ -230,13 +234,14 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : OS_Lib.Argument_List :=
- Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access &
- Lib_Opt'Unchecked_Access &
- Exp_File'Unchecked_Access &
- Adr_Opt'Unchecked_Access &
- Ofiles &
- All_Options;
+ Params : constant OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access &
+ Dll_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Adr_Opt'Unchecked_Access &
+ Ofiles &
+ All_Options;
begin
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
@@ -325,13 +330,14 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : OS_Lib.Argument_List :=
- Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access &
- Lib_Opt'Unchecked_Access &
- Exp_File'Unchecked_Access &
- Adr_Opt'Unchecked_Access &
- Ofiles &
- All_Options;
+ Params : constant OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access &
+ Dll_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Adr_Opt'Unchecked_Access &
+ Ofiles &
+ All_Options;
begin
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/misc.c,v
retrieving revision 1.72
diff -u -p -r1.72 misc.c
--- misc.c 14 Nov 2003 16:49:19 -0000 1.72
+++ misc.c 5 Jan 2004 13:15:43 -0000
@@ -530,12 +530,18 @@ gnat_print_type (FILE *file, tree node,
}
static const char *
-gnat_printable_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
+gnat_printable_name (tree decl, int verbosity)
{
const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
- char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
+ char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
__gnat_decode (coded_name, ada_name, 0);
+
+ if (verbosity == 2)
+ {
+ Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
+ ada_name = Name_Buffer;
+ }
return (const char *) ada_name;
}
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.7
diff -u -p -r1.7 mlib-prj.adb
--- mlib-prj.adb 1 Dec 2003 13:29:27 -0000 1.7
+++ mlib-prj.adb 5 Jan 2004 13:15:43 -0000
@@ -25,12 +25,14 @@
------------------------------------------------------------------------------
with ALI; use ALI;
+with Gnatvsn; use Gnatvsn;
with Hostparm;
with MLib.Fil; use MLib.Fil;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl; use MLib.Utl;
with Namet; use Namet;
with Opt;
+with Osint; use Osint;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Prj.Env; use Prj.Env;
@@ -1165,7 +1167,12 @@ package body MLib.Prj is
if Libgnarl_Needed then
Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String'("-lgnarl");
+
+ if The_Build_Mode = Static then
+ Opts.Table (Opts.Last) := new String'("-lgnarl");
+ else
+ Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
+ end if;
end if;
if Libdecgnat_Needed then
@@ -1177,7 +1184,12 @@ package body MLib.Prj is
end if;
Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String'("-lgnat");
+
+ if The_Build_Mode = Static then
+ Opts.Table (Opts.Last) := new String'("-lgnat");
+ else
+ Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat"));
+ end if;
-- If Path Option is supported, add the necessary switch with the
-- content of Rpath. As Rpath contains at least libgnat directory
@@ -1717,10 +1729,11 @@ package body MLib.Prj is
-- For fopen
Status : Interfaces.C_Streams.int;
+ pragma Unreferenced (Status);
-- For fclose
- Begin_Info : String := "-- BEGIN Object file/option list";
- End_Info : String := "-- END Object file/option list ";
+ Begin_Info : constant String := "-- BEGIN Object file/option list";
+ End_Info : constant String := "-- END Object file/option list ";
Next_Line : String (1 .. 1000);
-- Current line value
@@ -1793,18 +1806,30 @@ package body MLib.Prj is
if Next_Line (1 .. Nlast) /= End_Info then
loop
- -- Disregard -static and -shared, as -shared will be used
+ -- Ignore -static and -shared, since -shared will be used
-- in any case.
- -- Disregard -lgnat, -lgnarl and -ldecgnat as they will be added
+ -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added
-- later, because they are also needed for non Stand-Alone shared
-- libraries.
+ -- Also ignore the shared libraries which are :
+
+ -- UNIX / Windows VMS
+ -- -lgnat-<version> -lgnat_<version> (7 + version'length chars)
+ -- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars)
+
if Next_Line (1 .. Nlast) /= "-static" and then
Next_Line (1 .. Nlast) /= "-shared" and then
Next_Line (1 .. Nlast) /= "-ldecgnat" and then
Next_Line (1 .. Nlast) /= "-lgnarl" and then
- Next_Line (1 .. Nlast) /= "-lgnat"
+ Next_Line (1 .. Nlast) /= "-lgnat" and then
+ Next_Line
+ (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /=
+ Shared_Lib ("gnarl") and then
+ Next_Line
+ (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /=
+ Shared_Lib ("gnat")
then
if Next_Line (1) /= '-' then
@@ -1838,6 +1863,7 @@ package body MLib.Prj is
end if;
Status := fclose (Fd);
+ -- Is it really right to ignore any close error ???
end Process_Binder_File;
------------------
Index: mlib-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-tgt.adb,v
retrieving revision 1.6
diff -u -p -r1.6 mlib-tgt.adb
--- mlib-tgt.adb 20 Nov 2003 09:54:00 -0000 1.6
+++ mlib-tgt.adb 5 Jan 2004 13:15:43 -0000
@@ -137,7 +137,6 @@ package body MLib.Tgt is
function Is_Object_Ext (Ext : String) return Boolean is
pragma Unreferenced (Ext);
-
begin
return False;
end Is_Object_Ext;
@@ -148,7 +147,6 @@ package body MLib.Tgt is
function Is_C_Ext (Ext : String) return Boolean is
pragma Unreferenced (Ext);
-
begin
return False;
end Is_C_Ext;
@@ -159,7 +157,6 @@ package body MLib.Tgt is
function Is_Archive_Ext (Ext : String) return Boolean is
pragma Unreferenced (Ext);
-
begin
return False;
end Is_Archive_Ext;
@@ -179,7 +176,6 @@ package body MLib.Tgt is
function Library_Exists_For (Project : Project_Id) return Boolean is
pragma Unreferenced (Project);
-
begin
return False;
end Library_Exists_For;
@@ -190,7 +186,6 @@ package body MLib.Tgt is
function Library_File_Name_For (Project : Project_Id) return Name_Id is
pragma Unreferenced (Project);
-
begin
return No_Name;
end Library_File_Name_For;
Index: opt.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.ads,v
retrieving revision 1.10
diff -u -p -r1.10 opt.ads
--- opt.ads 10 Nov 2003 17:29:59 -0000 1.10
+++ opt.ads 5 Jan 2004 13:15:43 -0000
@@ -165,6 +165,11 @@ package Opt is
-- Force brief error messages to standard error, even if verbose mode is
-- set (so that main error messages go to standard output).
+ Build_Bind_And_Link_Full_Project : Boolean := False;
+ -- GNATMAKE
+ -- Set to True to build, bind and link all the sources of a project file
+ -- (switch -B)
+
Check_Object_Consistency : Boolean := False;
-- GNATBIND, GNATMAKE
-- Set to True to check whether every object file is consistent with
@@ -260,6 +265,13 @@ package Opt is
-- of the original source code. Causes debugging information to be
-- written with respect to the generated code file that is written.
+ Default_Sec_Stack_Size : Int := -1;
+ -- GNATBIND
+ -- Set to default secondary stack size in units of kilobytes. Set by
+ -- the -Dnnn switch for the binder. A value of -1 indicates that no
+ -- default was set by the binder, and that the default should be the
+ -- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size.
+
Display_Compilation_Progress : Boolean := False;
-- GNATMAKE
-- Set True (-d switch) to display information on progress while compiling
@@ -766,6 +778,11 @@ package Opt is
Run_Path_Option : Boolean := True;
-- GNATMAKE, GNATLINK
-- Set to False when no run_path_option should be issued to the linker
+
+ Sec_Stack_Used : Boolean := False;
+ -- GNAT, GBATBIND
+ -- Set True if generated code uses the System.Secondary_Stack package.
+ -- For the binder, set if any unit uses the secondary stack package.
Shared_Libgnat : Boolean;
-- GNATBIND
Index: osint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.adb,v
retrieving revision 1.15
diff -u -p -r1.15 osint.adb
--- osint.adb 17 Nov 2003 14:58:15 -0000 1.15
+++ osint.adb 5 Jan 2004 13:15:43 -0000
@@ -24,15 +24,17 @@
-- --
------------------------------------------------------------------------------
-with Fmap; use Fmap;
+with Fmap; use Fmap;
+with Gnatvsn; use Gnatvsn;
with Hostparm;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Sdefault; use Sdefault;
-with System.Case_Util; use System.Case_Util;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Sdefault; use Sdefault;
with Table;
+with System.Case_Util; use System.Case_Util;
+
with Unchecked_Conversion;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@@ -610,7 +612,6 @@ package body Osint is
function C_String_Length (S : Address) return Integer is
function Strlen (S : Address) return Integer;
pragma Import (C, Strlen, "strlen");
-
begin
if S = Null_Address then
return 0;
@@ -646,7 +647,6 @@ package body Osint is
function Concat (String_One : String; String_Two : String) return String is
Buffer : String (1 .. String_One'Length + String_Two'Length);
-
begin
Buffer (1 .. String_One'Length) := String_One;
Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two;
@@ -814,13 +814,14 @@ package body Osint is
procedure Exit_Program (Exit_Code : Exit_Code_Type) is
begin
-- The program will exit with the following status:
+
-- 0 if the object file has been generated (with or without warnings)
-- 1 if recompilation was not needed (smart recompilation)
-- 2 if gnat1 has been killed by a signal (detected by GCC)
-- 4 for a fatal error
-- 5 if there were errors
-- 6 if no code has been generated (spec)
- --
+
-- Note that exit code 3 is not used and must not be used as this is
-- the code returned by a program aborted via C abort() routine on
-- Windows. GCC checks for that case and thinks that the child process
@@ -1205,9 +1206,9 @@ package body Osint is
return null;
end if;
- else
- -- Search in the current directory
+ -- Search in the current directory
+ else
-- Get the current directory
declare
@@ -1845,7 +1846,7 @@ package body Osint is
-- Start of processing for Read_Default_Search_Dirs
begin
- -- Construct a C compatible character string buffer.
+ -- Construct a C compatible character string buffer
Buffer (1 .. Search_Dir_Prefix.all'Length)
:= Search_Dir_Prefix.all;
@@ -1940,7 +1941,7 @@ package body Osint is
-- indicates failure to open the specified source file.
Text : Text_Buffer_Ptr;
- -- Allocated text buffer.
+ -- Allocated text buffer
Status : Boolean;
-- For the calls to Close
@@ -2001,23 +2002,7 @@ package body Osint is
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
Close (Lib_FD, Status);
- -- No need to check the status, we return null anyway
-
- return null;
- end if;
- end if;
- -- Object file exists, compare object and ALI time stamps
-
- if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then
- if Fatal_Err then
- Get_Name_String (Current_Full_Obj_Name);
- Close (Lib_FD, Status);
- -- No need to check the status, we fail anyway
- Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len));
- else
- Current_Full_Obj_Stamp := Empty_Time_Stamp;
- Close (Lib_FD, Status);
-- No need to check the status, we return null anyway
return null;
@@ -2183,6 +2168,7 @@ package body Osint is
-- Read is complete, get time stamp and close file and we are done
Close (Source_File_FD, Status);
+
-- The status should never be False. But, if it is, what can we do?
-- So, we don't test it.
@@ -2206,6 +2192,7 @@ package body Osint is
Std_Prefix := Executable_Prefix;
if Std_Prefix.all /= "" then
+
-- Remove trailing directory separator when calling set_std_prefix
set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
@@ -2240,6 +2227,31 @@ package body Osint is
Running_Program := P;
end Set_Program;
+ ----------------
+ -- Shared_Lib --
+ ----------------
+
+ function Shared_Lib (Name : String) return String is
+ Library : String (1 .. Name'Length + Library_Version'Length + 3);
+ -- 3 = 2 for "-l" + 1 for "-" before lib version
+
+ begin
+ Library (1 .. 2) := "-l";
+ Library (3 .. 2 + Name'Length) := Name;
+ Library (3 + Name'Length) := '-';
+ Library (4 + Name'Length .. Library'Last) := Library_Version;
+
+ if Hostparm.OpenVMS then
+ for K in Library'First + 2 .. Library'Last loop
+ if Library (K) = '.' or else Library (K) = '-' then
+ Library (K) := '_';
+ end if;
+ end loop;
+ end if;
+
+ return Library;
+ end Shared_Lib;
+
----------------------
-- Smart_File_Stamp --
----------------------
@@ -2317,9 +2329,11 @@ package body Osint is
Get_Name_String (Name);
for J in reverse 1 .. Name_Len - 1 loop
+
-- If we find the last directory separator
if Is_Directory_Separator (Name_Buffer (J)) then
+
-- Return the part of Name that follows this last directory
-- separator.
@@ -2344,8 +2358,7 @@ package body Osint is
for J in reverse 2 .. Name_Len loop
- -- If we found the last '.', return the part of Name that precedes
- -- this '.'.
+ -- If we found the last '.', return part of Name that precedes it
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
@@ -2595,7 +2608,7 @@ package body Osint is
Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
- type Path_String_Access is access Path_String;
+ type Path_String_Access is access Path_String;
function Address_To_Access is new
Unchecked_Conversion (Source => Address,
@@ -2604,7 +2617,7 @@ package body Osint is
Path_Access : constant Path_String_Access :=
Address_To_Access (Path_Addr);
- Return_Val : String_Access;
+ Return_Val : String_Access;
begin
Return_Val := new String (1 .. Path_Len);
@@ -2669,7 +2682,6 @@ package body Osint is
Name_Buffer (1 .. Name_Len);
begin
-
Find_Program_Name;
-- Convert the name to lower case so error messages are the same on
Index: osint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.ads,v
retrieving revision 1.10
diff -u -p -r1.10 osint.ads
--- osint.ads 14 Nov 2003 10:24:43 -0000 1.10
+++ osint.ads 5 Jan 2004 13:15:43 -0000
@@ -213,6 +213,12 @@ package Osint is
-- If the above computation fails, return Path.
-- This function assumes that Prefix'First = Path'First
+ function Shared_Lib (Name : String) return String;
+ -- Returns the runtime shared library in the form -l<name>-<version> where
+ -- version is the GNAT runtime library option for the platform. For example
+ -- this routine called with Name set to "gnat" will return "-lgnat-5.02"
+ -- on UNIX and Windows and -lgnat_5_02 on VMS.
+
-------------------------
-- Search Dir Routines --
-------------------------
Index: prj-nmsc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-nmsc.adb,v
retrieving revision 1.15
diff -u -p -r1.15 prj-nmsc.adb
--- prj-nmsc.adb 20 Nov 2003 09:54:00 -0000 1.15
+++ prj-nmsc.adb 5 Jan 2004 13:15:44 -0000
@@ -125,8 +125,7 @@ package body Prj.Nmsc is
function Is_Illegal_Suffix
(Suffix : String;
- Dot_Replacement_Is_A_Single_Dot : Boolean)
- return Boolean;
+ Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean;
-- Returns True if the string Suffix cannot be used as
-- a spec suffix, a body suffix or a separate suffix.
@@ -154,15 +153,13 @@ package body Prj.Nmsc is
function Path_Name_Of
(File_Name : Name_Id;
- Directory : Name_Id)
- return String;
+ Directory : Name_Id) return String;
-- Returns the path name of a (non project) file.
-- Returns an empty string if file cannot be found.
function Project_Extends
(Extending : Project_Id;
- Extended : Project_Id)
- return Boolean;
+ Extended : Project_Id) return Boolean;
-- Returns True if Extending is extending directly or indirectly Extended.
procedure Check_Naming_Scheme
@@ -2522,8 +2519,7 @@ package body Prj.Nmsc is
function Is_Illegal_Suffix
(Suffix : String;
- Dot_Replacement_Is_A_Single_Dot : Boolean)
- return Boolean
+ Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean
is
begin
if Suffix'Length = 0 or else Index (Suffix, ".") = 0 then
@@ -2574,14 +2570,16 @@ package body Prj.Nmsc is
----------------------
procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr) is
- Directory : constant String := Get_Name_String (From);
+ Directory : constant String := Get_Name_String (From);
+ Element : String_Element;
+
Canonical_Directory_Id : Name_Id;
- Element : String_Element;
+ pragma Unreferenced (Canonical_Directory_Id);
+ -- Is this in fact being used for anything useful ???
procedure Recursive_Find_Dirs (Path : Name_Id);
- -- Find all the subdirectories (recursively) of Path
- -- and add them to the list of source directories
- -- of the project.
+ -- Find all the subdirectories (recursively) of Path and add them
+ -- to the list of source directories of the project.
-------------------------
-- Recursive_Find_Dirs --
@@ -2602,12 +2600,14 @@ package body Prj.Nmsc is
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
declare
- The_Path : String :=
+ The_Path : constant String :=
Normalize_Pathname
(Name => Name_Buffer (1 .. Name_Len)) &
- Directory_Separator;
+ Directory_Separator;
+
The_Path_Last : constant Natural :=
Compute_Directory_Last (The_Path);
+
begin
Name_Len := The_Path_Last - The_Path'First + 1;
Name_Buffer (1 .. Name_Len) :=
@@ -2738,8 +2738,13 @@ package body Prj.Nmsc is
Get_Name_String (From);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
-- Directory := Name_Buffer (1 .. Name_Len);
+ -- Why is above line commented out ???
+
Canonical_Directory_Id := Name_Find;
+ -- What is purpose of above assignment ???
+ -- Are we sure it is being used ???
if Current_Verbosity = High then
Write_Str (Directory);
@@ -3609,8 +3614,7 @@ package body Prj.Nmsc is
function Path_Name_Of
(File_Name : Name_Id;
- Directory : Name_Id)
- return String
+ Directory : Name_Id) return String
is
Result : String_Access;
The_Directory : constant String := Get_Name_String (Directory);
@@ -3635,8 +3639,7 @@ package body Prj.Nmsc is
function Project_Extends
(Extending : Project_Id;
- Extended : Project_Id)
- return Boolean
+ Extended : Project_Id) return Boolean
is
Current : Project_Id := Extending;
begin
Index: prj-pp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-pp.adb,v
retrieving revision 1.7
diff -u -p -r1.7 prj-pp.adb
--- prj-pp.adb 8 Dec 2003 10:33:15 -0000 1.7
+++ prj-pp.adb 5 Jan 2004 13:15:44 -0000
@@ -254,7 +254,8 @@ package body Prj.PP is
-------------------------------
procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
- Value : Name_Id := End_Of_Line_Comment (Node);
+ Value : constant Name_Id := End_Of_Line_Comment (Node);
+
begin
if Value /= No_Name then
Write_String (" --");
Index: prj-util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-util.adb,v
retrieving revision 1.9
diff -u -p -r1.9 prj-util.adb
--- prj-util.adb 21 Oct 2003 13:42:12 -0000 1.9
+++ prj-util.adb 5 Jan 2004 13:15:44 -0000
@@ -92,7 +92,7 @@ package body Prj.Util is
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package);
- Executable_Suffix : Variable_Value :=
+ Executable_Suffix : constant Variable_Value :=
Prj.Util.Value_Of
(Name => Main,
Attribute_Or_Array_Name =>
@@ -118,7 +118,8 @@ package body Prj.Util is
-- the specification suffix.
declare
- Name : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Name : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
Last : Positive := Name_Len;
Naming : constant Naming_Data :=
Index: rtsfind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/rtsfind.adb,v
retrieving revision 1.10
diff -u -p -r1.10 rtsfind.adb
--- rtsfind.adb 1 Dec 2003 13:29:27 -0000 1.10
+++ rtsfind.adb 5 Jan 2004 13:15:44 -0000
@@ -441,6 +441,7 @@ package body Rtsfind is
if S /= "not found"
or else not Configurable_Run_Time_Mode
+ or else All_Errors_Mode
then
M (1 .. 6) := "\file ";
P := 6;
@@ -539,6 +540,12 @@ package body Rtsfind is
if Present (U.Entity) then
return;
+ end if;
+
+ -- Note if secondary stack is used
+
+ if U_Id = System_Secondary_Stack then
+ Opt.Sec_Stack_Used := True;
end if;
-- Otherwise we need to load the unit, First build unit name
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_attr.adb
--- sem_attr.adb 3 Dec 2003 11:47:53 -0000 1.16
+++ sem_attr.adb 5 Jan 2004 13:15:44 -0000
@@ -1424,7 +1424,7 @@ package body Sem_Attr is
------------
function On_X86 return Boolean is
- T : String := Sdefault.Target_Name.all;
+ T : constant String := Sdefault.Target_Name.all;
begin
-- There is no clean way to check this. That's not surprising,
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_ch10.adb
--- sem_ch10.adb 20 Nov 2003 09:54:01 -0000 1.13
+++ sem_ch10.adb 5 Jan 2004 13:15:44 -0000
@@ -2375,7 +2375,6 @@ package body Sem_Ch10 is
procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Nam);
- P : Entity_Id;
Unum : Unit_Number_Type;
Withn : Node_Id;
@@ -2398,8 +2397,6 @@ package body Sem_Ch10 is
Subunit => False,
Error_Node => Nam);
- P := Cunit_Entity (Unum);
-
if not Analyzed (Cunit (Unum)) then
Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec
@@ -2431,8 +2428,6 @@ package body Sem_Ch10 is
Subunit => False,
Error_Node => Nam);
- P := Cunit_Entity (Unum);
-
if not Analyzed (Cunit (Unum)) then
Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec
@@ -3242,9 +3237,9 @@ package body Sem_Ch10 is
-------------------------------
procedure Install_Limited_Withed_Unit (N : Node_Id) is
- Unum : Unit_Number_Type :=
+ Unum : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (N));
- P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
P : Entity_Id;
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
@@ -3584,9 +3579,8 @@ package body Sem_Ch10 is
-------------------------
procedure Build_Limited_Views (N : Node_Id) is
-
- Unum : Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
- P : Entity_Id := Cunit_Entity (Unum);
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
+ P : constant Entity_Id := Cunit_Entity (Unum);
Spec : Node_Id; -- To denote a package specification
Lim_Typ : Entity_Id; -- To denote shadow entities.
@@ -3717,9 +3711,9 @@ package body Sem_Ch10 is
-- Could use more comments below ???
procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
- Decl : Node_Id;
- Analyzed_Unit : Boolean := Analyzed (Cunit (Unum));
+ Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
Is_Tagged : Boolean;
+ Decl : Node_Id;
begin
Decl := First (Visible_Declarations (Spec));
@@ -3788,7 +3782,7 @@ package body Sem_Ch10 is
-- Local package
declare
- Spec : Node_Id := Specification (Decl);
+ Spec : constant Node_Id := Specification (Decl);
begin
Comp_Typ := Defining_Unit_Name (Spec);
@@ -4077,7 +4071,7 @@ package body Sem_Ch10 is
--------------------------------
procedure Remove_Limited_With_Clause (N : Node_Id) is
- P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.29
diff -u -p -r1.29 sem_ch12.adb
--- sem_ch12.adb 8 Dec 2003 10:33:16 -0000 1.29
+++ sem_ch12.adb 5 Jan 2004 13:15:45 -0000
@@ -2577,7 +2577,7 @@ package body Sem_Ch12 is
if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
declare
- Decl : Node_Id :=
+ Decl : constant Node_Id :=
Original_Node
(Unit_Declaration_Node (Scope (Gen_Unit)));
begin
@@ -6248,7 +6248,7 @@ package body Sem_Ch12 is
Gen_Anc : Entity_Id)
return Boolean
is
- Gen_Par : Entity_Id := Generic_Parent (Act_Spec);
+ Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
begin
if No (Gen_Par) then
@@ -7768,8 +7768,7 @@ package body Sem_Ch12 is
begin
Decl := First (Actual_Decls);
-
- while (Present (Decl)) loop
+ while Present (Decl) loop
if Nkind (Decl) = N_Subtype_Declaration
and then Chars (Defining_Identifier (Decl)) =
Chars (Etype (A_Gen_T))
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_ch4.adb
--- sem_ch4.adb 20 Nov 2003 09:54:01 -0000 1.10
+++ sem_ch4.adb 5 Jan 2004 13:15:45 -0000
@@ -209,10 +209,9 @@ package body Sem_Ch4 is
-- a more informative message.
function Try_Indexed_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean;
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean;
-- If a function has defaults for all its actuals, a call to it may
-- in fact be an indexing on the result of the call. Try_Indexed_Call
-- attempts the interpretation as an indexing, prior to analysis as
@@ -220,10 +219,9 @@ package body Sem_Ch4 is
-- interpretations (same symbol but two different types).
function Try_Indirect_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean;
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean;
-- Similarly, a function F that needs no actuals can return an access
-- to a subprogram, and the call F (X) interpreted as F.all (X). In
-- this case the call may be overloaded with both interpretations.
@@ -334,10 +332,6 @@ package body Sem_Ch4 is
Check_Fully_Declared (Type_Id, N);
Set_Directly_Designated_Type (Acc_Type, Type_Id);
- if Is_Protected_Type (Type_Id) then
- Check_Restriction (No_Protected_Type_Allocators, N);
- end if;
-
if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
@@ -449,6 +443,15 @@ package body Sem_Ch4 is
Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N);
+ -- Check restriction against dynamically allocated protected
+ -- objects. Note that when limited aggregates are supported,
+ -- a similar test should be applied to an allocator with a
+ -- qualified expression ???
+
+ if Is_Protected_Type (Type_Id) then
+ Check_Restriction (No_Protected_Type_Allocators, N);
+ end if;
+
-- Check for missing initialization. Skip this check if we already
-- had errors on analyzing the allocator, since in that case these
-- are probably cascaded errors
@@ -4299,10 +4302,9 @@ package body Sem_Ch4 is
-----------------------
function Try_Indirect_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean
is
Actuals : constant List_Id := Parameter_Associations (N);
Actual : Node_Id;
@@ -4345,10 +4347,9 @@ package body Sem_Ch4 is
----------------------
function Try_Indexed_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean
is
Actuals : constant List_Id := Parameter_Associations (N);
Actual : Node_Id;
Index: sem_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch5.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_ch5.adb
--- sem_ch5.adb 1 Dec 2003 13:29:27 -0000 1.11
+++ sem_ch5.adb 5 Jan 2004 13:15:45 -0000
@@ -714,7 +714,7 @@ package body Sem_Ch5 is
and then Serious_Errors_Detected = 0
then
declare
- Chosen : Node_Id := Find_Static_Alternative (N);
+ Chosen : constant Node_Id := Find_Static_Alternative (N);
Alt : Node_Id;
begin
Index: sem_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch7.adb,v
retrieving revision 1.9
diff -u -p -r1.9 sem_ch7.adb
--- sem_ch7.adb 21 Oct 2003 13:42:20 -0000 1.9
+++ sem_ch7.adb 5 Jan 2004 13:15:45 -0000
@@ -733,7 +733,7 @@ package body Sem_Ch7 is
--------------------------------
procedure Generate_Parent_References is
- Decl : Node_Id := Parent (N);
+ Decl : constant Node_Id := Parent (N);
begin
if Id = Cunit_Entity (Main_Unit)
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_ch8.adb
--- sem_ch8.adb 20 Nov 2003 09:54:01 -0000 1.14
+++ sem_ch8.adb 5 Jan 2004 13:15:45 -0000
@@ -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- --
@@ -1240,7 +1240,8 @@ package body Sem_Ch8 is
-- There is no need for elaboration checks on the new entity, which
-- may be called before the next freezing point where the body will
- -- appear.
+ -- appear. Elaboration checks refer to the real entity, not the one
+ -- created by the renaming declaration.
Set_Kill_Elaboration_Checks (New_S, True);
Index: sem_elab.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elab.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_elab.adb
--- sem_elab.adb 24 Nov 2003 14:27:57 -0000 1.11
+++ sem_elab.adb 5 Jan 2004 13:15:46 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
@@ -300,7 +300,18 @@ package body Sem_Elab is
Decl : Node_Id;
E_Scope : Entity_Id;
- -- Top level scope of entity for called subprogram
+ -- Top level scope of entity for called subprogram. This
+ -- value includes following renamings and derivations, so
+ -- this scope can be in a non-visible unit. This is the
+ -- scope that is to be investigated to see whether an
+ -- elaboration check is required.
+
+ W_Scope : Entity_Id;
+ -- Top level scope of directly called entity for subprogram.
+ -- This differs from E_Scope in the case where renamings or
+ -- derivations are involved, since it does not follow these
+ -- links, thus W_Scope is always in a visible unit. This is
+ -- the scope for the Elaborate_All if one is needed.
Body_Acts_As_Spec : Boolean;
-- Set to true if call is to body acting as spec (no separate spec)
@@ -611,7 +622,7 @@ package body Sem_Elab is
Ent := Alias (Ent);
E_Scope := Ent;
- -- If no alias, there is a previous error.
+ -- If no alias, there is a previous error
if No (Ent) then
return;
@@ -623,6 +634,26 @@ package body Sem_Elab is
return;
end if;
+ -- Find top level scope for called entity (not following renamings
+ -- or derivations). This is where the Elaborate_All will go if it
+ -- is needed. We start with the called entity, except in the case
+ -- of initialization procedures, where the init proc is in the root
+ -- package, where we start fromn the entity of the name in the call.
+
+ if Is_Entity_Name (Name (N))
+ and then Is_Init_Proc (Entity (Name (N)))
+ then
+ W_Scope := Scope (Entity (Name (N)));
+ else
+ W_Scope := E;
+ end if;
+
+ while not Is_Compilation_Unit (W_Scope) loop
+ W_Scope := Scope (W_Scope);
+ end loop;
+
+ -- Now check if an elaborate_all (or dynamic check) is needed
+
if not Suppress_Elaboration_Warnings (Ent)
and then not Elaboration_Checks_Suppressed (Ent)
and then not Suppress_Elaboration_Warnings (E_Scope)
@@ -633,38 +664,23 @@ package body Sem_Elab is
if Inst_Case then
Error_Msg_NE
("instantiation of& may raise Program_Error?", N, Ent);
+
else
if Is_Init_Proc (Entity (Name (N)))
and then Comes_From_Source (Ent)
then
Error_Msg_NE
- ("implicit call to & in initialization" &
- " may raise Program_Error?", N, Ent);
- E_Scope := Scope (Entity (Name (N)));
+ ("implicit call to & may raise Program_Error?", N, Ent);
else
Error_Msg_NE
("call to & may raise Program_Error?", N, Ent);
end if;
-
- if Unit_Callee = No_Unit
- and then E_Scope = Current_Scope
- then
- -- The missing pragma cannot be on the current unit, so
- -- place it on the compilation unit that contains the
- -- called entity, which is more likely to be right.
-
- E_Scope := Ent;
-
- while not Is_Compilation_Unit (E_Scope) loop
- E_Scope := Scope (E_Scope);
- end loop;
- end if;
end if;
Error_Msg_Qual_Level := Nat'Last;
Error_Msg_NE
- ("\missing pragma Elaborate_All for&?", N, E_Scope);
+ ("\missing pragma Elaborate_All for&?", N, W_Scope);
Error_Msg_Qual_Level := 0;
Output_Calls (N);
@@ -672,7 +688,7 @@ package body Sem_Elab is
-- unless in All_Errors_Mode.
if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
- Set_Suppress_Elaboration_Warnings (E_Scope, True);
+ Set_Suppress_Elaboration_Warnings (W_Scope, True);
end if;
end if;
@@ -680,12 +696,18 @@ package body Sem_Elab is
if Dynamic_Elaboration_Checks then
if not Elaboration_Checks_Suppressed (Ent)
+ and then not Elaboration_Checks_Suppressed (W_Scope)
and then not Elaboration_Checks_Suppressed (E_Scope)
and then not Cunit_SC
then
-- Runtime elaboration check required. Generate check of the
-- elaboration Boolean for the unit containing the entity.
+ -- Note that for this case, we do check the real unit (the
+ -- one from following renamings, since that is the issue!)
+
+ -- Could this possibly miss a useless but required PE???
+
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
@@ -694,25 +716,41 @@ package body Sem_Elab is
(Spec_Entity (E_Scope), Loc)));
end if;
- -- If no dynamic check required, then ask binder to guarantee
- -- that the necessary elaborations will be done properly!
+ -- Case of static elaboration model
else
- if not Suppress_Elaboration_Warnings (E)
- and then not Elaboration_Checks_Suppressed (E)
- and then not Suppress_Elaboration_Warnings (E_Scope)
- and then not Elaboration_Checks_Suppressed (E_Scope)
- and then Elab_Warnings
- and then Generate_Warnings
- and then not Inst_Case
+ -- Do not do anything if elaboration checks suppressed. Note
+ -- that we check Ent here, not E, since we want the real entity
+ -- for the body to see if checks are suppressed for it, not the
+ -- dummy entry for renamings or derivations.
+
+ if Elaboration_Checks_Suppressed (Ent)
+ or else Elaboration_Checks_Suppressed (E_Scope)
+ or else Elaboration_Checks_Suppressed (W_Scope)
then
- Error_Msg_Node_2 := E_Scope;
- Error_Msg_NE ("call to& in elaboration code " &
- "requires pragma Elaborate_All on&?", N, E);
- end if;
+ null;
+
+ -- Here we need to generate an implicit elaborate all
+
+ else
+ -- Generate elaborate_all warning unless suppressed
- Set_Elaborate_All_Desirable (E_Scope);
- Set_Suppress_Elaboration_Warnings (E_Scope, True);
+ if (Elab_Warnings and Generate_Warnings and not Inst_Case)
+ and then not Suppress_Elaboration_Warnings (Ent)
+ and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then not Suppress_Elaboration_Warnings (W_Scope)
+ then
+ Error_Msg_Node_2 := W_Scope;
+ Error_Msg_NE
+ ("call to& in elaboration code " &
+ "requires pragma Elaborate_All on&?", N, E);
+ end if;
+
+ -- Set indication for binder to generate Elaborate_All
+
+ Set_Elaborate_All_Desirable (W_Scope);
+ Set_Suppress_Elaboration_Warnings (W_Scope, True);
+ end if;
end if;
-- Case of entity is in same unit as call or instantiation
Index: sem_elim.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elim.adb,v
retrieving revision 1.5
diff -u -p -r1.5 sem_elim.adb
--- sem_elim.adb 24 Apr 2003 17:54:17 -0000 1.5
+++ sem_elim.adb 5 Jan 2004 13:15:46 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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- --
@@ -33,6 +33,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Table;
with Uintp; use Uintp;
with GNAT.HTable; use GNAT.HTable;
@@ -91,6 +92,9 @@ package body Sem_Elim is
Homonym : Access_Elim_Data;
-- Pointer to next entry with same key
+ Prag : Node_Id;
+ -- Node_Id for Eliminate pragma
+
end record;
----------------
@@ -179,6 +183,14 @@ package body Sem_Elim is
end Set_Next;
end Hash_Subprograms;
+ ------------
+ -- Tables --
+ ------------
+
+ -- The following table records the data for each pragmas, using the
+ -- entity name as the hash key for retrieval. Entries in this table
+ -- are set by Process_Eliminate_Pragma and read by Check_Eliminated.
+
package Elim_Hash_Table is new Static_HTable (
Header_Num => Header_Num,
Element => Element,
@@ -191,6 +203,24 @@ package body Sem_Elim is
Hash => Hash_Subprograms.Hash,
Equal => Hash_Subprograms.Equal);
+ -- The following table records entities for subprograms that are
+ -- eliminated, and corresponding eliminate pragmas that caused the
+ -- elimination. Entries in this table are set by Check_Eliminated
+ -- and read by Eliminate_Error_Msg.
+
+ type Elim_Entity_Entry is record
+ Prag : Node_Id;
+ Subp : Entity_Id;
+ end record;
+
+ package Elim_Entities is new Table.Table (
+ Table_Component_Type => Elim_Entity_Entry,
+ Table_Index_Type => Name_Id,
+ Table_Low_Bound => First_Name_Id,
+ Table_Initial => 50,
+ Table_Increment => 200,
+ Table_Name => "Elim_Entries");
+
----------------------
-- Check_Eliminated --
----------------------
@@ -206,7 +236,7 @@ package body Sem_Elim is
if No_Elimination then
return;
- -- Elimination of objects and types is not implemented yet.
+ -- Elimination of objects and types is not implemented yet
elsif Ekind (E) not in Subprogram_Kind then
return;
@@ -217,142 +247,173 @@ package body Sem_Elim is
-- Loop through homonyms for this key
while Elmt /= null loop
+ declare
+ procedure Set_Eliminated;
+ -- Set current subprogram entity as eliminated
+
+ procedure Set_Eliminated is
+ begin
+ Set_Is_Eliminated (E);
+ Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
+ end Set_Eliminated;
- -- First we check that the name of the entity matches
+ begin
+ -- First we check that the name of the entity matches
- if Elmt.Entity_Name /= Chars (E) then
- goto Continue;
- end if;
+ if Elmt.Entity_Name /= Chars (E) then
+ goto Continue;
+ end if;
+
+ -- Then we need to see if the static scope matches within the
+ -- compilation unit.
- -- Then we need to see if the static scope matches within the
- -- compilation unit.
+ Scop := Scope (E);
+ if Elmt.Entity_Scope /= null then
+ for J in reverse Elmt.Entity_Scope'Range loop
+ if Elmt.Entity_Scope (J) /= Chars (Scop) then
+ goto Continue;
+ end if;
+
+ Scop := Scope (Scop);
+
+ if not Is_Compilation_Unit (Scop) and then J = 1 then
+ goto Continue;
+ end if;
+ end loop;
+ end if;
- Scop := Scope (E);
- if Elmt.Entity_Scope /= null then
- for J in reverse Elmt.Entity_Scope'Range loop
- if Elmt.Entity_Scope (J) /= Chars (Scop) then
+ -- Now see if compilation unit matches
+
+ for J in reverse Elmt.Unit_Name'Range loop
+ if Elmt.Unit_Name (J) /= Chars (Scop) then
goto Continue;
end if;
Scop := Scope (Scop);
- if not Is_Compilation_Unit (Scop) and then J = 1 then
+ if Scop /= Standard_Standard and then J = 1 then
goto Continue;
end if;
end loop;
- end if;
-
- -- Now see if compilation unit matches
-
- for J in reverse Elmt.Unit_Name'Range loop
- if Elmt.Unit_Name (J) /= Chars (Scop) then
- goto Continue;
- end if;
- Scop := Scope (Scop);
-
- if Scop /= Standard_Standard and then J = 1 then
+ if Scop /= Standard_Standard then
goto Continue;
end if;
- end loop;
-
- if Scop /= Standard_Standard then
- goto Continue;
- end if;
-
- -- Check for case of given entity is a library level subprogram
- -- and we have the single parameter Eliminate case, a match!
-
- if Is_Compilation_Unit (E)
- and then Is_Subprogram (E)
- and then No (Elmt.Entity_Node)
- then
- Set_Is_Eliminated (E);
- return;
-
- -- Check for case of type or object with two parameter case
- elsif (Is_Type (E) or else Is_Object (E))
- and then Elmt.Result_Type = No_Name
- and then Elmt.Parameter_Types = null
- then
- Set_Is_Eliminated (E);
- return;
+ -- Check for case of given entity is a library level subprogram
+ -- and we have the single parameter Eliminate case, a match!
- -- Check for case of subprogram
-
- elsif Ekind (E) = E_Function
- or else Ekind (E) = E_Procedure
- then
- -- If Homonym_Number present, then see if it matches
-
- if Elmt.Homonym_Number /= No_Uint then
- Ctr := 1;
-
- Ent := E;
- while Present (Homonym (Ent))
- and then Scope (Ent) = Scope (Homonym (Ent))
- loop
- Ctr := Ctr + 1;
- Ent := Homonym (Ent);
- end loop;
+ if Is_Compilation_Unit (E)
+ and then Is_Subprogram (E)
+ and then No (Elmt.Entity_Node)
+ then
+ Set_Eliminated;
+ return;
+
+ -- Check for case of type or object with two parameter case
+
+ elsif (Is_Type (E) or else Is_Object (E))
+ and then Elmt.Result_Type = No_Name
+ and then Elmt.Parameter_Types = null
+ then
+ Set_Eliminated;
+ return;
+
+ -- Check for case of subprogram
+
+ elsif Ekind (E) = E_Function
+ or else Ekind (E) = E_Procedure
+ then
+ -- If Homonym_Number present, then see if it matches
+
+ if Elmt.Homonym_Number /= No_Uint then
+ Ctr := 1;
+
+ Ent := E;
+ while Present (Homonym (Ent))
+ and then Scope (Ent) = Scope (Homonym (Ent))
+ loop
+ Ctr := Ctr + 1;
+ Ent := Homonym (Ent);
+ end loop;
- if Ctr /= Elmt.Homonym_Number then
- goto Continue;
+ if Ctr /= Elmt.Homonym_Number then
+ goto Continue;
+ end if;
end if;
- end if;
- -- If we have a Result_Type, then we must have a function
- -- with the proper result type
+ -- If we have a Result_Type, then we must have a function
+ -- with the proper result type
- if Elmt.Result_Type /= No_Name then
- if Ekind (E) /= E_Function
- or else Chars (Etype (E)) /= Elmt.Result_Type
- then
- goto Continue;
+ if Elmt.Result_Type /= No_Name then
+ if Ekind (E) /= E_Function
+ or else Chars (Etype (E)) /= Elmt.Result_Type
+ then
+ goto Continue;
+ end if;
end if;
- end if;
- -- If we have Parameter_Types, they must match
+ -- If we have Parameter_Types, they must match
- if Elmt.Parameter_Types /= null then
- Form := First_Formal (E);
+ if Elmt.Parameter_Types /= null then
+ Form := First_Formal (E);
- if No (Form) and then Elmt.Parameter_Types = null then
- null;
+ if No (Form) and then Elmt.Parameter_Types = null then
+ null;
- elsif Elmt.Parameter_Types = null then
- goto Continue;
+ elsif Elmt.Parameter_Types = null then
+ goto Continue;
- else
- for J in Elmt.Parameter_Types'Range loop
- if No (Form)
- or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
- then
+ else
+ for J in Elmt.Parameter_Types'Range loop
+ if No (Form)
+ or else
+ Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
+ then
+ goto Continue;
+ else
+ Next_Formal (Form);
+ end if;
+ end loop;
+
+ if Present (Form) then
goto Continue;
- else
- Next_Formal (Form);
end if;
- end loop;
-
- if Present (Form) then
- goto Continue;
end if;
end if;
- end if;
- -- If we fall through, this is match
+ -- If we fall through, this is match
- Set_Is_Eliminated (E);
- return;
- end if;
+ Set_Eliminated;
+ return;
+ end if;
- <<Continue>> Elmt := Elmt.Homonym;
+ <<Continue>> Elmt := Elmt.Homonym;
+ end;
end loop;
return;
end Check_Eliminated;
+ -------------------------
+ -- Eliminate_Error_Msg --
+ -------------------------
+
+ procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
+ begin
+ for J in Elim_Entities.First .. Elim_Entities.Last loop
+ if E = Elim_Entities.Table (J).Subp then
+ Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
+ Error_Msg_NE ("cannot call subprogram & eliminated #", N, E);
+ return;
+ end if;
+ end loop;
+
+ -- Should never fall through, since entry should be in table
+
+ pragma Assert (False);
+ end Eliminate_Error_Msg;
+
----------------
-- Initialize --
----------------
@@ -360,6 +421,7 @@ package body Sem_Elim is
procedure Initialize is
begin
Elim_Hash_Table.Reset;
+ Elim_Entities.Init;
No_Elimination := True;
end Initialize;
@@ -368,7 +430,8 @@ package body Sem_Elim is
------------------------------
procedure Process_Eliminate_Pragma
- (Arg_Unit_Name : Node_Id;
+ (Pragma_Node : Node_Id;
+ Arg_Unit_Name : Node_Id;
Arg_Entity : Node_Id;
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id;
@@ -416,6 +479,7 @@ package body Sem_Elim is
-- Start of processing for Process_Eliminate_Pragma
begin
+ Data.Prag := Pragma_Node;
Error_Msg_Name_1 := Name_Eliminate;
-- Process Unit_Name argument
Index: sem_elim.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elim.ads,v
retrieving revision 1.5
diff -u -p -r1.5 sem_elim.ads
--- sem_elim.ads 24 Apr 2003 17:54:17 -0000 1.5
+++ sem_elim.ads 5 Jan 2004 13:15:46 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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,21 +34,30 @@ package Sem_Elim is
-- Initialize for new main souce program
procedure Process_Eliminate_Pragma
- (Arg_Unit_Name : Node_Id;
+ (Pragma_Node : Node_Id;
+ Arg_Unit_Name : Node_Id;
Arg_Entity : Node_Id;
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id;
Arg_Homonym_Number : Node_Id);
- -- Process eliminate pragma. The number of arguments has been checked,
- -- as well as possible optional identifiers, but no other checks have
- -- been made. This subprogram completes the checking, and then if the
- -- pragma is well formed, makes appropriate entries in the internal
- -- tables used to keep track of Eliminate pragmas. The five arguments
- -- are expressions (not pragma argument associations) for the possible
- -- pragma arguments. A parameter that is not present is set to Empty.
+ -- Process eliminate pragma (given by Pragma_Node). The number of
+ -- arguments has been checked, as well as possible optional identifiers,
+ -- but no other checks have been made. This subprogram completes the
+ -- checking, and then if the pragma is well formed, makes appropriate
+ -- entries in the internal tables used to keep track of Eliminate pragmas.
+ -- The other five arguments are expressions (rather than pragma argument
+ -- associations) for the possible pragma arguments. A parameter that
+ -- is not present is set to Empty.
procedure Check_Eliminated (E : Entity_Id);
-- Checks if entity E is eliminated, and if so sets the Is_Eliminated
-- flag on the given entity.
+
+ procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id);
+ -- Called by the back end on encouterning a call to an eliminated
+ -- subprogram. N is the node for the call, and E is the entity of
+ -- the subprogram being eliminated.
+
+
end Sem_Elim;
Index: sem_eval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_eval.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_eval.adb
--- sem_eval.adb 21 Oct 2003 13:42:20 -0000 1.10
+++ sem_eval.adb 5 Jan 2004 13:15:46 -0000
@@ -2279,63 +2279,91 @@ package body Sem_Eval is
-------------------------
procedure Eval_String_Literal (N : Node_Id) is
- T : constant Entity_Id := Etype (N);
- B : constant Entity_Id := Base_Type (T);
- I : Entity_Id;
+ Typ : constant Entity_Id := Etype (N);
+ Bas : constant Entity_Id := Base_Type (Typ);
+ Xtp : Entity_Id;
+ Len : Nat;
+ Lo : Node_Id;
begin
-- Nothing to do if error type (handles cases like default expressions
-- or generics where we have not yet fully resolved the type)
- if B = Any_Type or else B = Any_String then
+ if Bas = Any_Type or else Bas = Any_String then
return;
+ end if;
-- String literals are static if the subtype is static (RM 4.9(2)), so
-- reset the static expression flag (it was set unconditionally in
-- Analyze_String_Literal) if the subtype is non-static. We tell if
-- the subtype is static by looking at the lower bound.
- elsif not Is_OK_Static_Expression (String_Literal_Low_Bound (T)) then
+ if Ekind (Typ) = E_String_Literal_Subtype then
+ if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+
+ -- Here if Etype of string literal is normal Etype (not yet possible,
+ -- but may be possible in future!)
+
+ elsif not Is_OK_Static_Expression
+ (Type_Low_Bound (Etype (First_Index (Typ))))
+ then
Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+
+ -- If original node was a type conversion, then result if non-static
- elsif Nkind (Original_Node (N)) = N_Type_Conversion then
+ if Nkind (Original_Node (N)) = N_Type_Conversion then
Set_Is_Static_Expression (N, False);
+ return;
+ end if;
-- Test for illegal Ada 95 cases. A string literal is illegal in
-- Ada 95 if its bounds are outside the index base type and this
- -- index type is static. This can hapen in only two ways. Either
+ -- index type is static. This can happen in only two ways. Either
-- the string literal is too long, or it is null, and the lower
-- bound is type'First. In either case it is the upper bound that
-- is out of range of the index type.
- elsif Ada_95 then
- if Root_Type (B) = Standard_String
- or else Root_Type (B) = Standard_Wide_String
+ if Ada_95 then
+ if Root_Type (Bas) = Standard_String
+ or else
+ Root_Type (Bas) = Standard_Wide_String
then
- I := Standard_Positive;
+ Xtp := Standard_Positive;
else
- I := Etype (First_Index (B));
+ Xtp := Etype (First_Index (Bas));
end if;
- if String_Literal_Length (T) > String_Type_Len (B) then
+ if Ekind (Typ) = E_String_Literal_Subtype then
+ Lo := String_Literal_Low_Bound (Typ);
+ else
+ Lo := Type_Low_Bound (Etype (First_Index (Typ)));
+ end if;
+
+ Len := String_Length (Strval (N));
+
+ if UI_From_Int (Len) > String_Type_Len (Bas) then
Apply_Compile_Time_Constraint_Error
(N, "string literal too long for}", CE_Length_Check_Failed,
- Ent => B,
- Typ => First_Subtype (B));
+ Ent => Bas,
+ Typ => First_Subtype (Bas));
- elsif String_Literal_Length (T) = 0
- and then not Is_Generic_Type (I)
- and then Expr_Value (String_Literal_Low_Bound (T)) =
- Expr_Value (Type_Low_Bound (Base_Type (I)))
+ elsif Len = 0
+ and then not Is_Generic_Type (Xtp)
+ and then
+ Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
then
Apply_Compile_Time_Constraint_Error
(N, "null string literal not allowed for}",
CE_Length_Check_Failed,
- Ent => B,
- Typ => First_Subtype (B));
+ Ent => Bas,
+ Typ => First_Subtype (Bas));
end if;
end if;
-
end Eval_String_Literal;
--------------------------
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_prag.adb
--- sem_prag.adb 11 Dec 2003 16:21:39 -0000 1.15
+++ sem_prag.adb 5 Jan 2004 13:15:46 -0000
@@ -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- --
@@ -2763,6 +2763,7 @@ package body Sem_Prag is
declare
Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
+
begin
if Present (Decl)
and then Nkind (Decl) = N_Subprogram_Declaration
@@ -2856,7 +2857,7 @@ package body Sem_Prag is
----------------------------
function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
- Decl : Node_Id := Unit_Declaration_Node (Subp);
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
begin
if Nkind (Decl) = N_Subprogram_Body then
@@ -4186,7 +4187,8 @@ package body Sem_Prag is
if Expander_Active then
declare
- Temp : Node_Id := New_Copy_Tree (Expression (Arg2));
+ Temp : constant Node_Id :=
+ New_Copy_Tree (Expression (Arg2));
begin
Set_Parent (Temp, N);
Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
@@ -5293,7 +5295,8 @@ package body Sem_Prag is
end if;
Process_Eliminate_Pragma
- (Unit_Name,
+ (N,
+ Unit_Name,
Entity,
Parameter_Types,
Result_Type,
@@ -7378,9 +7381,13 @@ package body Sem_Prag is
No_Run_Time_Mode := True;
Configurable_Run_Time_Mode := True;
- if Ttypes.System_Word_Size = 32 then
- Duration_32_Bits_On_Target := True;
- end if;
+ declare
+ Word32 : constant Boolean := Ttypes.System_Word_Size = 32;
+ begin
+ if Word32 then
+ Duration_32_Bits_On_Target := True;
+ end if;
+ end;
Restrictions (No_Finalization) := True;
Restrictions (No_Exception_Handlers) := True;
@@ -9776,7 +9783,7 @@ package body Sem_Prag is
-- than appearence as any argument is insignificant, a positive value
-- indicates that appearence in that parameter position is significant.
- Sig_Flags : array (Pragma_Id) of Int :=
+ Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_res.adb
--- sem_res.adb 17 Dec 2003 13:37:03 -0000 1.16
+++ sem_res.adb 5 Jan 2004 13:15:47 -0000
@@ -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- --
@@ -1832,7 +1832,24 @@ package body Sem_Res is
-- doesn't think of them this way!)
if Typ = Standard_Void_Type then
- Error_Msg_N ("expect procedure name in procedure call", N);
+
+ -- Special case message if function used as a procedure
+
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (N))
+ and then Ekind (Entity (Name (N))) = E_Function
+ then
+ Error_Msg_NE
+ ("cannot use function & in a procedure call",
+ Name (N), Entity (Name (N)));
+
+ -- Otherwise give general message (not clear what cases
+ -- this covers, but no harm in providing for them!)
+
+ else
+ Error_Msg_N ("expect procedure name in procedure call", N);
+ end if;
+
Found := True;
-- Otherwise we do have a subexpression with the wrong type
@@ -6535,10 +6552,10 @@ package body Sem_Res is
Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
- Set_String_Literal_Length (Subtype_Id,
- UI_From_Int (String_Length (Strval (N))));
- Set_Etype (Subtype_Id, Base_Type (Typ));
- Set_Is_Constrained (Subtype_Id);
+ Set_String_Literal_Length (Subtype_Id, UI_From_Int
+ (String_Length (Strval (N))));
+ Set_Etype (Subtype_Id, Base_Type (Typ));
+ Set_Is_Constrained (Subtype_Id);
-- The low bound is set from the low bound of the corresponding
-- index type. Note that we do not store the high bound in the
Index: sem_res.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.ads,v
retrieving revision 1.5
diff -u -p -r1.5 sem_res.ads
--- sem_res.ads 21 Oct 2003 13:42:22 -0000 1.5
+++ sem_res.ads 5 Jan 2004 13:15:47 -0000
@@ -59,7 +59,6 @@ package Sem_Res is
-- specified check suppressed (can be All_Checks to suppress all checks).
procedure Resolve (N : Node_Id);
- pragma Inline (Resolve);
-- A version of Resolve where the type to be used for resolution is
-- taken from the Etype (N). This is commonly used in cases where the
-- context does not add anything and the first pass of analysis found
@@ -117,5 +116,11 @@ package Sem_Res is
procedure Pre_Analyze_And_Resolve (N : Node_Id);
-- Same, but use type of node because context does not impose a single
-- type.
+
+private
+ procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve;
+ pragma Inline (Resolve_Implicit_Type);
+ -- We use this renaming to make the application of Inline very explicit
+ -- to this version, since other versions of Resolve are not inlined.
end Sem_Res;
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_util.adb
--- sem_util.adb 11 Dec 2003 16:21:39 -0000 1.17
+++ sem_util.adb 5 Jan 2004 13:15:47 -0000
@@ -3554,13 +3554,13 @@ package body Sem_Util is
function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
Loc : constant Source_Ptr := Sloc (Typ);
+ Constraints : constant List_Id := New_List;
+ Components : constant Elist_Id := New_Elmt_List;
Comp_Elmt : Elmt_Id;
Comp_Id : Node_Id;
Comp_List : Node_Id;
Discr : Entity_Id;
Discr_Val : Node_Id;
- Constraints : List_Id := New_List;
- Components : Elist_Id := New_Elmt_List;
Report_Errors : Boolean;
begin
@@ -6038,13 +6038,14 @@ package body Sem_Util is
-----------------------
function Type_Access_Level (Typ : Entity_Id) return Uint is
- Btyp : Entity_Id := Base_Type (Typ);
+ Btyp : Entity_Id;
begin
-- If the type is an anonymous access type we treat it as being
-- declared at the library level to ensure that names such as
-- X.all'access don't fail static accessibility checks.
+ Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
if Ekind (Btyp) = E_Anonymous_Access_Type then
return Scope_Depth (Standard_Standard);
Index: sem_util.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.ads,v
retrieving revision 1.8
diff -u -p -r1.8 sem_util.ads
--- sem_util.ads 21 Oct 2003 13:42:22 -0000 1.8
+++ sem_util.ads 5 Jan 2004 13:15:47 -0000
@@ -639,7 +639,7 @@ package Sem_Util is
procedure Process_End_Label
(N : Node_Id;
Typ : Character;
- Ent : Entity_Id);
+ Ent : Entity_Id);
-- N is a node whose End_Label is to be processed, generating all
-- appropriate cross-reference entries, and performing style checks
-- for any identifier references in the end label. Typ is either
@@ -776,7 +776,7 @@ package Sem_Util is
-- Is_Public based upon the new scope.
function Type_Access_Level (Typ : Entity_Id) return Uint;
- -- Return the accessibility level of Typ.
+ -- Return the accessibility level of Typ
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns
Index: s-interr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-interr.adb,v
retrieving revision 1.8
diff -u -p -r1.8 s-interr.adb
--- s-interr.adb 3 Dec 2003 11:47:53 -0000 1.8
+++ s-interr.adb 5 Jan 2004 13:15:47 -0000
@@ -346,8 +346,7 @@ package body System.Interrupts is
---------------------
function Current_Handler
- (Interrupt : Interrupt_ID)
- return Parameterless_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
if Is_Reserved (Interrupt) then
@@ -455,21 +454,17 @@ package body System.Interrupts is
-- Need comments as to why these always return True
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
+ (Object : access Dynamic_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
+ (Object : access Static_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -686,8 +681,7 @@ package body System.Interrupts is
------------------
function Unblocked_By
- (Interrupt : Interrupt_ID)
- return System.Tasking.Task_ID
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_ID
is
begin
if Is_Reserved (Interrupt) then
Index: s-poosiz.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-poosiz.adb,v
retrieving revision 1.5
diff -u -p -r1.5 s-poosiz.adb
--- s-poosiz.adb 21 Oct 2003 13:42:14 -0000 1.5
+++ s-poosiz.adb 5 Jan 2004 13:15:47 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -32,6 +32,7 @@
------------------------------------------------------------------------------
with System.Storage_Elements;
+with System.Soft_Links;
with Unchecked_Conversion;
@@ -40,6 +41,16 @@ package body System.Pool_Size is
package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
+ -- Even though these storage pools are typically only used
+ -- by a single task, if multiple tasks are declared at the
+ -- same or a more nested scope as the storage pool, there
+ -- still may be concurrent access. The current implementation
+ -- of Stack_Bounded_Pool always uses a global lock for protecting
+ -- access. This should eventually be replaced by an atomic
+ -- linked list implementation for efficiency reasons.
+
+ package SSL renames System.Soft_Links;
+
type Storage_Count_Access is access SSE.Storage_Count;
function To_Storage_Count_Access is
new Unchecked_Conversion (Address, Storage_Count_Access);
@@ -82,6 +93,8 @@ package body System.Pool_Size is
Alignment : SSE.Storage_Count)
is
begin
+ SSL.Lock_Task.all;
+
if Pool.Elmt_Size = 0 then
Vsize.Allocate (Pool, Address, Storage_Size, Alignment);
@@ -98,6 +111,13 @@ package body System.Pool_Size is
else
raise Storage_Error;
end if;
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Allocate;
----------------
@@ -111,6 +131,8 @@ package body System.Pool_Size is
Alignment : SSE.Storage_Count)
is
begin
+ SSL.Lock_Task.all;
+
if Pool.Elmt_Size = 0 then
Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
@@ -118,6 +140,12 @@ package body System.Pool_Size is
To_Storage_Count_Access (Address).all := Pool.First_Free;
Pool.First_Free := Address - Pool.The_Pool'Address + 1;
end if;
+
+ SSL.Unlock_Task.all;
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Deallocate;
----------------
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sprint.adb
--- sprint.adb 20 Nov 2003 09:54:02 -0000 1.12
+++ sprint.adb 5 Jan 2004 13:15:47 -0000
@@ -90,7 +90,7 @@ package body Sprint is
-- with a lower precedence than the operator (or equal precedence if
-- appearing as the right operand), then parentheses are required.
- Op_Prec : array (N_Subexpr) of Short_Short_Integer :=
+ Op_Prec : constant array (N_Subexpr) of Short_Short_Integer :=
(N_Op_And => 1,
N_Op_Or => 1,
N_Op_Xor => 1,
Index: s-secsta.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-secsta.adb,v
retrieving revision 1.6
diff -u -p -r1.6 s-secsta.adb
--- s-secsta.adb 21 Oct 2003 13:42:14 -0000 1.6
+++ s-secsta.adb 5 Jan 2004 13:15:47 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- 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- --
@@ -45,6 +45,27 @@ package body System.Secondary_Stack is
SS_Ratio_Dynamic : constant Boolean :=
Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
+ -- There are two entirely different implementations of the secondary
+ -- stack mechanism in this unit, and this Boolean is used to select
+ -- between them (at compile time, so the generated code will contain
+ -- only the code for the desired variant). If SS_Ratio_Dynamic is
+ -- True, then the secondary stack is dynamically allocated from the
+ -- heap in a linked list of chunks. If SS_Ration_Dynamic is False,
+ -- then the secondary stack is allocated statically by grabbing a
+ -- section of the primary stack and using it for this purpose.
+
+ type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
+ for Memory'Alignment use Standard'Maximum_Alignment;
+ -- This is the type used for actual allocation of secondary stack
+ -- areas. We require maximum alignment for all such allocations.
+
+ ---------------------------------------------------------------
+ -- Data Structures for Dynamically Allocated Secondary Stack --
+ ---------------------------------------------------------------
+
+ -- The following is a diagram of the data structures used for the
+ -- case of a dynamically allocated secondary stack, where the stack
+ -- is allocated as a linked list of chunks allocated from the heap.
-- +------------------+
-- | Next |
@@ -76,8 +97,6 @@ package body System.Secondary_Stack is
-- | Default_Size | | Prev |
-- +-----------------+ +------------------+
--
- --
- type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
type Chunk_Id (First, Last : Mark_Id);
type Chunk_Ptr is access all Chunk_Id;
@@ -93,198 +112,302 @@ package body System.Secondary_Stack is
Current_Chunk : Chunk_Ptr;
end record;
+ type Stack_Ptr is access Stack_Id;
+ -- Pointer to record used to represent a dynamically allocated secondary
+ -- stack descriptor for a secondary stack chunk.
+
+ procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
+ -- Free a dynamically allocated chunk
+
+ function To_Stack_Ptr is new
+ Unchecked_Conversion (Address, Stack_Ptr);
+ function To_Addr is new
+ Unchecked_Conversion (Stack_Ptr, Address);
+ -- Convert to and from address stored in task data structures
+
+ --------------------------------------------------------------
+ -- Data Structures for Statically Allocated Secondary Stack --
+ --------------------------------------------------------------
+
+ -- For the static case, the secondary stack is a single contiguous
+ -- chunk of storage, carved out of the primary stack, and represented
+ -- by the following data strcuture
+
type Fixed_Stack_Id is record
- Top : Mark_Id;
+ Top : Mark_Id;
+ -- Index of next available location in Mem. This is initialized to
+ -- 0, and then incremented on Allocate, and Decremented on Release.
+
Last : Mark_Id;
- Mem : Memory (1 .. Mark_Id'Last / 2 - 1);
- -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi
- -- with this type, introduced Sep 2001, that causes gigi to reject this
- -- type because its size in bytes overflows ???
+ -- Length of usable Mem array, which is thus the index past the
+ -- last available location in Mem. Mem (Last-1) can be used. This
+ -- is used to check that the stack does not overflow.
+
+ Max : Mark_Id;
+ -- Maximum value of Top. Initialized to 0, and then may be incremented
+ -- on Allocate, but is never Decremented. The last used location will
+ -- be Mem (Max - 1), so Max is the maximum count of used stack space.
+
+ Mem : Memory (0 .. 0);
+ -- This is the area that is actually used for the secondary stack.
+ -- Note that the upper bound is a dummy value properly defined by
+ -- the value of Last. We never actually allocate objects of type
+ -- Fixed_Stack_Id, so the bounds declared here do not matter.
end record;
- type Stack_Ptr is access Stack_Id;
- type Fixed_Stack_Ptr is access Fixed_Stack_Id;
+ Dummy_Fixed_Stack : Fixed_Stack_Id;
+ pragma Warnings (Off, Dummy_Fixed_Stack);
+ -- Well it is not quite true that we never allocate an object of the
+ -- type. This dummy object is allocated for the purpose of getting the
+ -- offset of the Mem field via the 'Position attribute (such a nuisance
+ -- that we cannot apply this to a field of a type!)
- function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr);
- function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address);
- function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr);
+ type Fixed_Stack_Ptr is access Fixed_Stack_Id;
+ -- Pointer to record used to describe statically allocated sec stack
- procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
+ function To_Fixed_Stack_Ptr is new
+ Unchecked_Conversion (Address, Fixed_Stack_Ptr);
+ -- Convert from address stored in task data structures
--------------
-- Allocate --
--------------
procedure SS_Allocate
- (Address : out System.Address;
+ (Addr : out Address;
Storage_Size : SSE.Storage_Count)
is
- Stack : constant Stack_Ptr :=
- From_Addr (SSL.Get_Sec_Stack_Addr.all);
- Fixed_Stack : Fixed_Stack_Ptr;
- Chunk : Chunk_Ptr;
Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
Max_Size : constant Mark_Id :=
((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
* Max_Align;
- To_Be_Released_Chunk : Chunk_Ptr;
-
begin
- -- If the secondary stack is fixed in the primary stack, then the
- -- handling becomes simple
+ -- Case of fixed allocation secondary stack
if not SS_Ratio_Dynamic then
- Fixed_Stack := To_Fixed (Stack);
+ declare
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
- if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
- raise Storage_Error;
- end if;
+ begin
+ -- Check if max stack usage is increasing
- Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
- Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size);
- return;
- end if;
+ if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
+
+ -- If so, check if max size is exceeded
+
+ if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
+ raise Storage_Error;
+ end if;
+
+ -- Record new max usage
- Chunk := Stack.Current_Chunk;
+ Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
+ end if;
+
+ -- Set resulting address and update top of stack pointer
- -- The Current_Chunk may not be the good one if a lot of release
- -- operations have taken place. So go down the stack if necessary
+ Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
+ Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
+ end;
- while Chunk.First > Stack.Top loop
- Chunk := Chunk.Prev;
- end loop;
+ -- Case of dynamically allocated secondary stack
- -- Find out if the available memory in the current chunk is sufficient.
- -- if not, go to the next one and eventally create the necessary room
+ else
+ declare
+ Stack : constant Stack_Ptr :=
+ To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+ Chunk : Chunk_Ptr;
- while Chunk.Last - Stack.Top + 1 < Max_Size loop
- if Chunk.Next /= null then
+ To_Be_Released_Chunk : Chunk_Ptr;
- -- Release unused non-first empty chunk
+ begin
+ Chunk := Stack.Current_Chunk;
- if Chunk.Prev /= null and then Chunk.First = Stack.Top then
- To_Be_Released_Chunk := Chunk;
+ -- The Current_Chunk may not be the good one if a lot of release
+ -- operations have taken place. So go down the stack if necessary
+
+ while Chunk.First > Stack.Top loop
Chunk := Chunk.Prev;
- Chunk.Next := To_Be_Released_Chunk.Next;
- To_Be_Released_Chunk.Next.Prev := Chunk;
- Free (To_Be_Released_Chunk);
- end if;
+ end loop;
- -- Create new chunk of the default size unless it is not sufficient
+ -- Find out if the available memory in the current chunk is
+ -- sufficient, if not, go to the next one and eventally create
+ -- the necessary room.
- elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
- Chunk.Next := new Chunk_Id (
- First => Chunk.Last + 1,
- Last => Chunk.Last + Mark_Id (Stack.Default_Size));
+ while Chunk.Last - Stack.Top + 1 < Max_Size loop
+ if Chunk.Next /= null then
- Chunk.Next.Prev := Chunk;
+ -- Release unused non-first empty chunk
- else
- Chunk.Next := new Chunk_Id (
- First => Chunk.Last + 1,
- Last => Chunk.Last + Max_Size);
+ if Chunk.Prev /= null and then Chunk.First = Stack.Top then
+ To_Be_Released_Chunk := Chunk;
+ Chunk := Chunk.Prev;
+ Chunk.Next := To_Be_Released_Chunk.Next;
+ To_Be_Released_Chunk.Next.Prev := Chunk;
+ Free (To_Be_Released_Chunk);
+ end if;
- Chunk.Next.Prev := Chunk;
- end if;
+ -- Create new chunk of default size unless it is not
+ -- sufficient to satisfy the current request.
- Chunk := Chunk.Next;
- Stack.Top := Chunk.First;
- end loop;
+ elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
+ Chunk.Next :=
+ new Chunk_Id
+ (First => Chunk.Last + 1,
+ Last => Chunk.Last + Mark_Id (Stack.Default_Size));
- -- Resulting address is the address pointed by Stack.Top
+ Chunk.Next.Prev := Chunk;
- Address := Chunk.Mem (Stack.Top)'Address;
- Stack.Top := Stack.Top + Max_Size;
- Stack.Current_Chunk := Chunk;
+ -- Otherwise create new chunk of requested size
+
+ else
+ Chunk.Next :=
+ new Chunk_Id
+ (First => Chunk.Last + 1,
+ Last => Chunk.Last + Max_Size);
+
+ Chunk.Next.Prev := Chunk;
+ end if;
+
+ Chunk := Chunk.Next;
+ Stack.Top := Chunk.First;
+ end loop;
+
+ -- Resulting address is the address pointed by Stack.Top
+
+ Addr := Chunk.Mem (Stack.Top)'Address;
+ Stack.Top := Stack.Top + Max_Size;
+ Stack.Current_Chunk := Chunk;
+ end;
+ end if;
end SS_Allocate;
-------------
-- SS_Free --
-------------
- procedure SS_Free (Stk : in out System.Address) is
- Stack : Stack_Ptr;
- Chunk : Chunk_Ptr;
-
- procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
-
+ procedure SS_Free (Stk : in out Address) is
begin
+ -- Case of statically allocated secondary stack, nothing to free
+
if not SS_Ratio_Dynamic then
return;
- end if;
- Stack := From_Addr (Stk);
- Chunk := Stack.Current_Chunk;
+ -- Case of dynamically allocated secondary stack
+
+ else
+ declare
+ Stack : Stack_Ptr := To_Stack_Ptr (Stk);
+ Chunk : Chunk_Ptr;
+
+ procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
- while Chunk.Prev /= null loop
- Chunk := Chunk.Prev;
- end loop;
-
- while Chunk.Next /= null loop
- Chunk := Chunk.Next;
- Free (Chunk.Prev);
- end loop;
-
- Free (Chunk);
- Free (Stack);
- Stk := Null_Address;
+ begin
+ Chunk := Stack.Current_Chunk;
+
+ while Chunk.Prev /= null loop
+ Chunk := Chunk.Prev;
+ end loop;
+
+ while Chunk.Next /= null loop
+ Chunk := Chunk.Next;
+ Free (Chunk.Prev);
+ end loop;
+
+ Free (Chunk);
+ Free (Stack);
+ Stk := Null_Address;
+ end;
+ end if;
end SS_Free;
+ ----------------
+ -- SS_Get_Max --
+ ----------------
+
+ function SS_Get_Max return Long_Long_Integer is
+ begin
+ if SS_Ratio_Dynamic then
+ return -1;
+ else
+ declare
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+ begin
+ return Long_Long_Integer (Fixed_Stack.Max);
+ end;
+ end if;
+ end SS_Get_Max;
+
-------------
-- SS_Info --
-------------
procedure SS_Info is
- Stack : constant Stack_Ptr :=
- From_Addr (SSL.Get_Sec_Stack_Addr.all);
- Fixed_Stack : Fixed_Stack_Ptr;
- Nb_Chunks : Integer := 1;
- Chunk : Chunk_Ptr := Stack.Current_Chunk;
-
begin
Put_Line ("Secondary Stack information:");
+ -- Case of fixed secondary stack
+
if not SS_Ratio_Dynamic then
- Fixed_Stack := To_Fixed (Stack);
- Put_Line (
- " Total size : "
- & Mark_Id'Image (Fixed_Stack.Last)
- & " bytes");
- Put_Line (
- " Current allocated space : "
- & Mark_Id'Image (Fixed_Stack.Top - 1)
- & " bytes");
- return;
- end if;
+ declare
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+
+ begin
+ Put_Line (
+ " Total size : "
+ & Mark_Id'Image (Fixed_Stack.Last)
+ & " bytes");
+
+ Put_Line (
+ " Current allocated space : "
+ & Mark_Id'Image (Fixed_Stack.Top - 1)
+ & " bytes");
+ end;
+
+ -- Case of dynamically allocated secondary stack
+
+ else
+ declare
+ Stack : constant Stack_Ptr :=
+ To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+ Nb_Chunks : Integer := 1;
+ Chunk : Chunk_Ptr := Stack.Current_Chunk;
+
+ begin
+ while Chunk.Prev /= null loop
+ Chunk := Chunk.Prev;
+ end loop;
- while Chunk.Prev /= null loop
- Chunk := Chunk.Prev;
- end loop;
-
- while Chunk.Next /= null loop
- Nb_Chunks := Nb_Chunks + 1;
- Chunk := Chunk.Next;
- end loop;
-
- -- Current Chunk information
-
- Put_Line (
- " Total size : "
- & Mark_Id'Image (Chunk.Last)
- & " bytes");
- Put_Line (
- " Current allocated space : "
- & Mark_Id'Image (Stack.Top - 1)
- & " bytes");
-
- Put_Line (
- " Number of Chunks : "
- & Integer'Image (Nb_Chunks));
-
- Put_Line (
- " Default size of Chunks : "
- & SSE.Storage_Count'Image (Stack.Default_Size));
+ while Chunk.Next /= null loop
+ Nb_Chunks := Nb_Chunks + 1;
+ Chunk := Chunk.Next;
+ end loop;
+
+ -- Current Chunk information
+
+ Put_Line (
+ " Total size : "
+ & Mark_Id'Image (Chunk.Last)
+ & " bytes");
+
+ Put_Line (
+ " Current allocated space : "
+ & Mark_Id'Image (Stack.Top - 1)
+ & " bytes");
+
+ Put_Line (
+ " Number of Chunks : "
+ & Integer'Image (Nb_Chunks));
+
+ Put_Line (
+ " Default size of Chunks : "
+ & SSE.Storage_Count'Image (Stack.Default_Size));
+ end;
+ end if;
end SS_Info;
-------------
@@ -292,33 +415,41 @@ package body System.Secondary_Stack is
-------------
procedure SS_Init
- (Stk : in out System.Address;
+ (Stk : in out Address;
Size : Natural := Default_Secondary_Stack_Size)
is
- Stack : Stack_Ptr;
- Fixed_Stack : Fixed_Stack_Ptr;
-
begin
- if not SS_Ratio_Dynamic then
- Fixed_Stack := To_Fixed (From_Addr (Stk));
- Fixed_Stack.Top := Fixed_Stack.Mem'First;
+ -- Case of fixed size secondary stack
- if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then
- Fixed_Stack.Last := 0;
- else
- Fixed_Stack.Last := Mark_Id (Size) -
- 2 * Mark_Id'Max_Size_In_Storage_Elements;
- end if;
+ if not SS_Ratio_Dynamic then
+ declare
+ Fixed_Stack : Fixed_Stack_Ptr := To_Fixed_Stack_Ptr (Stk);
- return;
- end if;
+ begin
+ Fixed_Stack.Top := 0;
+ Fixed_Stack.Max := 0;
+
+ if Size < Dummy_Fixed_Stack.Mem'Position then
+ Fixed_Stack.Last := 0;
+ else
+ Fixed_Stack.Last :=
+ Mark_Id (Size) - Dummy_Fixed_Stack.Mem'Position;
+ end if;
+ end;
- Stack := new Stack_Id;
- Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
- Stack.Top := 1;
- Stack.Default_Size := SSE.Storage_Count (Size);
+ -- Case of dynamically allocated secondary stack
- Stk := To_Addr (Stack);
+ else
+ declare
+ Stack : Stack_Ptr;
+ begin
+ Stack := new Stack_Id;
+ Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
+ Stack.Top := 1;
+ Stack.Default_Size := SSE.Storage_Count (Size);
+ Stk := To_Addr (Stack);
+ end;
+ end if;
end SS_Init;
-------------
@@ -327,7 +458,11 @@ package body System.Secondary_Stack is
function SS_Mark return Mark_Id is
begin
- return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top;
+ if SS_Ratio_Dynamic then
+ return To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+ else
+ return To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+ end if;
end SS_Mark;
----------------
@@ -336,30 +471,35 @@ package body System.Secondary_Stack is
procedure SS_Release (M : Mark_Id) is
begin
- From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ if SS_Ratio_Dynamic then
+ To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ else
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ end if;
end SS_Release;
-------------------------
-- Package Elaboration --
-------------------------
- -- Allocate a secondary stack for the main program to use.
+ -- Allocate a secondary stack for the main program to use
+
-- We make sure that the stack has maximum alignment. Some systems require
-- this (e.g. Sun), and in any case it is a good idea for efficiency.
Stack : aliased Stack_Id;
for Stack'Alignment use Standard'Maximum_Alignment;
- Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size);
+ Chunk : aliased Chunk_Id (1, Mark_Id (Default_Secondary_Stack_Size));
for Chunk'Alignment use Standard'Maximum_Alignment;
- Chunk_Address : System.Address;
+ Chunk_Address : Address;
begin
if SS_Ratio_Dynamic then
Stack.Top := 1;
Stack.Current_Chunk := Chunk'Access;
- Stack.Default_Size := Default_Secondary_Stack_Size;
+ Stack.Default_Size := SSE.Storage_Offset (Default_Secondary_Stack_Size);
System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
else
Index: s-secsta.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-secsta.ads,v
retrieving revision 1.6
diff -u -p -r1.6 s-secsta.ads
--- s-secsta.ads 21 Oct 2003 13:42:14 -0000 1.6
+++ s-secsta.ads 5 Jan 2004 13:15:47 -0000
@@ -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- --
@@ -37,11 +37,11 @@ package System.Secondary_Stack is
package SSE renames System.Storage_Elements;
- Default_Secondary_Stack_Size : constant := 10 * 1024;
- -- Default size of a secondary stack
+ Default_Secondary_Stack_Size : Natural := 10 * 1024;
+ -- Default size of a secondary stack. May be modified by binder -D switch
procedure SS_Init
- (Stk : in out System.Address;
+ (Stk : in out Address;
Size : Natural := Default_Secondary_Stack_Size);
-- Initialize the secondary stack with a main stack of the given Size.
--
@@ -62,15 +62,15 @@ package System.Secondary_Stack is
-- stack using System.Soft_Links.Get_Sec_Stack_Addr.
procedure SS_Allocate
- (Address : out System.Address;
+ (Addr : out Address;
Storage_Size : SSE.Storage_Count);
-- Allocate enough space for a 'Storage_Size' bytes object with Maximum
- -- alignment. The address of the allocated space is returned in 'Address'
+ -- alignment. The address of the allocated space is returned in Addr.
- procedure SS_Free (Stk : in out System.Address);
- -- Release the memory allocated for the Secondary Stack. That is to say,
- -- all the allocated chuncks.
- -- Upon return, Stk will be set to System.Null_Address
+ procedure SS_Free (Stk : in out Address);
+ -- Release the memory allocated for the Secondary Stack. That is
+ -- to say, all the allocated chunks. Upon return, Stk will be set
+ -- to System.Null_Address.
type Mark_Id is private;
-- Type used to mark the stack.
@@ -81,6 +81,14 @@ package System.Secondary_Stack is
procedure SS_Release (M : Mark_Id);
-- Restore the state of the stack corresponding to the mark M. If an
-- additional chunk have been allocated, it will never be freed during a
+
+ function SS_Get_Max return Long_Long_Integer;
+ -- Return maximum used space in storage units for the current secondary
+ -- stack. For a dynamically allocated secondary stack, the returned
+ -- result is always -1. For a statically allocated secondary stack,
+ -- the returned value shows the largest amount of space allocated so
+ -- far during execution of the program to the current secondary stack,
+ -- i.e. the secondary stack for the current task.
generic
with procedure Put_Line (S : String);
Index: s-stalib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-stalib.adb,v
retrieving revision 1.7
diff -u -p -r1.7 s-stalib.adb
--- s-stalib.adb 21 Oct 2003 13:42:14 -0000 1.7
+++ s-stalib.adb 5 Jan 2004 13:15:47 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
@@ -64,7 +64,7 @@ package body System.Standard_Library is
Inside_Elab_Final_Code : Integer := 0;
pragma Export (C, Inside_Elab_Final_Code, "__gnat_inside_elab_final_code");
- -- ???This variable is obsolete starting from 29/08 but cannot be removed
+ -- ???This variable is obsolete since 2001-08-29 but cannot be removed
-- ???right away due to the bootstrap problems
--------------------------
Index: s-tasdeb.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tasdeb.adb,v
retrieving revision 1.9
diff -u -p -r1.9 s-tasdeb.adb
--- s-tasdeb.adb 15 Dec 2003 11:51:00 -0000 1.9
+++ s-tasdeb.adb 5 Jan 2004 13:15:47 -0000
@@ -211,9 +211,7 @@ package body System.Tasking.Debug is
-- Set_Trace --
---------------
- procedure Set_Trace
- (Flag : Character;
- Value : Boolean := True) is
+ procedure Set_Trace (Flag : Character; Value : Boolean := True) is
begin
Trace_On (Flag) := Value;
end Set_Trace;
@@ -278,7 +276,8 @@ package body System.Tasking.Debug is
(Self_Id : Task_ID;
Msg : String;
Flag : Character;
- Other_Id : Task_ID := null) is
+ Other_Id : Task_ID := null)
+ is
begin
if Trace_On (Flag) then
Put (To_Integer (Self_Id)'Img &
@@ -294,11 +293,16 @@ package body System.Tasking.Debug is
end if;
end Trace;
- procedure Write (Fd : Integer; S : String; Count : Integer) is
+ -----------
+ -- Write --
+ -----------
- Num : Integer;
+ procedure Write (Fd : Integer; S : String; Count : Integer) is
+ Discard : Integer;
+ pragma Unreferenced (Discard);
begin
- Num := System.CRTL.write (Fd, S (S'First)'Address, Count);
+ Discard := System.CRTL.write (Fd, S (S'First)'Address, Count);
+ -- Is it really right to ignore write errors here ???
end Write;
end System.Tasking.Debug;
Index: switch-b.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-b.adb,v
retrieving revision 1.5
diff -u -p -r1.5 switch-b.adb
--- switch-b.adb 21 Oct 2003 13:42:22 -0000 1.5
+++ switch-b.adb 5 Jan 2004 13:15:47 -0000
@@ -24,9 +24,9 @@
-- --
------------------------------------------------------------------------------
-with Debug; use Debug;
-with Osint; use Osint;
-with Opt; use Opt;
+with Debug; use Debug;
+with Osint; use Osint;
+with Opt; use Opt;
with System.WCh_Con; use System.WCh_Con;
@@ -58,7 +58,6 @@ package body Switch.B is
then
Osint.Fail ("invalid switch: """, Switch_Chars, """"
& " (gnat not needed here)");
-
end if;
-- Loop to scan through switches given in switch string
@@ -131,6 +130,12 @@ package body Switch.B is
end if;
return;
+
+ -- Processing for D switch
+
+ when 'D' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Default_Sec_Stack_Size);
-- Processing for e switch
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.9
diff -u -p -r1.9 switch-c.adb
--- switch-c.adb 5 Dec 2003 10:24:05 -0000 1.9
+++ switch-c.adb 5 Jan 2004 13:15:47 -0000
@@ -469,13 +469,27 @@ package body Switch.C is
when 'g' =>
Ptr := Ptr + 1;
- GNAT_Mode := True;
- Identifier_Character_Set := 'n';
- Warning_Mode := Treat_As_Error;
- Check_Unreferenced := True;
- Check_Withs := True;
- Check_Unreferenced_Formals := True;
- System_Extend_Unit := Empty;
+ GNAT_Mode := True;
+ Identifier_Character_Set := 'n';
+ System_Extend_Unit := Empty;
+ Warning_Mode := Treat_As_Error;
+
+ -- Set default warnings (basically -gnatwa)
+
+ Check_Unreferenced := True;
+ Check_Unreferenced_Formals := True;
+ Check_Withs := True;
+ Constant_Condition_Warnings := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Constant := True;
+ Warn_On_Export_Import := True;
+ Warn_On_Modified_Unread := True;
+ Warn_On_No_Value_Assigned := True;
+ Warn_On_Obsolescent_Feature := True;
+ Warn_On_Redundant_Constructs := True;
+ Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unrecognized_Pragma := True;
Set_Default_Style_Check_Options;
Index: switch-m.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-m.adb,v
retrieving revision 1.5
diff -u -p -r1.5 switch-m.adb
--- switch-m.adb 21 Oct 2003 13:42:22 -0000 1.5
+++ switch-m.adb 5 Jan 2004 13:15:47 -0000
@@ -484,6 +484,12 @@ package body Switch.M is
Bind_Only := True;
Make_Steps := True;
+ -- Processing for B switch
+
+ when 'B' =>
+ Ptr := Ptr + 1;
+ Build_Bind_And_Link_Full_Project := True;
+
-- Processing for c switch
when 'c' =>
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.40
diff -u -p -r1.40 trans.c
--- trans.c 20 Dec 2003 15:37:31 -0000 1.40
+++ trans.c 5 Jan 2004 13:15:47 -0000
@@ -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- *
@@ -3939,6 +3939,15 @@ tree_transform (Node_Id gnat_node)
tree gnu_obj_type;
tree gnu_obj_size;
int align;
+
+ /* If this is a thin pointer, we must dereference it to create
+ a fat pointer, then go back below to a thin pointer. The
+ reason for this is that we need a fat pointer someplace in
+ order to properly compute the size. */
+ if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
+ gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ gnu_ptr));
/* If this is an unconstrained array, we know the object must
have been allocated with the template in front of the object.
Index: vxaddr2line.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vxaddr2line.adb,v
retrieving revision 1.1
diff -u -p -r1.1 vxaddr2line.adb
--- vxaddr2line.adb 21 Oct 2003 13:42:23 -0000 1.1
+++ vxaddr2line.adb 5 Jan 2004 13:15:47 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002, 2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2003 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- --
@@ -26,17 +26,17 @@
-- This program is meant to be used with vxworks to compute symbolic
-- backtraces on the host from non-symbolic backtraces obtained on the target.
---
+
-- The basic idea is to automate the computation of the necessary address
-- adjustments prior to calling addr2line when the application has only been
-- partially linked on the host.
---
+
-- Variants for various targets are supported, and the command line should
-- be like :
---
+
-- <target>-addr2line [-a <target_arch>] <exe_file> <ref_address>
-- <backtrace addresses>
---
+
-- Where:
-- <target_arch> :
-- selects the target architecture. In the absence of this parameter the
@@ -45,20 +45,20 @@
-- Otherwise, the command name will always be of the form
-- <target>-vxaddr2line where there is no ambiguity on the target's
-- architecture.
---
+
-- <exe_file> :
-- The name of the partially linked binary file for the application.
---
+
-- <ref_address> :
-- Runtime address (on the target) of a reference symbol you choose,
-- which name shall match the value of the Ref_Symbol variable declared
-- below. A symbol with a small offset from the beginning of the text
-- segment is better, so "adainit" is a good choice.
---
+
-- <backtrace addresses> :
-- The call chain addresses you obtained at run time on the target and
-- for which you want a symbolic association.
---
+
-- TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type
-- (in a format <host>_<target>), and then an appropriate value to Config_List
-- array
@@ -75,7 +75,7 @@ with GNAT.Regpat; use GNAT.Regpat;
procedure VxAddr2Line is
- Ref_Symbol : String := "adainit";
+ Ref_Symbol : constant String := "adainit";
-- This is the name of the reference symbol which runtime address shall
-- be provided as the <ref_address> argument.
@@ -171,9 +171,11 @@ procedure VxAddr2Line is
-----------------
procedure Detect_Arch is
- Name : String := Base_Name (Command_Name);
- Proc : String := Name (Name'First .. Index (Name, "-") - 1);
- Target : String := Name (Name'First .. Index (Name, "vxaddr2line") - 1);
+ Name : constant String := Base_Name (Command_Name);
+ Proc : constant String :=
+ Name (Name'First .. Index (Name, "-") - 1);
+ Target : constant String :=
+ Name (Name'First .. Index (Name, "vxaddr2line") - 1);
begin
Detect_Success := False;
@@ -231,7 +233,7 @@ procedure VxAddr2Line is
Nm_Cmd : constant String_Access :=
Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all);
- Nm_Args : Argument_List :=
+ Nm_Args : constant Argument_List :=
(new String'("-P"),
new String'(Argument (1)));
@@ -260,9 +262,9 @@ procedure VxAddr2Line is
-- If we are here, the pattern was matched successfully
declare
- Match_String : String := Expect_Out_Match (Pd);
- Matches : Match_Array (0 .. 1);
- Value : Integer;
+ Match_String : constant String := Expect_Out_Match (Pd);
+ Matches : Match_Array (0 .. 1);
+ Value : Integer;
begin
Match (Reference, Match_String, Matches);
@@ -303,8 +305,8 @@ procedure VxAddr2Line is
----------------------------
function Get_Value_From_Hex_Arg (Arg : Natural) return Integer is
+ Cur_Arg : constant String := Argument (Arg);
Offset : Natural;
- Cur_Arg : String := Argument (Arg);
begin
-- Skip "0x" prefix if present
Index: xref_lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/xref_lib.adb,v
retrieving revision 1.7
diff -u -p -r1.7 xref_lib.adb
--- xref_lib.adb 20 Nov 2003 09:54:03 -0000 1.7
+++ xref_lib.adb 5 Jan 2004 13:15:47 -0000
@@ -142,7 +142,6 @@ package body Xref_Lib is
Line_Num : Natural := 0;
Col_Num : Natural := 0;
File_Ref : File_Reference := Empty_File;
- Has_Pattern : Boolean := False;
begin
-- Find the end of the first item in Entity (pattern or file?)
@@ -224,8 +223,7 @@ package body Xref_Lib is
end;
end;
- File_Start := File_Start + 1;
- Has_Pattern := True;
+ File_Start := File_Start + 1;
end if;
-- Parse the file name
@@ -291,6 +289,8 @@ package body Xref_Lib is
procedure Add_Xref_File (File : String) is
File_Ref : File_Reference := Empty_File;
+ pragma Unreferenced (File_Ref);
+
Iterator : Expansion_Iterator;
procedure Add_Xref_File_Internal (File : String);
@@ -307,7 +307,7 @@ package body Xref_Lib is
if Tail (File, 4) = ".ali" then
File_Ref := Add_To_Xref_File
- (File, Visited => False, Emit_Warning => True);
+ (File, Visited => False, Emit_Warning => True);
-- Normal non-ali file case
@@ -315,9 +315,8 @@ package body Xref_Lib is
File_Ref := Add_To_Xref_File (File, Visited => True);
File_Ref := Add_To_Xref_File
- (ALI_File_Name (File),
- Visited => False,
- Emit_Warning => True);
+ (ALI_File_Name (File),
+ Visited => False, Emit_Warning => True);
end if;
end Add_Xref_File_Internal;
@@ -404,10 +403,12 @@ package body Xref_Lib is
--------------------
procedure Find_ALI_Files is
- My_Dir : Rec_DIR;
- Dir_Ent : File_Name_String;
- Last : Natural;
- File_Ref : File_Reference;
+ My_Dir : Rec_DIR;
+ Dir_Ent : File_Name_String;
+ Last : Natural;
+
+ File_Ref : File_Reference;
+ pragma Unreferenced (File_Ref);
function Open_Next_Dir return Boolean;
-- Tries to open the next object directory, and return False if
@@ -568,12 +569,14 @@ package body Xref_Lib is
Token : Positive;
Ptr : Positive := Ali'First;
Num_Dependencies : Natural := 0;
- File_Ref : File_Reference;
File_Start : Positive;
File_End : Positive;
Gnatchop_Offset : Integer;
Gnatchop_Name : Positive;
+ File_Ref : File_Reference;
+ pragma Unreferenced (File_Ref);
+
begin
-- Read all the lines possibly processing with-clauses and dependency
-- information and exit on finding the first Xref line.
@@ -581,7 +584,6 @@ package body Xref_Lib is
-- which is an error condition.
while Ali (Ptr) /= EOF loop
-
if D_Lines and then Ali (Ptr) = 'D' then
-- Found dependency information. Format looks like:
@@ -636,8 +638,8 @@ package body Xref_Lib is
Parse_Token (Ali, Ptr, Token);
Parse_Token (Ali, Ptr, Token);
- File_Ref := Add_To_Xref_File
- (Ali (Token .. Ptr - 1), Visited => False);
+ File_Ref :=
+ Add_To_Xref_File (Ali (Token .. Ptr - 1), Visited => False);
elsif Ali (Ptr) = 'X' then
@@ -763,7 +765,6 @@ package body Xref_Lib is
E_Line : Natural; -- Line number of current entity
E_Col : Natural; -- Column number of current entity
E_Name : Positive; -- Pointer to begin of entity name
- E_Type : Character; -- Type of current entity
begin
-- Look for the X lines corresponding to unit Eun
@@ -783,7 +784,6 @@ package body Xref_Lib is
loop
Parse_Number (Ali, Ptr, E_Line);
- E_Type := Ali (Ptr);
exit when Ali (Ptr) = EOF;
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, E_Col);
@@ -885,7 +885,6 @@ package body Xref_Lib is
Parse_Derived_Info : declare
P_Line : Natural; -- parent entity line
P_Column : Natural; -- parent entity column
- P_Type : Character; -- parent entity type
P_Eun : Positive; -- parent entity file number
begin
@@ -913,7 +912,6 @@ package body Xref_Lib is
-- Then parse the type and column number
- P_Type := Ali (Ptr);
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, P_Column);
@@ -1034,9 +1032,9 @@ package body Xref_Lib is
if Wide_Search then
declare
- File_Ref : File_Reference;
- File_Name : constant String :=
- Get_Gnatchop_File (File.X_File);
+ File_Ref : File_Reference;
+ pragma Unreferenced (File_Ref);
+ File_Name : constant String := Get_Gnatchop_File (File.X_File);
begin
File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
end;
Index: xr_tabls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/xr_tabls.adb,v
retrieving revision 1.7
diff -u -p -r1.7 xr_tabls.adb
--- xr_tabls.adb 21 Oct 2003 13:42:23 -0000 1.7
+++ xr_tabls.adb 5 Jan 2004 13:15:48 -0000
@@ -749,8 +749,7 @@ package body Xr_Tabls is
function Get_File
(Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String
+ With_Dir : Boolean := False) return String
is
begin
return Get_File (Decl.Decl.File, With_Dir);
@@ -758,8 +757,7 @@ package body Xr_Tabls is
function Get_File
(Ref : Reference;
- With_Dir : Boolean := False)
- return String
+ With_Dir : Boolean := False) return String
is
begin
return Get_File (Ref.File, With_Dir);
@@ -768,8 +766,7 @@ package body Xr_Tabls is
function Get_File
(File : File_Reference;
With_Dir : in Boolean := False;
- Strip : Natural := 0)
- return String
+ Strip : Natural := 0) return String
is
Tmp : GNAT.OS_Lib.String_Access;
Index: xr_tabls.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/xr_tabls.ads,v
retrieving revision 1.6
diff -u -p -r1.6 xr_tabls.ads
--- xr_tabls.ads 21 Oct 2003 13:42:23 -0000 1.6
+++ xr_tabls.ads 5 Jan 2004 13:15:48 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 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- --
@@ -201,21 +201,19 @@ package Xr_Tabls is
function Get_File
(Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String;
+ With_Dir : Boolean := False) return String;
+ pragma Inline (Get_File);
-- Extract column number or file name from reference
function Get_File
(Ref : Reference;
- With_Dir : Boolean := False)
- return String;
+ With_Dir : Boolean := False) return String;
pragma Inline (Get_File);
function Get_File
(File : File_Reference;
With_Dir : Boolean := False;
- Strip : Natural := 0)
- return String;
+ Strip : Natural := 0) return String;
-- Returns the file name (and its directory if With_Dir is True or the
-- user has used the -f switch on the command line. If Strip is not 0,
-- then the last Strip-th "-..." substrings are removed first. For
@@ -223,7 +221,9 @@ package Xr_Tabls is
-- would be returned as "parent-child1.ali". This is used when looking
-- for the ALI file to use for a package, since for separates with have
-- to use the parent's ALI. The null string is returned if there is no
- -- such parent unit
+ -- such parent unit.
+ --
+ -- Note that this version of Get_File is not inlined
function Get_File_Ref (Ref : Reference) return File_Reference;
function Get_Line (Decl : Declaration_Reference) return String;
@@ -383,7 +383,6 @@ private
pragma Inline (Get_Column);
pragma Inline (Get_Emit_Warning);
- pragma Inline (Get_File);
pragma Inline (Get_File_Ref);
pragma Inline (Get_Line);
pragma Inline (Get_Symbol);
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.2
diff -u -p -r1.2 vms_conv.adb
--- vms_conv.adb 14 Nov 2003 10:24:44 -0000 1.2
+++ vms_conv.adb 5 Jan 2004 13:15:48 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -24,6 +24,7 @@
-- --
------------------------------------------------------------------------------
+with Gnatvsn;
with Hostparm;
with Osint; use Osint;
@@ -31,8 +32,6 @@ with Ada.Characters.Handling; use Ada.Ch
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with Gnatvsn;
-
package body VMS_Conv is
Param_Count : Natural := 0;
@@ -85,8 +84,7 @@ package body VMS_Conv is
function Matching_Name
(S : String;
Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr;
+ Quiet : Boolean := False) return Item_Ptr;
-- Determines if the item list headed by Itm and threaded through the
-- Next fields (with null marking the end of the list), contains an
-- entry that uniquely matches the given string. The match is case
@@ -452,8 +450,7 @@ package body VMS_Conv is
function Matching_Name
(S : String;
Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr
+ Quiet : Boolean := False) return Item_Ptr
is
P1, P2 : Item_Ptr;
@@ -620,7 +617,7 @@ package body VMS_Conv is
begin
Put ("GNAT ");
Put (Gnatvsn.Gnat_Version_String);
- Put_Line (" Copyright 1996-2003 Free Software Foundation, Inc.");
+ Put_Line (" Copyright 1996-2004 Free Software Foundation, Inc.");
end Output_Version;
-----------
@@ -1049,8 +1046,7 @@ package body VMS_Conv is
function Get_Arg_End
(Argv : String;
- Arg_Idx : Integer)
- return Integer;
+ Arg_Idx : Integer) return Integer;
-- Begins looking at Arg_Idx + 1 and returns the index of the
-- last character before a slash or else the index of the last
-- character in the string Argv.
@@ -1061,8 +1057,7 @@ package body VMS_Conv is
function Get_Arg_End
(Argv : String;
- Arg_Idx : Integer)
- return Integer
+ Arg_Idx : Integer) return Integer
is
begin
for J in Arg_Idx + 1 .. Argv'Last loop
@@ -1399,8 +1394,8 @@ package body VMS_Conv is
Arg1_Idx : Integer := Arg'First;
function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
+ (Arg : String;
+ Arg_Idx : Integer) return Integer;
-- Begins looking at Arg_Idx + 1 and
-- returns the index of the last character
-- before a comma or else the index of the
@@ -1411,8 +1406,8 @@ package body VMS_Conv is
------------------
function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
+ (Arg : String;
+ Arg_Idx : Integer) return Integer
is
begin
for J in Arg_Idx + 1 .. Arg'Last loop
Index: vms_data.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_data.ads,v
retrieving revision 1.3
diff -u -p -r1.3 vms_data.ads
--- vms_data.ads 14 Nov 2003 10:24:44 -0000 1.3
+++ vms_data.ads 5 Jan 2004 13:15:48 -0000
@@ -3577,6 +3577,20 @@ package VMS_Data is
-- /COMPILER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be
-- passed to any GNAT BIND commands generated by GNAT MAKE.
+ S_Make_Bindprj : aliased constant S := "/BND_LNK_FULL_PROJECT " &
+ "-B";
+ -- /BND_LNK_FULL_PROJECT
+ --
+ -- Bind and link all sources of a project, without any consideration
+ -- to attribute Main, if there is one. This qualifier need to be
+ -- used in conjunction with the /PROJECT_FILE= qualifier and cannot
+ -- be used with a main subprogram on the command line or for
+ -- a library project file. As the binder is invoked with the option
+ -- meaning "No Ada main subprogram", the user must ensure that the
+ -- proper options are specified to the linker. This qualifier is
+ -- normally used when the main subprogram is in a foreign language
+ -- such as C.
+
S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
"-cargs COMPILE";
-- /COMPILER_QUALIFIERS
@@ -4343,6 +4357,14 @@ package VMS_Data is
-- Write the output into the specified file, overriding any possibly
-- existing file.
+ S_Pretty_Formfeed : aliased constant S := "/FORM_FEED_AFTER_PRAGMA_PAGE " &
+ "-ff";
+ -- /FORM_FEED_AFTER_PRAGMA_PAGE
+ --
+ -- When there is a pragma Page in the source, insert a Form Feed
+ -- character immediately after the semicolon that follows the pragma
+ -- Page.
+
S_Pretty_Indent : aliased constant S := "/INDENTATION_LEVEL=#" &
"-i#";
-- /INDENTATION_LEVEL=nnn
@@ -4531,6 +4553,7 @@ package VMS_Data is
S_Pretty_Current 'Access,
S_Pretty_Dico 'Access,
S_Pretty_Forced 'Access,
+ S_Pretty_Formfeed 'Access,
S_Pretty_Indent 'Access,
S_Pretty_Keyword 'Access,
S_Pretty_Maxlen 'Access,
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-17 14:17 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-17 14:17 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-17 Ed Falis <falis@gnat.com>
* a-elchha.adb (Tailored_Exception_Information): made Info constant to
eliminate warning.
* a-exextr.adb: Add context clause for
Ada.Exceptions.Last_Chance_Handler.
2003-12-17 Sergey Rybin <rybin@act-europe.fr>
* cstand.adb (Create_Standard): Change the way how the declaration of
the Duration type is created (making it the same way as it is for all
the other standard types).
2003-12-17 Robert Dewar <dewar@gnat.com>
* s-crtl.ads: Fix header format
Change Pure to Preelaborate
2003-12-17 Ed Schonberg <schonberg@gnat.com>
* checks.adb (Selected_Length_Checks): Generate an Itype reference for
the expression type only if it is declared in the current unit.
* sem_ch3.adb (Constrain_Index): Handle properly a range whose bounds
are universal and already analyzed, as can occur in constrained
subcomponents that depend on discriminants, when one constraint is a
subtype mark.
* sem_res.adb (Resolve_Type_Conversion): Any arithmetic expression of
type Any_Fixed is legal as the argument of a conversion, if only one
fixed-point type is in context.
2003-12-17 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: a-elchha.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-elchha.adb,v
retrieving revision 1.1
diff -u -p -r1.1 a-elchha.adb
--- a-elchha.adb 5 Dec 2003 10:24:04 -0000 1.1
+++ a-elchha.adb 17 Dec 2003 11:19:44 -0000
@@ -38,16 +38,15 @@
-- Default version for most targets
procedure Ada.Exceptions.Last_Chance_Handler
- (Except : Exception_Occurrence) is
-
+ (Except : Exception_Occurrence)
+is
procedure Unhandled_Terminate;
pragma No_Return (Unhandled_Terminate);
pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
-- Perform system dependent shutdown code
function Tailored_Exception_Information
- (X : Exception_Occurrence)
- return String;
+ (X : Exception_Occurrence) return String;
-- Exception information to be output in the case of automatic tracing
-- requested through GNAT.Exception_Traces.
--
@@ -96,16 +95,14 @@ procedure Ada.Exceptions.Last_Chance_Han
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
- Last : in out Integer) is
-
- Info : String := Tailored_Exception_Information (X);
+ Last : in out Integer)
+ is
+ Info : constant String := Tailored_Exception_Information (X);
begin
Last := Info'Last;
Buff (1 .. Last) := Info;
end Tailored_Exception_Information;
-
-
begin
-- First allocate & store the exception info in a buffer when
-- we know it will be needed. This needs to be done before
@@ -152,9 +149,9 @@ begin
To_Stderr (Nline);
- else
- -- Traceback exists
+ -- Traceback exists
+ else
-- Note we can have this whole information output twice if
-- this occurrence gets reraised up to here.
@@ -165,5 +162,4 @@ begin
end if;
Unhandled_Terminate;
-
end Ada.Exceptions.Last_Chance_Handler;
Index: a-exextr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-exextr.adb,v
retrieving revision 1.2
diff -u -p -r1.2 a-exextr.adb
--- a-exextr.adb 5 Dec 2003 10:24:04 -0000 1.2
+++ a-exextr.adb 17 Dec 2003 11:19:44 -0000
@@ -33,6 +33,11 @@
with Unchecked_Conversion;
+pragma Warnings (Off);
+with Ada.Exceptions.Last_Chance_Handler;
+pragma Warnings (On);
+-- Bring last chance handler into closure
+
separate (Ada.Exceptions)
package body Exception_Traces is
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.13
diff -u -p -r1.13 checks.adb
--- checks.adb 14 Nov 2003 10:24:42 -0000 1.13
+++ checks.adb 17 Dec 2003 11:19:44 -0000
@@ -4778,13 +4778,16 @@ package body Checks is
-- At the library level, we need to ensure that the
-- type of the object is elaborated before the check
- -- itself is emitted.
+ -- itself is emitted. This is only done if the object
+ -- is in the current compilation unit, otherwise the
+ -- type is frozen and elaborated in its unit.
if Is_Itype (Exptyp)
and then
Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
and then
not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
+ and then In_Open_Scopes (Scope (Exptyp))
then
Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
Set_Itype (Ref_Node, Exptyp);
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.12
diff -u -p -r1.12 cstand.adb
--- cstand.adb 21 Nov 2003 10:46:37 -0000 1.12
+++ cstand.adb 17 Dec 2003 11:19:44 -0000
@@ -104,8 +104,7 @@ package body CStand is
function Make_Formal
(Typ : Entity_Id;
- Formal_Name : String)
- return Entity_Id;
+ Formal_Name : String) return Entity_Id;
-- Construct entity for subprogram formal with given name and type
function Make_Integer (V : Uint) return Node_Id;
@@ -118,8 +117,7 @@ package body CStand is
-- Build entity for standard operator with given name and type.
function New_Standard_Entity
- (New_Node_Kind : Node_Kind := N_Defining_Identifier)
- return Entity_Id;
+ (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id;
-- Builds a new entity for Standard
procedure Print_Standard;
@@ -1009,9 +1007,9 @@ package body CStand is
-- delta and size values depend on the mode set in system.ads.
Build_Duration : declare
- Dlo : Uint;
- Dhi : Uint;
- Delta_Val : Ureal;
+ Dlo : Uint;
+ Dhi : Uint;
+ Delta_Val : Ureal;
begin
-- In 32 bit mode, the size is 32 bits, and the delta and
@@ -1031,18 +1029,16 @@ package body CStand is
Delta_Val := UR_From_Components (Uint_1, Uint_9, 10);
end if;
- Decl :=
- Make_Full_Type_Declaration (Stloc,
- Defining_Identifier => Standard_Duration,
- Type_Definition =>
- Make_Ordinary_Fixed_Point_Definition (Stloc,
+ Tdef_Node := Make_Ordinary_Fixed_Point_Definition (Stloc,
Delta_Expression => Make_Real_Literal (Stloc, Delta_Val),
Real_Range_Specification =>
Make_Real_Range_Specification (Stloc,
Low_Bound => Make_Real_Literal (Stloc,
Realval => Dlo * Delta_Val),
High_Bound => Make_Real_Literal (Stloc,
- Realval => Dhi * Delta_Val))));
+ Realval => Dhi * Delta_Val)));
+
+ Set_Type_Definition (Parent (Standard_Duration), Tdef_Node);
Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
Set_Etype (Standard_Duration, Standard_Duration);
@@ -1058,7 +1054,7 @@ package body CStand is
Set_Small_Value (Standard_Duration, Delta_Val);
Set_Scalar_Range (Standard_Duration,
Real_Range_Specification
- (Type_Definition (Decl)));
+ (Type_Definition (Parent (Standard_Duration))));
-- Normally it does not matter that nodes in package Standard are
-- not marked as analyzed. The Scalar_Range of the fixed-point
@@ -1325,8 +1321,7 @@ package body CStand is
function Make_Formal
(Typ : Entity_Id;
- Formal_Name : String)
- return Entity_Id
+ Formal_Name : String) return Entity_Id
is
Formal : Entity_Id;
@@ -1348,7 +1343,6 @@ package body CStand is
function Make_Integer (V : Uint) return Node_Id is
N : constant Node_Id := Make_Integer_Literal (Stloc, V);
-
begin
Set_Is_Static_Expression (N);
return N;
@@ -1398,8 +1392,7 @@ package body CStand is
-------------------------
function New_Standard_Entity
- (New_Node_Kind : Node_Kind := N_Defining_Identifier)
- return Entity_Id
+ (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id
is
E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc);
Index: s-crtl.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-crtl.ads,v
retrieving revision 1.1
diff -u -p -r1.1 s-crtl.ads
--- s-crtl.ads 15 Dec 2003 11:51:01 -0000 1.1
+++ s-crtl.ads 17 Dec 2003 11:19:44 -0000
@@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . C R T L --
+-- S Y S T E M . C R T L --
-- --
-- S p e c --
-- --
@@ -36,7 +36,7 @@
with System.Parameters;
package System.CRTL is
- pragma Pure (CRTL);
+pragma Preelaborate (CRTL);
subtype chars is System.Address;
-- Pointer to null-terminated array of characters
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.26
diff -u -p -r1.26 sem_ch3.adb
--- sem_ch3.adb 11 Dec 2003 16:21:39 -0000 1.26
+++ sem_ch3.adb 17 Dec 2003 11:19:45 -0000
@@ -7715,8 +7715,8 @@ package body Sem_Ch3 is
if not Error_Posted (S)
and then
(Nkind (S) /= N_Range
- or else Base_Type (T) /= Base_Type (Etype (Low_Bound (S)))
- or else Base_Type (T) /= Base_Type (Etype (High_Bound (S))))
+ or else not Covers (T, (Etype (Low_Bound (S))))
+ or else not Covers (T, (Etype (High_Bound (S)))))
then
if Base_Type (T) /= Any_Type
and then Etype (Low_Bound (S)) /= Any_Type
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_res.adb
--- sem_res.adb 11 Dec 2003 16:21:39 -0000 1.15
+++ sem_res.adb 17 Dec 2003 11:19:45 -0000
@@ -6207,6 +6207,12 @@ package body Sem_Res is
Error_Msg_N ("\as Duration, and will lose precision?", Rop);
end if;
+ elsif Is_Numeric_Type (Typ)
+ and then Nkind (Operand) in N_Op
+ and then Unique_Fixed_Point_Type (N) /= Any_Type
+ then
+ Set_Etype (Operand, Standard_Duration);
+
else
Error_Msg_N ("invalid context for mixed mode operation", N);
Set_Etype (Operand, Any_Type);
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.63
diff -u -p -r1.63 Make-lang.in
--- Make-lang.in 15 Dec 2003 11:51:01 -0000 1.63
+++ Make-lang.in 17 Dec 2003 11:19:45 -0000
@@ -1221,11 +1221,12 @@ ada/a-elchha.o : ada/ada.ads ada/a-excep
ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \
ada/a-excach.adb ada/a-exexda.adb ada/a-exexpr.adb ada/a-exextr.adb \
- ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads ada/a-uncdea.ads \
- ada/interfac.ads ada/system.ads ada/s-exctab.ads ada/s-except.ads \
- ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traceb.ads \
- ada/s-traent.ads ada/s-traent.adb ada/s-unstyp.ads ada/unchconv.ads
+ ada/a-elchha.ads ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads \
+ ada/a-uncdea.ads ada/interfac.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-except.ads ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traceb.ads ada/s-traent.ads ada/s-traent.adb ada/s-unstyp.ads \
+ ada/unchconv.ads
ada/a-ioexce.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \
ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-15 11:51 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-15 11:51 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-15 Robert Dewar <dewar@gnat.com>
* exp_ch6.adb (Expand_Thread_Body): Fix error in picking up default
sec stack size.
2003-12-15 Vincent Celier <celier@gnat.com>
* gnatchop.adb: (Error_Msg): Do not exit on error for a warning
(Gnatchop): Do not set failure status when reporting the number of
warnings.
2003-12-15 Doug Rupp <rupp@gnat.com>
* s-ctrl.ads: New file.
* Makefile.rtl (GNAT_RTL_NONTASKING_OBJS): Add s-crtl$(objext).
* Make-lang.in: (GNAT_ADA_OBJS): Add ada/s-crtl.o.
(GNATBIND_OBJS): Add ada/s-crtl.o.
* Makefile.in [VMS]: Clean up ifeq rules.
* gnatlink.adb, 6vcstrea.adb, a-direio.adb, a-sequio.adb,
a-ststio.adb, a-textio.adb, g-os_lib.adb, a-witeio.adb,
g-os_lib.ads, i-cstrea.adb, i-cstrea.ads, s-direio.adb,
s-fileio.adb, s-memcop.ads, s-memory.adb, s-stache.adb,
s-tasdeb.adb: Update copyright.
Import System.CRTL.
Make minor modifications to use System.CRTL declared functions instead
of importing locally.
2003-12-15 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 6vcstrea.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/6vcstrea.adb,v
retrieving revision 1.7
diff -u -p -r1.7 6vcstrea.adb
--- 6vcstrea.adb 21 Oct 2003 13:41:53 -0000 1.7
+++ 6vcstrea.adb 15 Dec 2003 10:46:19 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2003 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- --
@@ -36,6 +36,8 @@
with Unchecked_Conversion;
package body Interfaces.C_Streams is
+ use type System.CRTL.size_t;
+
------------
-- fread --
------------
@@ -154,14 +156,6 @@ package body Interfaces.C_Streams is
size : size_t)
return int
is
- function C_setvbuf
- (stream : FILEs;
- buffer : chars;
- mode : int;
- size : size_t)
- return int;
- pragma Import (C, C_setvbuf, "setvbuf");
-
use type System.Address;
begin
@@ -173,9 +167,11 @@ package body Interfaces.C_Streams is
if mode = IONBF
and then (stream = stdout or else stream = stderr)
then
- return C_setvbuf (stream, buffer, IOLBF, size);
+ return System.CRTL.setvbuf
+ (stream, buffer, IOLBF, System.CRTL.size_t (size));
else
- return C_setvbuf (stream, buffer, mode, size);
+ return System.CRTL.setvbuf
+ (stream, buffer, mode, System.CRTL.size_t (size));
end if;
end setvbuf;
Index: a-direio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-direio.adb,v
retrieving revision 1.5
diff -u -p -r1.5 a-direio.adb
--- a-direio.adb 21 Oct 2003 13:41:53 -0000 1.5
+++ a-direio.adb 15 Dec 2003 10:46:19 -0000
@@ -38,6 +38,7 @@
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
+with System.CRTL;
with System.File_Control_Block;
with System.File_IO;
with System.Direct_IO;
@@ -64,6 +65,8 @@ package body Ada.Direct_IO is
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_DIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
+
+ use type System.CRTL.size_t;
-----------
-- Close --
Index: a-sequio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-sequio.adb,v
retrieving revision 1.5
diff -u -p -r1.5 a-sequio.adb
--- a-sequio.adb 21 Oct 2003 13:41:54 -0000 1.5
+++ a-sequio.adb 15 Dec 2003 10:46:19 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, 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 Interfaces.C_Streams; use Interfaces.C_Streams;
with System;
+with System.CRTL;
with System.File_Control_Block;
with System.File_IO;
with System.Storage_Elements;
@@ -57,6 +58,8 @@ package body Ada.Sequential_IO is
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
+
+ use type System.CRTL.size_t;
-----------
-- Close --
Index: a-ststio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-ststio.adb,v
retrieving revision 1.6
diff -u -p -r1.6 a-ststio.adb
--- a-ststio.adb 21 Oct 2003 13:41:54 -0000 1.6
+++ a-ststio.adb 15 Dec 2003 10:46:19 -0000
@@ -35,6 +35,7 @@ with Interfaces.C_Streams; use Inte
with System; use System;
with System.File_IO;
with System.Soft_Links;
+with System.CRTL;
with Unchecked_Conversion;
with Unchecked_Deallocation;
@@ -382,8 +383,11 @@ package body Ada.Streams.Stream_IO is
------------------
procedure Set_Position (File : in File_Type) is
+ use type System.CRTL.long;
begin
- if fseek (File.Stream, long (File.Index) - 1, SEEK_SET) /= 0 then
+ if fseek (File.Stream,
+ System.CRTL.long (File.Index) - 1, SEEK_SET) /= 0
+ then
raise Use_Error;
end if;
end Set_Position;
Index: a-textio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-textio.adb,v
retrieving revision 1.6
diff -u -p -r1.6 a-textio.adb
--- a-textio.adb 21 Oct 2003 13:41:54 -0000 1.6
+++ a-textio.adb 15 Dec 2003 10:46:19 -0000
@@ -35,6 +35,7 @@ with Ada.Streams; use Ada.Strea
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System;
with System.File_IO;
+with System.CRTL;
with Unchecked_Conversion;
with Unchecked_Deallocation;
@@ -50,6 +51,8 @@ package body Ada.Text_IO is
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
use type FCB.File_Mode;
+
+ use type System.CRTL.size_t;
-------------------
-- AFCB_Allocate --
Index: a-witeio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-witeio.adb,v
retrieving revision 1.6
diff -u -p -r1.6 a-witeio.adb
--- a-witeio.adb 21 Oct 2003 13:41:55 -0000 1.6
+++ a-witeio.adb 15 Dec 2003 10:46:19 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -36,6 +36,7 @@ with Ada.Streams; use Ada.Strea
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System;
+with System.CRTL;
with System.File_IO;
with System.WCh_Cnv; use System.WCh_Cnv;
with System.WCh_Con; use System.WCh_Con;
@@ -54,6 +55,8 @@ package body Ada.Wide_Text_IO is
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
use type FCB.File_Mode;
+
+ use type System.CRTL.size_t;
WC_Encoding : Character;
pragma Import (C, WC_Encoding, "__gl_wc_encoding");
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_ch6.adb
--- exp_ch6.adb 5 Dec 2003 10:24:04 -0000 1.15
+++ exp_ch6.adb 15 Dec 2003 10:46:19 -0000
@@ -2992,7 +2992,7 @@ package body Exp_Ch6 is
Make_Integer_Literal (Loc,
Intval =>
Expr_Value
- (Expression (RTE (RE_Default_Secondary_Stack_Size))));
+ (Constant_Value (RTE (RE_Default_Secondary_Stack_Size))));
end if;
Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
Index: gnatchop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatchop.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnatchop.adb
--- gnatchop.adb 21 Nov 2003 10:46:37 -0000 1.10
+++ gnatchop.adb 15 Dec 2003 10:46:19 -0000
@@ -342,10 +342,10 @@ procedure Gnatchop is
if not Warning then
Set_Exit_Status (Failure);
- end if;
- if Exit_On_Error then
- raise Terminate_Program;
+ if Exit_On_Error then
+ raise Terminate_Program;
+ end if;
end if;
end Error_Msg;
@@ -1738,7 +1738,7 @@ begin
declare
Warnings_Msg : String := Warning_Count'Img & " warning(s)";
begin
- Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last));
+ Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
end;
end if;
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.10
diff -u -p -r1.10 gnatlink.adb
--- gnatlink.adb 14 Nov 2003 10:24:43 -0000 1.10
+++ gnatlink.adb 15 Dec 2003 10:46:19 -0000
@@ -42,6 +42,7 @@ with Types;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.CRTL;
procedure Gnatlink is
pragma Ident (Gnatvsn.Gnat_Static_Version_String);
@@ -770,6 +771,7 @@ procedure Gnatlink is
------------------------
procedure Store_File_Context is
+ use type System.CRTL.long;
begin
RB_Next_Line := Next_Line;
RB_Nfirst := Nfirst;
Index: g-os_lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-os_lib.adb,v
retrieving revision 1.8
diff -u -p -r1.8 g-os_lib.adb
--- g-os_lib.adb 21 Oct 2003 13:42:03 -0000 1.8
+++ g-os_lib.adb 15 Dec 2003 10:46:19 -0000
@@ -32,6 +32,7 @@
------------------------------------------------------------------------------
with System.Case_Util;
+with System.CRTL;
with System.Soft_Links;
with Unchecked_Conversion;
with System; use System;
@@ -82,8 +83,7 @@ package body GNAT.OS_Lib is
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access;
+ Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String. We could do this making use of
-- Interfaces.C.Strings but we prefer not to import that entire package
@@ -143,8 +143,7 @@ package body GNAT.OS_Lib is
-----------------------------
function Argument_String_To_List
- (Arg_String : String)
- return Argument_List_Access
+ (Arg_String : String) return Argument_List_Access
is
Max_Args : constant Integer := Arg_String'Length;
New_Argv : Argument_List (1 .. Max_Args);
@@ -397,8 +396,7 @@ package body GNAT.OS_Lib is
function Copy_Attributes
(From, To : System.Address;
- Mode : Integer)
- return Integer;
+ Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
@@ -558,8 +556,7 @@ package body GNAT.OS_Lib is
function Copy_Attributes
(From, To : System.Address;
- Mode : Integer)
- return Integer;
+ Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
@@ -611,13 +608,11 @@ package body GNAT.OS_Lib is
function Create_File
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
function C_Create_File
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Create_File, "__gnat_open_create");
begin
@@ -626,8 +621,7 @@ package body GNAT.OS_Lib is
function Create_File
(Name : String;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
@@ -643,13 +637,11 @@ package body GNAT.OS_Lib is
function Create_New_File
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
function C_Create_New_File
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Create_New_File, "__gnat_open_new");
begin
@@ -658,8 +650,7 @@ package body GNAT.OS_Lib is
function Create_New_File
(Name : String;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
@@ -679,8 +670,7 @@ package body GNAT.OS_Lib is
is
function Open_New_Temp
(Name : System.Address;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
begin
@@ -1225,8 +1215,7 @@ package body GNAT.OS_Lib is
-------------------------
function Locate_Exec_On_Path
- (Exec_Name : String)
- return String_Access
+ (Exec_Name : String) return String_Access
is
function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
@@ -1262,8 +1251,7 @@ package body GNAT.OS_Lib is
function Locate_Regular_File
(File_Name : C_File_Name;
- Path : C_File_Name)
- return String_Access
+ Path : C_File_Name) return String_Access
is
function Locate_Regular_File
(C_File_Name, Path_Val : Address) return Address;
@@ -1291,8 +1279,7 @@ package body GNAT.OS_Lib is
function Locate_Regular_File
(File_Name : String;
- Path : String)
- return String_Access
+ Path : String) return String_Access
is
C_File_Name : String (1 .. File_Name'Length + 1);
C_Path : String (1 .. Path'Length + 1);
@@ -1313,8 +1300,7 @@ package body GNAT.OS_Lib is
function Non_Blocking_Spawn
(Program_Name : String;
- Args : Argument_List)
- return Process_Id
+ Args : Argument_List) return Process_Id
is
Junk : Integer;
Pid : Process_Id;
@@ -1428,8 +1414,7 @@ package body GNAT.OS_Lib is
(Name : String;
Directory : String := "";
Resolve_Links : Boolean := True;
- Case_Sensitive : Boolean := True)
- return String
+ Case_Sensitive : Boolean := True) return String
is
Max_Path : Integer;
pragma Import (C, Max_Path, "__gnat_max_path_len");
@@ -1465,13 +1450,11 @@ package body GNAT.OS_Lib is
function Readlink
(Path : System.Address;
Buf : System.Address;
- Bufsiz : Integer)
- return Integer;
+ Bufsiz : Integer) return Integer;
pragma Import (C, Readlink, "__gnat_readlink");
function To_Canonical_File_Spec
- (Host_File : System.Address)
- return System.Address;
+ (Host_File : System.Address) return System.Address;
pragma Import
(C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
@@ -1909,13 +1892,11 @@ package body GNAT.OS_Lib is
function Open_Read
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
function C_Open_Read
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Open_Read, "__gnat_open_read");
begin
@@ -1924,8 +1905,7 @@ package body GNAT.OS_Lib is
function Open_Read
(Name : String;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
@@ -1941,13 +1921,11 @@ package body GNAT.OS_Lib is
function Open_Read_Write
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
function C_Open_Read_Write
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
begin
@@ -1956,8 +1934,7 @@ package body GNAT.OS_Lib is
function Open_Read_Write
(Name : String;
- Fmode : Mode)
- return File_Descriptor
+ Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
@@ -1967,6 +1944,20 @@ package body GNAT.OS_Lib is
return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
end Open_Read_Write;
+ ----------
+ -- Read --
+ ----------
+
+ function Read
+ (FD : File_Descriptor;
+ A : System.Address;
+ N : Integer) return Integer
+ is
+ begin
+ return Integer (System.CRTL.read
+ (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
+ end Read;
+
-----------------
-- Rename_File --
-----------------
@@ -2031,8 +2022,7 @@ package body GNAT.OS_Lib is
function Spawn
(Program_Name : String;
- Args : Argument_List)
- return Integer
+ Args : Argument_List) return Integer
is
Junk : Process_Id;
Result : Integer;
@@ -2173,8 +2163,7 @@ package body GNAT.OS_Lib is
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access
+ Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
type Path_String_Access is access Path_String;
@@ -2212,5 +2201,19 @@ package body GNAT.OS_Lib is
Pid := Portable_Wait (Status'Address);
Success := (Status = 0);
end Wait_Process;
+
+ -----------
+ -- Write --
+ -----------
+
+ function Write
+ (FD : File_Descriptor;
+ A : System.Address;
+ N : Integer) return Integer
+ is
+ begin
+ return Integer (System.CRTL.write
+ (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
+ end Write;
end GNAT.OS_Lib;
Index: g-os_lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-os_lib.ads,v
retrieving revision 1.9
diff -u -p -r1.9 g-os_lib.ads
--- g-os_lib.ads 3 Dec 2003 11:47:52 -0000 1.9
+++ g-os_lib.ads 15 Dec 2003 10:46:20 -0000
@@ -175,31 +175,27 @@ pragma Elaborate_Body (OS_Lib);
function Open_Read
(Name : String;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
-- Open file Name for reading, returning file descriptor File descriptor
-- returned is Invalid_FD if file cannot be opened.
function Open_Read_Write
(Name : String;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
-- Open file Name for both reading and writing, returning file
-- descriptor. File descriptor returned is Invalid_FD if file cannot be
-- opened.
function Create_File
(Name : String;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
-- Creates new file with given name for writing, returning file descriptor
-- for subsequent use in Write calls. File descriptor returned is
-- Invalid_FD if file cannot be successfully created
function Create_New_File
(Name : String;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
-- Create new file with given name for writing, returning file descriptor
-- for subsequent use in Write calls. This differs from Create_File in
-- that it fails if the file already exists. File descriptor returned is
@@ -334,18 +330,14 @@ pragma Elaborate_Body (OS_Lib);
function Read
(FD : File_Descriptor;
A : System.Address;
- N : Integer)
- return Integer;
- pragma Import (C, Read, "read");
+ N : Integer) return Integer;
-- Read N bytes to address A from file referenced by FD. Returned value
-- is count of bytes actually read, which can be less than N at EOF.
function Write
(FD : File_Descriptor;
A : System.Address;
- N : Integer)
- return Integer;
- pragma Import (C, Write, "write");
+ N : Integer) return Integer;
-- Write N bytes from address A to file referenced by FD. The returned
-- value is the number of bytes written, which can be less than N if
-- a disk full condition was detected.
@@ -379,8 +371,7 @@ pragma Elaborate_Body (OS_Lib);
(Name : String;
Directory : String := "";
Resolve_Links : Boolean := True;
- Case_Sensitive : Boolean := True)
- return String;
+ Case_Sensitive : Boolean := True) return String;
-- Returns a file name as an absolute path name, resolving all relative
-- directories, and symbolic links. The parameter Directory is a fully
-- resolved path name for a directory, or the empty string (the default).
@@ -458,8 +449,7 @@ pragma Elaborate_Body (OS_Lib);
-- span file systems and may refer to directories.
function Locate_Exec_On_Path
- (Exec_Name : String)
- return String_Access;
+ (Exec_Name : String) return String_Access;
-- Try to locate an executable whose name is given by Exec_Name in the
-- directories listed in the environment Path. If the Exec_Name doesn't
-- have the executable suffix, it will be appended before the search.
@@ -470,8 +460,7 @@ pragma Elaborate_Body (OS_Lib);
function Locate_Regular_File
(File_Name : String;
- Path : String)
- return String_Access;
+ Path : String) return String_Access;
-- Try to locate a regular file whose name is given by File_Name in the
-- directories listed in Path. If a file is found, its full pathname is
-- returned; otherwise, a null pointer is returned. If the File_Name given
@@ -511,25 +500,23 @@ pragma Elaborate_Body (OS_Lib);
-- This subtype is used to document that a parameter is the address
-- of a null-terminated string containing the name of a file.
+ -- All the following functions need comments ???
+
function Open_Read
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
function Open_Read_Write
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
function Create_File
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
function Create_New_File
(Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
+ Fmode : Mode) return File_Descriptor;
procedure Delete_File (Name : C_File_Name; Success : out Boolean);
Index: i-cstrea.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/i-cstrea.adb,v
retrieving revision 1.4
diff -u -p -r1.4 i-cstrea.adb
--- i-cstrea.adb 24 Apr 2003 17:54:05 -0000 1.4
+++ i-cstrea.adb 15 Dec 2003 10:46:20 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2003 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,8 @@
with Unchecked_Conversion;
package body Interfaces.C_Streams is
+
+ use type System.CRTL.size_t;
------------
-- fread --
Index: i-cstrea.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/i-cstrea.ads,v
retrieving revision 1.7
diff -u -p -r1.7 i-cstrea.ads
--- i-cstrea.ads 21 Oct 2003 13:42:08 -0000 1.7
+++ i-cstrea.ads 15 Dec 2003 10:46:20 -0000
@@ -34,38 +34,17 @@
-- This package is a thin binding to selected functions in the C
-- library that provide a complete interface for handling C streams.
-with System.Parameters;
+with System.CRTL;
package Interfaces.C_Streams is
pragma Preelaborate;
- -- Note: the reason we do not use the types that are in Interfaces.C is
- -- that we want to avoid dragging in the code in this unit if possible.
-
- subtype chars is System.Address;
- -- Pointer to null-terminated array of characters
-
- subtype FILEs is System.Address;
- -- Corresponds to the C type FILE*
-
+ subtype chars is System.CRTL.chars;
+ subtype FILEs is System.CRTL.FILEs;
+ subtype int is System.CRTL.int;
+ subtype long is System.CRTL.long;
+ subtype size_t is System.CRTL.size_t;
subtype voids is System.Address;
- -- Corresponds to the C type void*
-
- subtype int is Integer;
- -- Note: the above type is a subtype deliberately, and it is part of
- -- this spec that the above correspondence is guaranteed. This means
- -- that it is legitimate to, for example, use Integer instead of int.
- -- We provide this synonym for clarity, but in some cases it may be
- -- convenient to use the underlying types (for example to avoid an
- -- unnecessary dependency of a spec on the spec of this unit).
-
- type long is range -(2 ** (System.Parameters.long_bits - 1))
- .. +(2 ** (System.Parameters.long_bits - 1)) - 1;
- -- Note: the above type also used to be a subtype, but the correspondence
- -- was unused so it was made into a parameterized type to avoid having
- -- multiple versions of this spec for systems where long /= Long_Integer.
-
- type size_t is mod 2 ** Standard'Address_Size;
NULL_Stream : constant FILEs;
-- Value returned (NULL in C) to indicate an fdopen/fopen/tmpfile error
@@ -106,34 +85,39 @@ package Interfaces.C_Streams is
-- Library Reference" (Microsoft Press, 1990, ISBN 1-55615-225-6),
-- which includes useful information on system compatibility.
- procedure clearerr (stream : FILEs);
+ procedure clearerr (stream : FILEs) renames System.CRTL.clearerr;
- function fclose (stream : FILEs) return int;
+ function fclose (stream : FILEs) return int renames System.CRTL.fclose;
- function fdopen (handle : int; mode : chars) return FILEs;
+ function fdopen (handle : int; mode : chars) return FILEs
+ renames System.CRTL.fdopen;
function feof (stream : FILEs) return int;
function ferror (stream : FILEs) return int;
- function fflush (stream : FILEs) return int;
+ function fflush (stream : FILEs) return int renames System.CRTL.fflush;
- function fgetc (stream : FILEs) return int;
+ function fgetc (stream : FILEs) return int renames System.CRTL.fgetc;
- function fgets (strng : chars; n : int; stream : FILEs) return chars;
+ function fgets (strng : chars; n : int; stream : FILEs) return chars
+ renames System.CRTL.fgets;
function fileno (stream : FILEs) return int;
- function fopen (filename : chars; Mode : chars) return FILEs;
+ function fopen (filename : chars; Mode : chars) return FILEs
+ renames System.CRTL.fopen;
-- Note: to maintain target independence, use text_translation_required,
-- a boolean variable defined in a-sysdep.c to deal with the target
-- dependent text translation requirement. If this variable is set,
-- then b/t should be appended to the standard mode argument to set
-- the text translation mode off or on as required.
- function fputc (C : int; stream : FILEs) return int;
+ function fputc (C : int; stream : FILEs) return int
+ renames System.CRTL.fputc;
- function fputs (Strng : chars; Stream : FILEs) return int;
+ function fputs (Strng : chars; Stream : FILEs) return int
+ renames System.CRTL.fputs;
function fread
(buffer : voids;
@@ -159,15 +143,16 @@ package Interfaces.C_Streams is
(filename : chars;
mode : chars;
stream : FILEs)
- return FILEs;
+ return FILEs renames System.CRTL.freopen;
function fseek
(stream : FILEs;
offset : long;
origin : int)
- return int;
+ return int renames System.CRTL.fseek;
- function ftell (stream : FILEs) return long;
+ function ftell (stream : FILEs) return long
+ renames System.CRTL.ftell;
function fwrite
(buffer : voids;
@@ -176,12 +161,12 @@ package Interfaces.C_Streams is
stream : FILEs)
return size_t;
- function isatty (handle : int) return int;
+ function isatty (handle : int) return int renames System.CRTL.isatty;
- procedure mktemp (template : chars);
+ procedure mktemp (template : chars) renames System.CRTL.mktemp;
-- The return value (which is just a pointer to template) is discarded
- procedure rewind (stream : FILEs);
+ procedure rewind (stream : FILEs) renames System.CRTL.rewind;
function setvbuf
(stream : FILEs;
@@ -190,16 +175,18 @@ package Interfaces.C_Streams is
size : size_t)
return int;
- procedure tmpnam (string : chars);
+ procedure tmpnam (string : chars) renames System.CRTL.tmpnam;
-- The parameter must be a pointer to a string buffer of at least L_tmpnam
-- bytes (the call with a null parameter is not supported). The returned
-- value, which is just a copy of the input argument, is discarded.
- function tmpfile return FILEs;
+ function tmpfile return FILEs renames System.CRTL.tmpfile;
- function ungetc (c : int; stream : FILEs) return int;
+ function ungetc (c : int; stream : FILEs) return int
+ renames System.CRTL.ungetc;
- function unlink (filename : chars) return int;
+ function unlink (filename : chars) return int
+ renames System.CRTL.unlink;
---------------------
-- Extra functions --
@@ -252,29 +239,6 @@ private
pragma Inline (fread);
pragma Inline (fwrite);
pragma Inline (setvbuf);
-
- -- The following routines are always functions in C, and thus can be
- -- imported directly into Ada without any intermediate C needed
-
- pragma Import (C, clearerr);
- pragma Import (C, fclose);
- pragma Import (C, fdopen);
- pragma Import (C, fflush);
- pragma Import (C, fgetc);
- pragma Import (C, fgets);
- pragma Import (C, fopen);
- pragma Import (C, fputc);
- pragma Import (C, fputs);
- pragma Import (C, freopen);
- pragma Import (C, fseek);
- pragma Import (C, ftell);
- pragma Import (C, isatty);
- pragma Import (C, mktemp);
- pragma Import (C, rewind);
- pragma Import (C, tmpnam);
- pragma Import (C, tmpfile);
- pragma Import (C, ungetc);
- pragma Import (C, unlink);
pragma Import (C, file_exists, "__gnat_file_exists");
pragma Import (C, is_regular_file, "__gnat_is_regular_file_fd");
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.60
diff -u -p -r1.60 Makefile.in
--- Makefile.in 11 Dec 2003 16:21:39 -0000 1.60
+++ Makefile.in 15 Dec 2003 10:46:20 -0000
@@ -1123,7 +1123,7 @@ ifeq ($(strip $(filter-out alpha% dec os
LIBRARY_VERSION := $(LIB_VERSION)
endif
-ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
+ifeq ($(strip $(filter-out alpha% ia64 dec vms% openvms% alphavms%,$(host))),)
soext = .exe
@@ -1134,17 +1134,32 @@ soext = .exe
endif
ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
-ifeq ($(strip $(filter-out alpha64% dec vms% openvms% alphavms%,$(targ))),)
- LIBGNAT_TARGET_PAIRS_AUX =
+
+ifeq ($(strip $(filter-out ia64% hp vms% openvms%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS_AUX = \
+ s-osinte.adb<5xosinte.adb \
+ s-osinte.ads<5xosinte.ads \
+ s-parame.ads<5vparame.ads
+else
+ifeq ($(strip $(filter-out alpha64% dec hp vms% openvms% alphavms%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS_AUX = \
+ s-osinte.adb<5vosinte.adb \
+ s-osinte.ads<5vosinte.ads \
+ s-parame.ads<5vparame.ads
else
ifeq ($(strip $(filter-out express EXPRESS,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS_AUX = \
+ s-osinte.adb<5vosinte.adb \
+ s-osinte.ads<5vosinte.ads \
s-parame.ads<5xparame.ads
else
LIBGNAT_TARGET_PAIRS_AUX = \
+ s-osinte.adb<5vosinte.adb \
+ s-osinte.ads<5vosinte.ads \
s-parame.ads<5vparame.ads
endif
endif
+endif
LIBGNAT_TARGET_PAIRS = \
a-caldel.adb<4vcaldel.adb \
@@ -1152,6 +1167,7 @@ endif
a-calend.ads<4vcalend.ads \
a-excpol.adb<4wexcpol.adb \
a-intnam.ads<4vintnam.ads \
+ a-numaux.ads<4vnumaux.ads \
g-expect.adb<3vexpect.adb \
g-soccon.ads<3vsoccon.ads \
g-socthi.ads<3vsocthi.ads \
@@ -1161,12 +1177,11 @@ endif
i-cpp.adb<6vcpp.adb \
interfac.ads<6vinterf.ads \
s-asthan.adb<5vasthan.adb \
+ s-crtl.ads<5vcrtl.ads \
s-inmaop.adb<5vinmaop.adb \
s-interr.adb<5vinterr.adb \
s-intman.adb<5vintman.adb \
s-intman.ads<5vintman.ads \
- s-osinte.adb<5vosinte.adb \
- s-osinte.ads<5vosinte.ads \
s-osprim.adb<5vosprim.adb \
s-osprim.ads<5vosprim.ads \
s-taprop.adb<5vtaprop.adb \
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.3
diff -u -p -r1.3 Makefile.rtl
--- Makefile.rtl 5 Dec 2003 10:24:05 -0000 1.3
+++ Makefile.rtl 15 Dec 2003 10:46:20 -0000
@@ -1,5 +1,5 @@
# Makefile.rtl for GNU Ada Compiler (GNAT).
-# Copyright (C) 2002 Free Software Foundation, Inc.
+# Copyright (C) 2003 Free Software Foundation, Inc.
#This file is part of GCC.
@@ -283,6 +283,7 @@ GNATRTL_NONTASKING_OBJS= \
s-caun32$(objext) \
s-caun64$(objext) \
s-chepoo$(objext) \
+ s-crtl$(objext) \
s-crc32$(objext) \
s-direio$(objext) \
s-errrep$(objext) \
Index: s-direio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-direio.adb,v
retrieving revision 1.6
diff -u -p -r1.6 s-direio.adb
--- s-direio.adb 21 Oct 2003 13:42:13 -0000 1.6
+++ s-direio.adb 15 Dec 2003 10:46:20 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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 Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
+with System.CRTL;
with System.File_IO;
with System.Soft_Links;
with Unchecked_Deallocation;
@@ -45,6 +46,9 @@ package body System.Direct_IO is
subtype AP is FCB.AFCB_Ptr;
use type FCB.Shared_Status_Type;
+
+ use type System.CRTL.long;
+ use type System.CRTL.size_t;
-----------------------
-- Local Subprograms --
Index: s-fileio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-fileio.adb,v
retrieving revision 1.7
diff -u -p -r1.7 s-fileio.adb
--- s-fileio.adb 10 Nov 2003 17:29:59 -0000 1.7
+++ s-fileio.adb 15 Dec 2003 10:46:20 -0000
@@ -34,6 +34,7 @@
with Ada.Finalization; use Ada.Finalization;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.CRTL;
with System.Soft_Links;
with Unchecked_Deallocation;
@@ -42,6 +43,8 @@ package body System.File_IO is
use System.File_Control_Block;
package SSL renames System.Soft_Links;
+
+ use type System.CRTL.size_t;
----------------------
-- Global Variables --
Index: s-memcop.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-memcop.ads,v
retrieving revision 1.1
diff -u -p -r1.1 s-memcop.ads
--- s-memcop.ads 21 Oct 2003 13:42:14 -0000 1.1
+++ s-memcop.ads 15 Dec 2003 10:46:20 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2003 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 --
@@ -35,24 +35,27 @@
-- --
------------------------------------------------------------------------------
--- This package provides general block copy mechanisms analgous to those
+-- This package provides general block copy mechanisms analogous to those
-- provided by the C routines memcpy and memmove allowing for copies with
--- and without possible overflow.
+-- and without possible overlap of the operands.
+
+-- The idea is to allow a configurable run-time to provide this capability
+-- for use by the compiler without dragging in C-run time routines.
+
+with System.CRTL;
+-- The above with is contrary to the intent ???
package System.Memory_Copy is
pragma Preelaborate;
- type size_t is mod 2 ** Standard'Address_Size;
- -- Note: the reason we redefine this here instead of using the
- -- definition in Interfaces.C is that we do not want to drag in
- -- all of Interfaces.C just because System.Memory_Copy is used.
-
- procedure memcpy (S1 : Address; S2 : Address; N : size_t);
+ procedure memcpy (S1 : Address; S2 : Address; N : System.CRTL.size_t)
+ renames System.CRTL.memcpy;
-- Copies N storage units from area starting at S2 to area starting
-- at S1 without any check for buffer overflow. The memory areas
-- must not overlap, or the result of this call is undefined.
- procedure memmove (S1 : Address; S2 : Address; N : size_t);
+ procedure memmove (S1 : Address; S2 : Address; N : System.CRTL.size_t)
+ renames System.CRTL.memmove;
-- Copies N storage units from area starting at S2 to area starting
-- at S1 without any check for buffer overflow. The difference between
-- this memmove and memcpy is that with memmove, the storage areas may
@@ -60,8 +63,6 @@ pragma Preelaborate;
-- is as if S2 is first moved to a temporary area, and then this area
-- is copied to S1 in a separate step).
-private
-
-- In the standard library, these are just interfaced to the C routines.
-- But in the HI-E (high integrity version) they may be reprogrammed to
-- meet certification requirements (and marked High_Integrity).
@@ -69,8 +70,5 @@ private
-- Note that in high integrity mode these routines are by default not
-- available, and the HI-E compiler will as a result generate implicit
-- loops (which will violate the restriction No_Implicit_Loops).
-
- pragma Import (C, memcpy, "memcpy");
- pragma Import (C, memmove, "memmove");
end System.Memory_Copy;
Index: s-memory.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-memory.adb,v
retrieving revision 1.6
diff -u -p -r1.6 s-memory.adb
--- s-memory.adb 21 Oct 2003 13:42:14 -0000 1.6
+++ s-memory.adb 15 Dec 2003 10:46:20 -0000
@@ -46,21 +46,22 @@
with Ada.Exceptions;
with System.Soft_Links;
with System.Parameters;
+with System.CRTL;
package body System.Memory is
use Ada.Exceptions;
use System.Soft_Links;
- function c_malloc (Size : size_t) return System.Address;
- pragma Import (C, c_malloc, "malloc");
+ function c_malloc (Size : System.CRTL.size_t) return System.Address
+ renames System.CRTL.malloc;
- procedure c_free (Ptr : System.Address);
- pragma Import (C, c_free, "free");
+ procedure c_free (Ptr : System.Address)
+ renames System.CRTL.free;
function c_realloc
- (Ptr : System.Address; Size : size_t) return System.Address;
- pragma Import (C, c_realloc, "realloc");
+ (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address
+ renames System.CRTL.realloc;
-----------
-- Alloc --
@@ -85,10 +86,10 @@ package body System.Memory is
end if;
if Parameters.No_Abort then
- Result := c_malloc (Actual_Size);
+ Result := c_malloc (System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
- Result := c_malloc (Actual_Size);
+ Result := c_malloc (System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
@@ -132,10 +133,10 @@ package body System.Memory is
end if;
if Parameters.No_Abort then
- Result := c_realloc (Ptr, Actual_Size);
+ Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
- Result := c_realloc (Ptr, Actual_Size);
+ Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
Index: s-stache.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-stache.adb,v
retrieving revision 1.7
diff -u -p -r1.7 s-stache.adb
--- s-stache.adb 21 Oct 2003 13:42:14 -0000 1.7
+++ s-stache.adb 15 Dec 2003 10:46:20 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 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- --
@@ -36,6 +36,7 @@ with Ada.Exceptions;
with System.Storage_Elements; use System.Storage_Elements;
with System.Parameters; use System.Parameters;
with System.Soft_Links;
+with System.CRTL;
package body System.Stack_Checking is
@@ -72,7 +73,6 @@ package body System.Stack_Checking is
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
pragma Warnings (Off, Any_Stack);
-
begin
Cache := Null_Stack;
end Invalidate_Stack_Cache;
@@ -82,8 +82,7 @@ package body System.Stack_Checking is
--------------------
function Set_Stack_Info
- (Stack : access Stack_Access)
- return Stack_Access
+ (Stack : access Stack_Access) return Stack_Access
is
type Frame_Mark is null record;
Frame_Location : Frame_Mark;
@@ -93,12 +92,6 @@ package body System.Stack_Checking is
Limit_Chars : System.Address;
Limit : Integer;
- function getenv (S : String) return System.Address;
- pragma Import (C, getenv, External_Name => "getenv");
-
- function atoi (A : System.Address) return Integer;
- pragma Import (C, atoi);
-
begin
-- The order of steps 1 .. 3 is important, see specification.
@@ -113,16 +106,16 @@ package body System.Stack_Checking is
-- the current frame address.
if My_Stack.Size = 0 then
-
My_Stack.Size := Storage_Offset (Default_Env_Stack_Size);
-- When the environment variable GNAT_STACK_LIMIT is set,
-- set Environment_Stack_Size to that number of kB.
- Limit_Chars := getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
+ Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
if Limit_Chars /= Null_Address then
- Limit := atoi (Limit_Chars);
+ Limit := System.CRTL.atoi (Limit_Chars);
+
if Limit >= 0 then
My_Stack.Size := Storage_Offset (Limit) * Kilobyte;
end if;
@@ -192,8 +185,7 @@ package body System.Stack_Checking is
-----------------
function Stack_Check
- (Stack_Address : System.Address)
- return Stack_Access
+ (Stack_Address : System.Address) return Stack_Access
is
type Frame_Marker is null record;
Marker : Frame_Marker;
@@ -227,7 +219,6 @@ package body System.Stack_Checking is
-- it is essential to use our local copy of Stack!
begin
-
if (Stack_Grows_Down and then
(not (Frame_Address <= My_Stack.Base)))
or else
Index: s-tasdeb.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tasdeb.adb,v
retrieving revision 1.8
diff -u -p -r1.8 s-tasdeb.adb
--- s-tasdeb.adb 21 Oct 2003 13:42:15 -0000 1.8
+++ s-tasdeb.adb 15 Dec 2003 10:46:20 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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- --
@@ -39,14 +39,12 @@
-- Do not add any dependency to GNARL packages since this package is used
-- in both normal and restricted (ravenscar) environments.
-with Interfaces.C;
+with System.CRTL;
with System.Task_Primitives.Operations;
with Unchecked_Conversion;
package body System.Tasking.Debug is
- use Interfaces.C;
-
package STPO renames System.Task_Primitives.Operations;
function To_Integer is new
@@ -60,8 +58,7 @@ package body System.Tasking.Debug is
-- Local Subprograms --
-----------------------
- procedure write (Fd : Integer; S : String; Count : size_t);
- pragma Import (C, write);
+ procedure Write (Fd : Integer; S : String; Count : Integer);
procedure Put (S : String);
-- Display S on standard output.
@@ -177,7 +174,7 @@ package body System.Tasking.Debug is
procedure Put (S : String) is
begin
- write (2, S, S'Length);
+ Write (2, S, S'Length);
end Put;
--------------
@@ -186,7 +183,7 @@ package body System.Tasking.Debug is
procedure Put_Line (S : String := "") is
begin
- write (2, S & ASCII.LF, S'Length + 1);
+ Write (2, S & ASCII.LF, S'Length + 1);
end Put_Line;
----------------------
@@ -296,5 +293,12 @@ package body System.Tasking.Debug is
Put_Line (Msg);
end if;
end Trace;
+
+ procedure Write (Fd : Integer; S : String; Count : Integer) is
+
+ Num : Integer;
+ begin
+ Num := System.CRTL.write (Fd, S (S'First)'Address, Count);
+ end Write;
end System.Tasking.Debug;
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.62
diff -u -p -r1.62 Make-lang.in
--- Make-lang.in 8 Dec 2003 10:33:17 -0000 1.62
+++ Make-lang.in 15 Dec 2003 10:46:20 -0000
@@ -153,7 +153,7 @@ GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o
ada/stylesw.o ada/validsw.o ada/system.o ada/table.o ada/targparm.o \
ada/tbuild.o ada/tree_gen.o ada/tree_io.o ada/treepr.o ada/treeprs.o \
ada/ttypef.o ada/ttypes.o ada/types.o ada/uintp.o ada/uname.o ada/urealp.o \
- ada/usage.o ada/widechar.o
+ ada/usage.o ada/widechar.o ada/s-crtl.o
# Object files for gnat executables
GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
@@ -212,6 +212,7 @@ GNATBIND_OBJS = \
ada/s-carun8.o \
ada/s-casuti.o \
ada/s-crc32.o \
+ ada/s-crtl.o \
ada/s-except.o \
ada/s-exctab.o \
ada/s-htable.o \
@@ -2254,10 +2255,10 @@ ada/g-htable.o : ada/gnat.ads ada/g-htab
ada/g-os_lib.o : ada/ada.ads ada/a-except.ads ada/gnat.ads \
ada/g-os_lib.ads ada/g-os_lib.adb ada/g-string.ads ada/system.ads \
- ada/s-casuti.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-casuti.ads ada/s-crtl.ads ada/s-exctab.ads ada/s-exctab.adb \
+ ada/s-htable.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traent.ads ada/unchconv.ads ada/unchdeal.ads
ada/g-speche.o : ada/gnat.ads ada/g-speche.ads ada/g-speche.adb \
ada/system.ads
@@ -2711,6 +2712,8 @@ ada/s-casuti.o : ada/system.ads ada/s-ca
ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \
ada/s-crc32.adb
+ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads
+
ada/s-except.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-stalib.ads ada/s-traent.ads ada/unchconv.ads
@@ -2730,9 +2733,9 @@ ada/s-mastop.o : ada/ada.ads ada/a-excep
ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads
ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/system.ads \
- ada/s-memory.ads ada/s-memory.adb ada/s-parame.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/unchconv.ads
+ ada/s-crtl.ads ada/s-memory.ads ada/s-memory.adb ada/s-parame.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads
ada/s-parame.o : ada/system.ads ada/s-parame.ads ada/s-parame.adb
@@ -2761,9 +2764,9 @@ ada/s-sopco5.o : ada/system.ads ada/s-se
ada/s-sopco5.ads ada/s-sopco5.adb ada/unchconv.ads
ada/s-stache.o : ada/ada.ads ada/a-except.ads ada/system.ads \
- ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stache.adb \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
- ada/unchconv.ads
+ ada/s-crtl.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stache.adb ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traent.ads ada/unchconv.ads
ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-memory.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-11 16:22 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-11 16:22 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-11 Ed Falis <falis@gnat.com>
* 5zinit.adb: Clean up.
* 5zintman.adb (Notify_Exception): replaced case statement with a call
to __gnat_map_signal, imported from init.c to support
signal -> exception mappings that depend on the vxWorks version.
* init.c:
Created and exported __gnat_map_signal to support signal -> exception
mapping that is dependent on the VxWorks version.
Change mapping of SIGBUS from Program_Error to Storage_Error on VxWorks
2003-12-11 Vasiliy Fofanv <fofanov@act-europe.fr>
* 5wosinte.ads: Link with -mthreads switch.
2003-12-11 Arnaud Charlet <charlet@act-europe.fr>
* init.c (__gnat_install_handler [NetBSD]): Set
__gnat_handler_installed, as done on all other platforms.
Remove duplicated code.
2003-12-11 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (rts-zfp, rts-ravenscar): Create libgnat.a.
2003-12-11 Thomas Quinot <quinot@act-europe.fr>
* sinfo.ads: Fix inconsistent example code in comment.
2003-12-11 Robert Dewar <dewar@gnat.com>
* a-tiinau.adb: Add a couple of comments
* sem_ch3.adb: Minor reformatting
* sem_prag.adb:
Fix bad prototype of Same_Base_Type in body (code reading cleanup)
Minor reformatting throughout
2003-12-11 Ed Schonberg <schonberg@gnat.com>
* exp_ch7.adb (Establish_Transient_Scope): If the call is within the
bounds of a loop, create a separate block in order to generate proper
cleanup actions to prevent memory leaks.
* sem_res.adb (Resolve_Call): After a call to
Establish_Transient_Scope, the call may be rewritten and relocated, in
which case no further processing is needed.
* sem_util.adb: (Wrong_Type): Refine previous fix.
Fixes ACATS regressions.
PR ada/13353
* sem_prag.adb (Back_End_Cannot_Inline): A renaming_as_body can always
be inlined.
--
Index: 5wosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wosinte.ads,v
retrieving revision 1.4
diff -u -p -r1.4 5wosinte.ads
--- 5wosinte.ads 24 Apr 2003 17:53:52 -0000 1.4
+++ 5wosinte.ads 11 Dec 2003 13:31:27 -0000
@@ -46,6 +46,8 @@ with Interfaces.C.Strings;
package System.OS_Interface is
pragma Preelaborate;
+ pragma Linker_Options ("-mthreads");
+
subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long;
Index: 5zinit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zinit.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5zinit.adb
--- 5zinit.adb 10 Nov 2003 17:29:58 -0000 1.2
+++ 5zinit.adb 11 Dec 2003 13:31:27 -0000
@@ -33,9 +33,6 @@
-- This is the VxWorks version of this package
-with System.OS_Interface;
--- used for various Constants, Signal and types
-
with Interfaces.C;
-- used for int and other types
@@ -47,10 +44,58 @@ package body System.Init is
-- This unit contains initialization circuits that are system dependent.
use Ada.Exceptions;
- use System.OS_Interface;
- use type Interfaces.C.int;
+ use Interfaces.C;
+
+ --------------------------
+ -- Signal Definitions --
+ --------------------------
+
+ NSIG : constant := 32;
+ -- Number of signals on the target OS
+ type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
+
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGFPE : constant := 8; -- floating point exception
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+
+ type sigset_t is new long;
+
+ SIG_SETMASK : constant := 3;
+ SA_ONSTACK : constant := 16#0004#;
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ -------------------------------
+ -- Binder Generated Values --
+ -------------------------------
- -- Copies of global values computed by the binder
Gl_Main_Priority : Integer := -1;
pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
Index: 5zintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zintman.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5zintman.adb
--- 5zintman.adb 24 Nov 2003 14:27:57 -0000 1.7
+++ 5zintman.adb 11 Dec 2003 13:31:27 -0000
@@ -53,12 +53,8 @@ with Interfaces.C;
with System.OS_Interface;
-- used for various Constants, Signal and types
-with Ada.Exceptions;
--- used for Raise_Exception
-
package body System.Interrupt_Management is
- use Ada.Exceptions;
use System.OS_Interface;
use type Interfaces.C.int;
@@ -71,6 +67,11 @@ package body System.Interrupt_Management
Exception_Action : aliased struct_sigaction;
+ procedure Map_And_Raise_Exception (signo : Signal);
+ pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal");
+ -- Map signal to Ada exception and raise it. Different versions
+ -- of VxWorks need different mappings.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -103,20 +104,7 @@ package body System.Interrupt_Management
Result := taskResume (My_Id);
end if;
- case signo is
- when SIGFPE =>
- Raise_Exception (Constraint_Error'Identity, "SIGFPE");
- when SIGILL =>
- Raise_Exception (Constraint_Error'Identity, "SIGILL");
- when SIGSEGV =>
- Raise_Exception
- (Program_Error'Identity,
- "stack overflow or erroneous memory access");
- when SIGBUS =>
- Raise_Exception (Program_Error'Identity, "SIGBUS");
- when others =>
- Raise_Exception (Program_Error'Identity, "unhandled signal");
- end case;
+ Map_And_Raise_Exception (signo);
end Notify_Exception;
---------------------------
Index: a-tiinau.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-tiinau.adb,v
retrieving revision 1.6
diff -u -p -r1.6 a-tiinau.adb
--- a-tiinau.adb 21 Oct 2003 13:41:54 -0000 1.6
+++ a-tiinau.adb 11 Dec 2003 13:31:27 -0000
@@ -167,6 +167,9 @@ package body Ada.Text_IO.Integer_Aux is
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based literal (note : is ok replacement for #)
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
@@ -174,6 +177,8 @@ package body Ada.Text_IO.Integer_Aux is
Load_Extended_Digits (File, Buf, Ptr);
Load (File, Buf, Ptr, Buf (Hash_Loc));
end if;
+
+ -- Deal with exponent
Load (File, Buf, Ptr, 'E', 'e', Loaded);
Index: exp_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch7.adb,v
retrieving revision 1.9
diff -u -p -r1.9 exp_ch7.adb
--- exp_ch7.adb 21 Oct 2003 13:41:59 -0000 1.9
+++ exp_ch7.adb 11 Dec 2003 13:31:27 -0000
@@ -1074,6 +1074,76 @@ package body Exp_Ch7 is
if No (Wrap_Node) then
null;
+ elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
+
+ -- Create a declaration followed by an assignment, so that
+ -- the assignment can have its own transient scope.
+ -- We generate the equivalent of:
+
+ -- type Ptr is access all expr_type;
+ -- Var : Ptr;
+ -- begin
+ -- Var := Expr'reference;
+ -- end;
+
+ -- This closely resembles what is done in Remove_Side_Effect,
+ -- but it has to be done here, before the analysis of the call
+ -- is completed.
+
+ declare
+ Ptr_Typ : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('A'));
+ Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ Expr_Type : constant Entity_Id := Etype (N);
+ New_Expr : constant Node_Id := Relocate_Node (N);
+ Decl : Node_Id;
+ Ptr_Typ_Decl : Node_Id;
+ Stmt : Node_Id;
+
+ begin
+ Ptr_Typ_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Reference_To (Expr_Type, Loc)));
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ptr,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
+
+ Set_Etype (Ptr, Ptr_Typ);
+ Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Ptr, Loc),
+ Expression => Make_Reference (Loc, New_Expr));
+
+ Set_Analyzed (New_Expr, False);
+
+ Insert_List_Before_And_Analyze
+ (Parent (Wrap_Node),
+ New_List (
+ Ptr_Typ_Decl,
+ Decl,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Stmt)))));
+
+ Rewrite (N,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Ptr, Loc)));
+ Analyze_And_Resolve (N, Expr_Type);
+
+ end;
+
-- Transient scope is required
else
@@ -1815,14 +1885,12 @@ package body Exp_Ch7 is
return The_Parent;
end if;
- -- ??? No scheme yet for "for I in Expression'Range loop"
- -- ??? the current scheme for Expression wrapping doesn't apply
- -- ??? because a RANGE is NOT an expression. Tricky problem...
- -- ??? while this problem is not solved we have a potential for
- -- ??? leak and unfinalized intermediate objects here.
+ -- If the expression is within the iteration scheme of a loop,
+ -- we must create a declaration for it, followed by an assignment
+ -- in order to have a usable statement to wrap.
when N_Loop_Parameter_Specification =>
- return Empty;
+ return Parent (The_Parent);
-- The following nodes contains "dummy calls" which don't
-- need to be wrapped.
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.21
diff -u -p -r1.21 init.c
--- init.c 18 Nov 2003 10:00:43 -0000 1.21
+++ init.c 11 Dec 2003 13:31:27 -0000
@@ -1551,6 +1551,7 @@ __gnat_initialize ()
extern int __gnat_inum_to_ivec (int);
static void __gnat_error_handler (int, int, struct sigcontext *);
+void __gnat_map_signal (int);
#ifndef __alpha_vxworks
@@ -1573,27 +1574,14 @@ __gnat_inum_to_ivec (int num)
return INUM_TO_IVEC (num);
}
-static void
-__gnat_error_handler (int sig, int code, struct sigcontext *sc)
+/* Exported to 5zintman.adb in order to handle different signal
+ to exception mappings in different VxWorks versions */
+void
+__gnat_map_signal (int sig)
{
struct Exception_Data *exception;
- sigset_t mask;
- int result;
char *msg;
- /* VxWorks will always mask out the signal during the signal handler and
- will reenable it on a longjmp. GNAT does not generate a longjmp to
- return from a signal handler so the signal will still be masked unless
- we unmask it. */
- sigprocmask (SIG_SETMASK, NULL, &mask);
- sigdelset (&mask, sig);
- sigprocmask (SIG_SETMASK, &mask, NULL);
-
- /* VxWorks will suspend the task when it gets a hardware exception. We
- take the liberty of resuming the task for the application. */
- if (taskIsSuspended (taskIdSelf ()) != 0)
- taskResume (taskIdSelf ());
-
switch (sig)
{
case SIGFPE:
@@ -1609,8 +1597,13 @@ __gnat_error_handler (int sig, int code,
msg = "SIGSEGV";
break;
case SIGBUS:
+#ifdef VTHREADS
+ exception = &storage_error;
+ msg = "SIGBUS: possible stack overflow";
+#else
exception = &program_error;
msg = "SIGBUS";
+#endif
break;
default:
exception = &program_error;
@@ -1620,6 +1613,29 @@ __gnat_error_handler (int sig, int code,
Raise_From_Signal_Handler (exception, msg);
}
+static void
+__gnat_error_handler (int sig, int code, struct sigcontext *sc)
+{
+ sigset_t mask;
+ int result;
+
+ /* VxWorks will always mask out the signal during the signal handler and
+ will reenable it on a longjmp. GNAT does not generate a longjmp to
+ return from a signal handler so the signal will still be masked unless
+ we unmask it. */
+ sigprocmask (SIG_SETMASK, NULL, &mask);
+ sigdelset (&mask, sig);
+ sigprocmask (SIG_SETMASK, &mask, NULL);
+
+ /* VxWorks will suspend the task when it gets a hardware exception. We
+ take the liberty of resuming the task for the application. */
+ if (taskIsSuspended (taskIdSelf ()) != 0)
+ taskResume (taskIdSelf ());
+
+ __gnat_map_signal (sig);
+
+}
+
void
__gnat_install_handler (void)
{
@@ -1755,6 +1771,8 @@ __gnat_install_handler(void)
sigaction (SIGSEGV, &act, NULL);
if (__gnat_get_interrupt_state (SIGBUS) != 's')
sigaction (SIGBUS, &act, NULL);
+
+ __gnat_handler_installed = 1;
}
void
@@ -1762,22 +1780,6 @@ __gnat_initialize (void)
{
__gnat_install_handler ();
__gnat_init_float ();
-}
-
-/***************************************/
-/* __gnat_initialize (RTEMS version) */
-/***************************************/
-
-#elif defined(__rtems__)
-
-extern void __gnat_install_handler (void);
-
-/* For RTEMS, each bsp will provide a custom __gnat_install_handler (). */
-
-void
-__gnat_initialize (void)
-{
- __gnat_install_handler ();
}
/***************************************/
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.59
diff -u -p -r1.59 Makefile.in
--- Makefile.in 8 Dec 2003 10:33:16 -0000 1.59
+++ Makefile.in 11 Dec 2003 13:31:28 -0000
@@ -1841,9 +1841,9 @@ rts-zfp: force
RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
-$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
+ cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
- $(AR) r rts-zfp/adalib/libgnat.a
$(CHMOD) a-wx rts-zfp/adalib/libgnat.a
rts-none: force
@@ -1862,8 +1862,9 @@ rts-ravenscar: force
COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
-$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
+ cd rts-ravenscar/adalib/ ; $(AR) r libgnat.a *.o
+ $(RM) rts-ravenscar/adalib/*.o
$(CHMOD) a-wx rts-ravenscar/adalib/*.ali
- $(AR) r rts-ravenscar/adalib/libgnat.a
$(CHMOD) a-wx rts-ravenscar/adalib/libgnat.a
# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.25
diff -u -p -r1.25 sem_ch3.adb
--- sem_ch3.adb 8 Dec 2003 10:33:16 -0000 1.25
+++ sem_ch3.adb 11 Dec 2003 13:31:28 -0000
@@ -8492,7 +8492,6 @@ package body Sem_Ch3 is
Set_Small_Value (T, Delta_Val);
Set_Scale_Value (T, Scale_Val);
Set_Is_Constrained (T);
-
end Decimal_Fixed_Point_Type_Declaration;
-----------------------
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_prag.adb
--- sem_prag.adb 5 Dec 2003 10:24:05 -0000 1.14
+++ sem_prag.adb 11 Dec 2003 13:31:28 -0000
@@ -432,8 +432,7 @@ package body Sem_Prag is
function Is_Before_First_Decl
(Pragma_Node : Node_Id;
- Decls : List_Id)
- return Boolean;
+ Decls : List_Id) return Boolean;
-- Return True if Pragma_Node is before the first declarative item in
-- Decls where Decls is the list of declarative items.
@@ -1122,7 +1121,6 @@ package body Sem_Prag is
when N_Index_Or_Discriminant_Constraint =>
declare
IDC : Entity_Id := First (Constraints (Constr));
-
begin
while Present (IDC) loop
Check_Static_Constraint (IDC);
@@ -1506,8 +1504,7 @@ package body Sem_Prag is
function Is_Before_First_Decl
(Pragma_Node : Node_Id;
- Decls : List_Id)
- return Boolean
+ Decls : List_Id) return Boolean
is
Item : Node_Id := First (Decls);
@@ -2185,8 +2182,7 @@ package body Sem_Prag is
function Same_Base_Type
(Ptype : Node_Id;
- Formal : Entity_Id)
- return Boolean;
+ Formal : Entity_Id) return Boolean;
-- Determines if Ptype references the type of Formal. Note that
-- only the base types need to match according to the spec. Ptype
-- here is the argument from the pragma, which is either a type
@@ -2196,7 +2192,10 @@ package body Sem_Prag is
-- Same_Base_Type --
--------------------
- function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is
+ function Same_Base_Type
+ (Ptype : Node_Id;
+ Formal : Entity_Id) return Boolean
+ is
Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
Pref : Node_Id;
@@ -2823,9 +2822,8 @@ package body Sem_Prag is
if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
declare
Cunit : constant Node_Id := Parent (Parent (N));
-
begin
- Set_Body_Required (Cunit, False);
+ Set_Body_Required (Cunit, False);
end;
end if;
end Process_Import_Or_Interface;
@@ -2869,10 +2867,21 @@ package body Sem_Prag is
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
- return
- Present (Exception_Handlers
- (Handled_Statement_Sequence
- (Unit_Declaration_Node (Corresponding_Body (Decl)))));
+ -- If the subprogram is a renaming as body, the body is
+ -- just a call to the renamed subprogram, and inlining is
+ -- trivially possible.
+
+ if Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ return False;
+
+ else
+ return
+ Present (Exception_Handlers
+ (Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)))));
+ end if;
else
-- If body is not available, assume the best, the check is
-- performed again when compiling enclosing package bodies.
@@ -3701,11 +3710,9 @@ package body Sem_Prag is
declare
Arg_Node : Node_Id;
-
begin
Arg_Count := 0;
Arg_Node := Arg1;
-
while Present (Arg_Node) loop
Arg_Count := Arg_Count + 1;
Next (Arg_Node);
@@ -4480,7 +4487,6 @@ package body Sem_Prag is
when Pragma_Convention => Convention : declare
C : Convention_Id;
E : Entity_Id;
-
begin
Check_Ada_83_Warning;
Check_Arg_Count (2);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_res.adb
--- sem_res.adb 27 Nov 2003 11:40:45 -0000 1.14
+++ sem_res.adb 11 Dec 2003 13:31:29 -0000
@@ -3727,6 +3727,13 @@ package body Sem_Res is
Establish_Transient_Scope
(N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
+ -- If the call appears within the bounds of a loop, it will
+ -- be rewritten and reanalyzed, nothing left to do here.
+
+ if Nkind (N) /= N_Function_Call then
+ return;
+ end if;
+
elsif Is_Init_Proc (Nam)
and then not Within_Init_Proc
then
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_util.adb
--- sem_util.adb 8 Dec 2003 10:33:16 -0000 1.16
+++ sem_util.adb 11 Dec 2003 13:31:29 -0000
@@ -6371,7 +6371,10 @@ package body Sem_Util is
Error_Msg_N (
"operator of the type is not directly visible!", Expr);
- elsif Ekind (Found_Type) = E_Void then
+ elsif Ekind (Found_Type) = E_Void
+ and then Present (Parent (Found_Type))
+ and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
+ then
Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
else
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.16
diff -u -p -r1.16 sinfo.ads
--- sinfo.ads 24 Nov 2003 14:27:57 -0000 1.16
+++ sinfo.ads 11 Dec 2003 13:31:29 -0000
@@ -244,7 +244,7 @@ package Sinfo is
-- Variant := First (Variants (N));
-- while Present (Variant) loop
-- ...
- -- Alt := Next (Alt);
+ -- Variant := Next (Variant);
-- end loop;
-- or
@@ -252,7 +252,7 @@ package Sinfo is
-- Variant := First_Non_Pragma (Variants (N));
-- while Present (Variant) loop
-- ...
- -- Alt := Next_Non_Pragma (Alt);
+ -- Variant := Next_Non_Pragma (Variant);
-- end loop;
-- In the first form of the loop, Variant can either be an N_Pragma or
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-08 10:34 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-08 10:34 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-08 Jerome Guitton <guitton@act-europe.fr>
* 5ytiitho.adb, 5zthrini.adb, 5ztiitho.adb, i-vthrea.adb,
i-vthrea.ads, s-tpae65.adb, s-tpae65.ads: Cleanup: Remove a bunch of
obsolete files.
* Makefile.in: (rts-ravenscar): Generate an empty libgnat.a.
(rts-zfp): Ditto.
2003-12-08 Robert Dewar <dewar@gnat.com>
* 7sintman.adb: Minor reformatting
* bindgen.adb: Configurable_Run_Time mode no longer suppresses the
standard linker options to get standard libraries linked. We now plan
to provide dummy versions of these libraries to match the appropriate
configurable run-time (e.g. if a library is not needed at all, provide
a dummy empty library).
* targparm.ads: Configurable_Run_Time mode no longer affects linker
options (-L parameters and standard libraries). What we plan to do is
to provide dummy libraries where the libraries are not required.
* gnatbind.adb: Minor comment improvement
2003-12-08 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb (Build_Record_Aggr_Code): Do not remove the expanded
aggregate in the parent. Otherwise constants with limited aggregates
are not supported. Add new formal to pass the component type (Ctype).
It is required to call the corresponding IP subprogram in case of
default initialized components.
(Gen_Assign): In case of default-initialized component, generate a
call to the IP subprogram associated with the component.
(Build_Record_Aggr_Code): Remove the aggregate from the parent in case
of aggregate with default initialized components.
(Has_Default_Init_Comps): Improve implementation to recursively check
all the present expressions.
* exp_ch3.ads, exp_ch3.adb (Build_Initialization_Call): Add new formal
to indicate that the initialization call corresponds to a
default-initialized component of an aggregate.
In case of default initialized aggregate with tasks this parameter is
used to generate a null string (this is just a workaround that must be
improved later). In case of discriminants, this parameter is used to
generate a selected component node that gives access to the discriminant
value.
* exp_ch9.ads, exp_ch9.adb (Build_Task_Allocate_Block_With_Stmts): New
subprogram, based on Build_Task_Allocate_Block, but adapted to expand
allocated aggregates with default-initialized components.
* par-ch4.adb (P_Aggregate_Or_Paren_Expr): Improve error message if
the box notation is used in positional aggregates.
2003-12-08 Samuel Tardieu <tardieu@act-europe.fr>
* lib.ads: Fix typo in comment
2003-12-08 Vincent Celier <celier@gnat.com>
* prj.adb (Project_Empty): New component Unkept_Comments
(Scan): Remove procedure; moved to Prj.Err.
* prj.ads (Project_Data): New Boolean component Unkept_Comments
(Scan): Remove procedure; moved to Prj.Err.
* prj-dect.adb: Manage comments for the different declarations.
* prj-part.adb (With_Record): New component Node
(Parse): New Boolean parameter Store_Comments, defaulted to False.
Set the scanner to return ends of line and comments as tokens, if
Store_Comments is True.
(Pre_Parse_Context_Clause): Create the N_With_Clause nodes so that
comments are associated with these nodes. Store the node IDs in the
With_Records.
(Post_Parse_Context_Clause): Use the N_With_Clause nodes stored in the
With_Records.
(Parse_Single_Project): Call Pre_Parse_Context_Clause before creating
the N_Project node. Call Tree.Save and Tree.Reset before scanning the
current project. Call Tree.Restore afterwards. Set the various nodes
for comment storage (Next_End, End_Of_Line, Previous_Line,
Previous_End).
* prj-part.ads (Parse): New Boolean parameter Store_Comments,
defaulted to False.
* prj-pp.adb (Write_String): New Boolean parameter Truncated, defaulted
to False. When Truncated is True, truncate the string, never go to the
next line.
(Write_End_Of_Line_Comment): New procedure
(Print): Process comments for nodes N_With_Clause,
N_Package_Declaration, N_String_Type_Declaration,
N_Attribute_Declaration, N_Typed_Variable_Declaration,
N_Variable_Declaration, N_Case_Construction, N_Case_Item.
Process nodes N_Comment.
* prj-tree.ads, prj-tree.adb (Default_Project_Node): If it is a node
without comments and there are some comments, set the flag
Unkept_Comments to True.
(Scan): If there are comments, set the flag Unkept_Comments to True and
clear the comments.
(Project_Node_Kind): Add enum values N_Comment_Zones, N_Comment
(Next_End_Nodes: New table
(Comment_Zones_Of): New function
(Scan): New procedure; moved from Prj. Accumulate comments in the
Comments table and set end of line comments, comments after, after end
and before end.
(Add_Comments): New procedure
(Save, Restore, Seset_State): New procedures
(There_Are_Unkept_Comments): New function
(Set_Previous_Line_Node, Set_Previous_End_Node): New procedures
(Set_End_Of_Line, Set_Next_End_Node, Remove_Next_End_Node): New
procedures.
(First_Comment_After, First_Comment_After_End): New functions
(First_Comment_Before, First_Comment_Before_End): New functions
(Next_Comment): New function
(End_Of_Line_Comment, Follows_Empty_Line,
Is_Followed_By_Empty_Line): New functions
(Set_First_Comment_After, Set_First_Comment_After_End): New procedures
(Set_First_Comment_Before, Set_First_Comment_Before_End): New procedures
(Set_Next_Comment): New procedure
(Default_Project_Node): Associate comment before if the node can store
comments.
* scans.ads (Token_Type): New enumeration value Tok_Comment
(Comment_Id): New global variable
* scng.ads, scng.adb (Comment_Is_Token): New Boolean global variable,
defaulted to False.
(Scan): Store position of start of comment. If comments are tokens, set
Comment_Id and set Token to Tok_Comment when scanning a comment.
(Set_Comment_As_Token): New procedure
* sinput-p.adb: Update Copyright notice
(Source_File_Is_Subunit): Call Prj.Err.Scanner.Scan instead of Prj.Scan
that no longer exists.
2003-12-08 Javier Miranda <miranda@gnat.com>
* sem_aggr.adb: Add dependence on Exp_Tss package
Correct typo in comment
(Resolve_Aggregate): In case of array aggregates set the estimated
type of the aggregate before calling resolve. This is needed to know
the name of the corresponding IP in case of limited array aggregates.
(Resolve_Array_Aggregate): Delay the resolution to the expansion phase
in case of default initialized array components.
* sem_ch12.adb (Analyze_Formal_Object_Declaration): Allow limited
types. Required to give support to limited aggregates in generic
formals.
2003-12-08 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Check_Initialization): For legality purposes, an
inlined body functions like an instantiation.
(Decimal_Fixed_Point_Declaration): Do not set kind of first subtype
until bounds are analyzed, to diagnose premature use of type.
* sem_util.adb (Wrong_Type): Improve error message when the type of
the expression is used prematurely.
2003-12-08 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 7sintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7sintman.adb,v
retrieving revision 1.7
diff -u -p -r1.7 7sintman.adb
--- 7sintman.adb 5 Dec 2003 10:24:04 -0000 1.7
+++ 7sintman.adb 8 Dec 2003 10:31:49 -0000
@@ -152,7 +152,7 @@ begin
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
+ -- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
@@ -178,9 +178,9 @@ begin
act.sa_flags := SA_SIGINFO;
-- Setting SA_SIGINFO asks the kernel to pass more than just the signal
- -- number argument to the handler when it is called. The set of extra
+ -- number argument to the handler when it is called. The set of extra
-- parameters typically includes a pointer to a structure describing
- -- the interrupted context. Although the Notify_Exception handler does
+ -- the interrupted context. Although the Notify_Exception handler does
-- not use this information, it is actually required for the GCC/ZCX
-- exception propagation scheme because on some targets (at least
-- alpha-tru64), the structure contents are not even filled when this
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.16
diff -u -p -r1.16 bindgen.adb
--- bindgen.adb 14 Nov 2003 10:24:42 -0000 1.16
+++ bindgen.adb 8 Dec 2003 10:31:49 -0000
@@ -1774,22 +1774,18 @@ package body Bindgen is
end if;
end loop;
- -- Add a "-Ldir" for each directory in the object path. We skip this
- -- in Configurable_Run_Time mode, where we want more precise control
- -- of exactly what goes into the resulting object file
-
- if not Configurable_Run_Time_Mode then
- for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
- declare
- Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("-L");
- Add_Str_To_Name_Buffer (Dir.all);
- Write_Linker_Option;
- end;
- end loop;
- end if;
+ -- Add a "-Ldir" for each directory in the object path
+
+ for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
+ declare
+ Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
+ begin
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer ("-L");
+ Add_Str_To_Name_Buffer (Dir.all);
+ Write_Linker_Option;
+ end;
+ end loop;
-- Sort linker options
@@ -1845,7 +1841,7 @@ package body Bindgen is
-- files. The reason for this decision is that libraries referenced
-- by internal routines may reference these standard library entries.
- if not (Configurable_Run_Time_Mode or else Opt.No_Stdlib) then
+ if not Opt.No_Stdlib then
Name_Len := 0;
if Opt.Shared_Libgnat then
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_aggr.adb
--- exp_aggr.adb 20 Nov 2003 09:53:58 -0000 1.10
+++ exp_aggr.adb 8 Dec 2003 10:31:50 -0000
@@ -33,6 +33,7 @@ with Expander; use Expander;
with Exp_Util; use Exp_Util;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch9; use Exp_Ch9;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Itypes; use Itypes;
@@ -170,6 +171,7 @@ package body Exp_Aggr is
function Build_Array_Aggr_Code
(N : Node_Id;
+ Ctype : Entity_Id;
Index : Node_Id;
Into : Node_Id;
Scalar_Comp : Boolean;
@@ -397,6 +399,7 @@ package body Exp_Aggr is
function Build_Array_Aggr_Code
(N : Node_Id;
+ Ctype : Entity_Id;
Index : Node_Id;
Into : Node_Id;
Scalar_Comp : Boolean;
@@ -430,6 +433,9 @@ package body Exp_Aggr is
-- Into (Indices, Ind) := Expr;
--
-- Otherwise we call Build_Code recursively.
+ --
+ -- Ada0Y (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;
-- Nodes L and H must be side-effect free expressions.
@@ -656,7 +662,13 @@ package body Exp_Aggr is
Res : List_Id;
begin
- if Nkind (Parent (Expr)) = N_Component_Association
+ -- Ada0Y (AI-287): Do nothing else in case of default initialized
+ -- component
+
+ if not Present (Expr) then
+ return Lis;
+
+ elsif Nkind (Parent (Expr)) = N_Component_Association
and then Present (Loop_Actions (Parent (Expr)))
then
Append_List (Lis, Loop_Actions (Parent (Expr)));
@@ -692,15 +704,20 @@ package body Exp_Aggr is
F := Find_Final_List (Current_Scope);
end if;
else
- F := 0;
+ F := Empty;
end if;
if Present (Next_Index (Index)) then
return
Add_Loop_Actions (
Build_Array_Aggr_Code
- (Expr, Next_Index (Index),
- Into, Scalar_Comp, New_Indices, F));
+ (N => Expr,
+ Ctype => Ctype,
+ Index => Next_Index (Index),
+ Into => Into,
+ Scalar_Comp => Scalar_Comp,
+ Indices => New_Indices,
+ Flist => F));
end if;
-- If we get here then we are at a bottom-level (sub-)aggregate
@@ -713,7 +730,12 @@ package body Exp_Aggr is
Set_Assignment_OK (Indexed_Comp);
- if Nkind (Expr) = N_Qualified_Expression then
+ -- Ada0Y (AI-287): In case of default initialized component, Expr
+ -- is not present (and therefore we also initialize Expr_Q to empty)
+
+ if not Present (Expr) then
+ Expr_Q := Empty;
+ elsif Nkind (Expr) = N_Qualified_Expression then
Expr_Q := Expression (Expr);
else
Expr_Q := Expr;
@@ -723,34 +745,49 @@ package body Exp_Aggr is
and then Etype (N) /= Any_Composite
then
Comp_Type := Component_Type (Etype (N));
+ pragma Assert (Comp_Type = Ctype); -- AI-287
elsif Present (Next (First (New_Indices))) then
- -- This is a multidimensional array. Recover the component
- -- type from the outermost aggregate, because subaggregates
- -- do not have an assigned type.
+ -- Ada0Y (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
+ -- formal can be used to replace this code in all cases.
+
+ if Present (Expr) then
+
+ -- This is a multidimensional array. Recover the component
+ -- type from the outermost aggregate, because subaggregates
+ -- do not have an assigned type.
- declare
- P : Node_Id := Parent (Expr);
+ declare
+ P : Node_Id := Parent (Expr);
- begin
- while Present (P) loop
+ begin
+ while Present (P) loop
- if Nkind (P) = N_Aggregate
- and then Present (Etype (P))
- then
- Comp_Type := Component_Type (Etype (P));
- exit;
+ if Nkind (P) = N_Aggregate
+ and then Present (Etype (P))
+ then
+ Comp_Type := Component_Type (Etype (P));
+ exit;
- else
- P := Parent (P);
- end if;
- end loop;
- end;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+ pragma Assert (Comp_Type = Ctype); -- AI-287
+ end;
+ end if;
end if;
- if Nkind (Expr_Q) = N_Aggregate
- or else Nkind (Expr_Q) = N_Extension_Aggregate
+ -- Ada0Y (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
+ or else Nkind (Expr_Q) = N_Extension_Aggregate)
then
-- At this stage the Expression may not have been
-- analyzed yet because the array aggregate code has not
@@ -771,59 +808,73 @@ package body Exp_Aggr is
end if;
end if;
- -- Now generate the assignment with no associated controlled
- -- actions since the target of the assignment may not have
- -- been initialized, it is not possible to Finalize it as
- -- expected by normal controlled assignment. The rest of the
- -- controlled actions are done manually with the proper
- -- finalization list coming from the context.
+ -- Ada0Y (AI-287): In case of default initialized component, call
+ -- the initialization subprogram associated with the component type
- A :=
- Make_OK_Assignment_Statement (Loc,
- Name => Indexed_Comp,
- Expression => New_Copy_Tree (Expr));
+ if not Present (Expr) then
- if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
- Set_No_Ctrl_Actions (A);
- end if;
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Indexed_Comp,
+ Typ => Ctype,
+ With_Default_Init => True));
- Append_To (L, A);
+ else
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for the Java VM
- -- where tags are implicit.
+ -- Now generate the assignment with no associated controlled
+ -- actions since the target of the assignment may not have
+ -- been initialized, it is not possible to Finalize it as
+ -- expected by normal controlled assignment. The rest of the
+ -- controlled actions are done manually with the proper
+ -- finalization list coming from the context.
- if Present (Comp_Type)
- and then Is_Tagged_Type (Comp_Type)
- and then not Java_VM
- then
A :=
Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Indexed_Comp),
- Selector_Name =>
- New_Reference_To (Tag_Component (Comp_Type), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (
- Access_Disp_Table (Comp_Type), Loc)));
+ Name => Indexed_Comp,
+ Expression => New_Copy_Tree (Expr));
+
+ if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
+ Set_No_Ctrl_Actions (A);
+ end if;
Append_To (L, A);
- end if;
- -- Adjust and Attach the component to the proper final list
- -- which can be the controller of the outer record object or
- -- the final list associated with the scope
+ -- Adjust the tag if tagged (because of possible view
+ -- conversions), unless compiling for the Java VM
+ -- where tags are implicit.
- if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
- Append_List_To (L,
- Make_Adjust_Call (
- Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Comp_Type,
- Flist_Ref => F,
- With_Attach => Make_Integer_Literal (Loc, 1)));
+ if Present (Comp_Type)
+ and then Is_Tagged_Type (Comp_Type)
+ and then not Java_VM
+ then
+ A :=
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Indexed_Comp),
+ Selector_Name =>
+ New_Reference_To (Tag_Component (Comp_Type), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (
+ Access_Disp_Table (Comp_Type), Loc)));
+
+ Append_To (L, A);
+ end if;
+
+ -- Adjust and Attach the component to the proper final list
+ -- which can be the controller of the outer record object or
+ -- the final list associated with the scope
+
+ if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
+ Append_List_To (L,
+ Make_Adjust_Call (
+ Ref => New_Copy_Tree (Indexed_Comp),
+ Typ => Comp_Type,
+ Flist_Ref => F,
+ With_Attach => Make_Integer_Literal (Loc, 1)));
+ end if;
end if;
return Add_Loop_Actions (L);
@@ -857,21 +908,29 @@ package body Exp_Aggr is
if Empty_Range (L, H) then
Append_To (S, Make_Null_Statement (Loc));
- -- The expression must be type-checked even though no component
- -- of the aggregate will have this value. This is done only for
- -- actual components of the array, not for subaggregates. Do the
- -- check on a copy, because the expression may be shared among
- -- several choices, some of which might be non-null.
-
- if Present (Etype (N))
- and then Is_Array_Type (Etype (N))
- and then No (Next_Index (Index))
- then
- Expander_Mode_Save_And_Set (False);
- Tcopy := New_Copy_Tree (Expr);
- Set_Parent (Tcopy, N);
- Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
- Expander_Mode_Restore;
+ -- Ada0Y (AI-287): Nothing else need to be done in case of
+ -- default initialized component
+
+ if not Present (Expr) then
+ null;
+
+ else
+ -- The expression must be type-checked even though no component
+ -- of the aggregate will have this value. This is done only for
+ -- actual components of the array, not for subaggregates. Do
+ -- the check on a copy, because the expression may be shared
+ -- among several choices, some of which might be non-null.
+
+ if Present (Etype (N))
+ and then Is_Array_Type (Etype (N))
+ and then No (Next_Index (Index))
+ then
+ Expander_Mode_Save_And_Set (False);
+ Tcopy := New_Copy_Tree (Expr);
+ Set_Parent (Tcopy, N);
+ Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
+ Expander_Mode_Restore;
+ end if;
end if;
return S;
@@ -891,6 +950,7 @@ package body Exp_Aggr is
and then Local_Compile_Time_Known_Value (H)
and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
then
+
Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
@@ -1084,7 +1144,8 @@ package body Exp_Aggr is
Expr : Node_Id;
Typ : Entity_Id;
- Others_Expr : Node_Id := Empty;
+ Others_Expr : Node_Id := Empty;
+ Others_Mbox_Present : Boolean := False;
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
@@ -1096,8 +1157,8 @@ package body Exp_Aggr is
Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free.
- Low : Node_Id;
- High : Node_Id;
+ Low : Node_Id;
+ High : Node_Id;
Nb_Choices : Nat := 0;
Table : Case_Table_Type (1 .. Number_Of_Choices (N));
@@ -1144,7 +1205,12 @@ package body Exp_Aggr is
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Set_Loop_Actions (Assoc, New_List);
- Others_Expr := Expression (Assoc);
+
+ if Box_Present (Assoc) then
+ Others_Mbox_Present := True;
+ else
+ Others_Expr := Expression (Assoc);
+ end if;
exit;
end if;
@@ -1155,9 +1221,15 @@ package body Exp_Aggr is
end if;
Nb_Choices := Nb_Choices + 1;
- Table (Nb_Choices) := (Choice_Lo => Low,
- Choice_Hi => High,
- Choice_Node => Expression (Assoc));
+ if Box_Present (Assoc) then
+ Table (Nb_Choices) := (Choice_Lo => Low,
+ Choice_Hi => High,
+ Choice_Node => Empty);
+ else
+ Table (Nb_Choices) := (Choice_Lo => Low,
+ Choice_Hi => High,
+ Choice_Node => Expression (Assoc));
+ end if;
Next (Choice);
end loop;
@@ -1185,7 +1257,7 @@ package body Exp_Aggr is
-- We don't need to generate loops over empty gaps, but if there is
-- a single empty range we must analyze the expression for semantics
- if Present (Others_Expr) then
+ if Present (Others_Expr) or else Others_Mbox_Present then
declare
First : Boolean := True;
@@ -1254,12 +1326,21 @@ package body Exp_Aggr is
if Present (Component_Associations (N)) then
Assoc := Last (Component_Associations (N));
- Expr := Expression (Assoc);
- Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
- Aggr_High,
- Expr),
- To => New_Code);
+ -- Ada0Y (AI-287)
+ if Box_Present (Assoc) then
+ Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
+ Aggr_High,
+ Empty),
+ To => New_Code);
+ else
+ Expr := Expression (Assoc);
+
+ Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
+ Aggr_High,
+ Expr), -- AI-287
+ To => New_Code);
+ end if;
end if;
end if;
@@ -1544,11 +1625,19 @@ package body Exp_Aggr is
-- 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)))))
then
if Init_Pr then
@@ -1666,11 +1755,22 @@ package body Exp_Aggr is
Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
Set_Assignment_OK (Ref);
- Append_List_To (Start_L,
- Build_Initialization_Call (Loc,
- Id_Ref => Ref,
- Typ => Init_Typ,
- In_Init_Proc => Within_Init_Proc));
+ if Has_Default_Init_Comps (N)
+ or else Has_Task (Base_Type (Init_Typ))
+ then
+ Append_List_To (Start_L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => Init_Typ,
+ In_Init_Proc => Within_Init_Proc,
+ With_Default_Init => True));
+ else
+ Append_List_To (Start_L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => Init_Typ,
+ In_Init_Proc => Within_Init_Proc));
+ end if;
if Is_Constrained (Entity (A))
and then Has_Discriminants (Entity (A))
@@ -1812,18 +1912,48 @@ package body Exp_Aggr is
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
- -- Default initialization of a limited component
+ -- Ada0Y (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
+ -- 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)
+
+ declare
+ Ctype : Entity_Id := Etype (Selector);
+ Inside_Allocator : Boolean := False;
+ P : Node_Id := Parent (N);
+
+ begin
+ if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
+ while Present (P) loop
+ if Nkind (P) = N_Allocator then
+ Inside_Allocator := True;
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if not Inside_Init_Proc and not Inside_Allocator then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (N));
+ end if;
+ end if;
+ end;
+
Append_List_To (L,
Build_Initialization_Call (Loc,
Id_Ref => Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Selector,
- Loc)),
- Typ => Etype (Selector)));
+ Loc)),
+ Typ => Etype (Selector),
+ With_Default_Init => True));
goto Next_Comp;
end if;
@@ -2200,10 +2330,26 @@ package body Exp_Aggr is
Access_Type : constant Entity_Id := Etype (Temp);
begin
- Insert_Actions_After (Decl,
- Late_Expansion (Aggr, Typ, Occ,
- Find_Final_List (Access_Type),
- Associated_Final_Chain (Base_Type (Access_Type))));
+ if Has_Default_Init_Comps (Aggr) then
+ declare
+ L : constant List_Id := New_List;
+ Init_Stmts : List_Id;
+
+ begin
+ Init_Stmts := Late_Expansion (Aggr, Typ, Occ,
+ Find_Final_List (Access_Type),
+ Associated_Final_Chain (Base_Type (Access_Type)));
+
+ Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
+ Insert_Actions_After (Decl, L);
+ end;
+
+ else
+ Insert_Actions_After (Decl,
+ Late_Expansion (Aggr, Typ, Occ,
+ Find_Final_List (Access_Type),
+ Associated_Final_Chain (Base_Type (Access_Type))));
+ end if;
end Convert_Aggr_In_Allocator;
--------------------------------
@@ -2706,6 +2852,14 @@ package body Exp_Aggr is
-- Start of processing for Convert_To_Positional
begin
+ -- Ada0Y (AI-287): Do not convert in case of default initialized
+ -- components because in this case will need to call the corresponding
+ -- IP procedure.
+
+ if Has_Default_Init_Comps (N) then
+ return;
+ end if;
+
if Is_Flat (N, Number_Dimensions (Typ)) then
return;
end if;
@@ -3827,14 +3981,19 @@ package body Exp_Aggr is
(N, Sec_Stack => Has_Controlled_Component (Typ));
end if;
- Maybe_In_Place_OK :=
- Comes_From_Source (N)
- and then Nkind (Parent (N)) = N_Assignment_Statement
- and then not Is_Bit_Packed_Array (Typ)
- and then not Has_Controlled_Component (Typ)
- and then In_Place_Assign_OK;
+ if Has_Default_Init_Comps (N) then
+ Maybe_In_Place_OK := False;
+ else
+ Maybe_In_Place_OK :=
+ Comes_From_Source (N)
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then not Is_Bit_Packed_Array (Typ)
+ and then not Has_Controlled_Component (Typ)
+ and then In_Place_Assign_OK;
+ end if;
- if Comes_From_Source (Parent (N))
+ if not Has_Default_Init_Comps (N)
+ and then Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration
and then not Must_Slide (N, Typ)
and then N = Expression (Parent (N))
@@ -3938,6 +4097,15 @@ package body Exp_Aggr is
Target := New_Reference_To (Tmp, Loc);
else
+
+ if Has_Default_Init_Comps (N) then
+
+ -- Ada0Y (AI-287): This case has not been analyzed???
+
+ pragma Assert (False);
+ null;
+ end if;
+
-- Name in assignment is explicit dereference.
Target := New_Copy (Tmp);
@@ -3945,6 +4113,7 @@ package body Exp_Aggr is
Aggr_Code :=
Build_Array_Aggr_Code (N,
+ Ctype => Ctyp,
Index => First_Index (Typ),
Into => Target,
Scalar_Comp => Is_Scalar_Type (Ctyp));
@@ -4478,14 +4647,17 @@ package body Exp_Aggr is
function Has_Default_Init_Comps (N : Node_Id) return Boolean is
Comps : constant List_Id := Component_Associations (N);
C : Node_Id;
-
+ Expr : Node_Id;
begin
pragma Assert (Nkind (N) = N_Aggregate
- or else Nkind (N) = N_Extension_Aggregate);
+ or else Nkind (N) = N_Extension_Aggregate);
+
if No (Comps) then
return False;
end if;
+ -- Check if any direct component has default initialized components
+
C := First (Comps);
while Present (C) loop
if Box_Present (C) then
@@ -4494,6 +4666,24 @@ package body Exp_Aggr is
Next (C);
end loop;
+
+ -- Recursive call in case of aggregate expression
+
+ C := First (Comps);
+ while Present (C) loop
+ Expr := Expression (C);
+
+ if Present (Expr)
+ and then (Nkind (Expr) = N_Aggregate
+ or else Nkind (Expr) = N_Extension_Aggregate)
+ and then Has_Default_Init_Comps (Expr)
+ then
+ return True;
+ end if;
+
+ Next (C);
+ end loop;
+
return False;
end Has_Default_Init_Comps;
@@ -4527,20 +4717,23 @@ package body Exp_Aggr is
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty) return List_Id
- is
+ Obj : Entity_Id := Empty) return List_Id is
begin
if Is_Record_Type (Etype (N)) then
return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
- else
+ elsif Is_Array_Type (Etype (N)) then
return
Build_Array_Aggr_Code
- (N,
- First_Index (Typ),
- Target,
- Is_Scalar_Type (Component_Type (Typ)),
- No_List,
- Flist);
+ (N => N,
+ Ctype => Component_Type (Etype (N)),
+ Index => First_Index (Typ),
+ Into => Target,
+ Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
+ Indices => No_List,
+ Flist => Flist);
+ else
+ pragma Assert (False);
+ return New_List;
end if;
end Late_Expansion;
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_ch3.adb
--- exp_ch3.adb 27 Oct 2003 14:27:17 -0000 1.10
+++ exp_ch3.adb 8 Dec 2003 10:31:50 -0000
@@ -56,6 +56,7 @@ with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
+with Stringt; use Stringt;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -1032,13 +1033,14 @@ package body Exp_Ch3 is
-- end;
function Build_Initialization_Call
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
- Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List)
- return List_Id
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ Typ : Entity_Id;
+ In_Init_Proc : Boolean := False;
+ Enclos_Type : Entity_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False)
+ return List_Id
is
First_Arg : Node_Id;
Args : List_Id;
@@ -1076,7 +1078,6 @@ package body Exp_Ch3 is
-- honest. Actually it isn't quite type honest, because there can be
-- conflicts of views in the private type case. That is why we set
-- Conversion_OK in the conversion node.
-
if (Is_Record_Type (Typ)
or else Is_Array_Type (Typ)
or else Is_Private_Type (Typ))
@@ -1110,12 +1111,28 @@ package body Exp_Ch3 is
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
- Decl := Last (Decls);
+ -- Ada0Y (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???
- Append_To (Args,
- New_Occurrence_Of (Defining_Identifier (Decl), Loc));
- Append_List (Decls, Res);
+ if With_Default_Init then
+ declare
+ S : String_Id;
+ Null_String : Node_Id;
+ begin
+ Start_String;
+ S := End_String;
+ Null_String := Make_String_Literal (Loc, Strval => S);
+ Append_To (Args, Null_String);
+ end;
+ else
+ Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
+ Decl := Last (Decls);
+
+ Append_To (Args,
+ New_Occurrence_Of (Defining_Identifier (Decl), Loc));
+ Append_List (Decls, Res);
+ end if;
else
Decls := No_List;
@@ -1202,7 +1219,22 @@ package body Exp_Ch3 is
end if;
end if;
- Append_To (Args, Arg);
+ -- Ada0Y (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
+ -- corresponding formal.
+
+ if With_Default_Init
+ and then Nkind (Id_Ref) = N_Selected_Component
+ then
+ Append_To (Args,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Prefix (Id_Ref)),
+ Selector_Name => Arg));
+ else
+ Append_To (Args, Arg);
+ end if;
Next_Discriminant (Discr);
end loop;
Index: exp_ch3.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.ads,v
retrieving revision 1.6
diff -u -p -r1.6 exp_ch3.ads
--- exp_ch3.ads 21 Oct 2003 13:41:59 -0000 1.6
+++ exp_ch3.ads 8 Dec 2003 10:31:50 -0000
@@ -52,13 +52,14 @@ package Exp_Ch3 is
-- and the discriminant checking functions are inserted after this node.
function Build_Initialization_Call
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
- Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List)
- return List_Id;
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ Typ : Entity_Id;
+ In_Init_Proc : Boolean := False;
+ Enclos_Type : Entity_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False)
+ return List_Id;
-- Builds a call to the initialization procedure of the Id entity. Id_Ref
-- is either a new reference to Id (for record fields), or an indexed
-- component (for array elements). Loc is the source location for the
@@ -76,6 +77,10 @@ package Exp_Ch3 is
-- entry families bounded by discriminants, protected type discriminants
-- can appear within expressions in array bounds (not as stand-alone
-- identifiers) and a general replacement is necessary.
+ --
+ -- Ada0Y (AI-287): With_Default_Init is used to indicate that the initia-
+ -- lization call corresponds to a default initialized component of an
+ -- aggregate.
procedure Freeze_Type (N : Node_Id);
-- This procedure executes the freezing actions associated with the given
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_ch9.adb
--- exp_ch9.adb 21 Oct 2003 13:41:59 -0000 1.8
+++ exp_ch9.adb 8 Dec 2003 10:31:51 -0000
@@ -69,8 +69,7 @@ package body Exp_Ch9 is
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
- Tsk : Entity_Id)
- return Node_Id;
+ Tsk : Entity_Id) return Node_Id;
-- Compute the index position for an entry call. Tsk is the target
-- task. If the bounds of some entry family depend on discriminants,
-- the expression computed by this function uses the discriminants
@@ -79,8 +78,7 @@ package body Exp_Ch9 is
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
- Prot : Entity_Id)
- return List_Id;
+ Prot : Entity_Id) return List_Id;
-- For an entry family and its barrier function, we define a local entity
-- that maps the index in the call into the entry index into the object:
--
@@ -105,23 +103,20 @@ package body Exp_Ch9 is
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id;
+ Pid : Node_Id) return Node_Id;
-- Build the function body returning the value of the barrier expression
-- for the specified entry body.
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Build a specification for a function implementing
-- the protected entry barrier of the specified entry body.
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Node_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Common to tasks and protected types. Copy discriminant specifications,
-- build record declaration. N is the type declaration, Ctyp is the
-- concurrent entity (task type or protected type).
@@ -129,40 +124,33 @@ package body Exp_Ch9 is
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Compute number of entries for concurrent object. This is a count of
-- simple entries, followed by an expression that computes the length
-- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type.
- function Build_Find_Body_Index
- (Typ : Entity_Id)
- return Node_Id;
+ function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
- function Build_Find_Body_Index_Spec
- (Typ : Entity_Id)
- return Node_Id;
- -- Build subprogram declaration for previous one.
+ function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
+ -- Build subprogram declaration for previous one
function Build_Protected_Entry
- (N : Node_Id;
- Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id;
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Pid : Node_Id) return Node_Id;
-- Build the procedure implementing the statement sequence of
-- the specified entry body.
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Build a specification for a procedure implementing
-- the statement sequence of the specified entry body.
-- Add attributes associating it with the entry defining identifier
@@ -171,8 +159,7 @@ package body Exp_Ch9 is
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
- N_Op_Spec : Node_Id)
- return Node_Id;
+ N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the protected version of a protected
-- subprogram. Its statement sequence first defers abortion, then locks
-- the associated protected object, and then enters a block that contains
@@ -185,8 +172,7 @@ package body Exp_Ch9 is
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
- Ident : Entity_Id)
- return List_Id;
+ Ident : Entity_Id) return List_Id;
-- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
-- Subprogram_Type. Builds signature of protected subprogram, adding the
-- formal that corresponds to the object itself. For an access to protected
@@ -197,8 +183,7 @@ package body Exp_Ch9 is
function Build_Selected_Name
(Prefix, Selector : Name_Id;
- Append_Char : Character := ' ')
- return Name_Id;
+ Append_Char : Character := ' ') return Name_Id;
-- Build a name in the form of Prefix__Selector, with an optional
-- character appended. This is used for internal subprograms generated
-- for operations of protected types, including barrier functions. In
@@ -227,9 +212,8 @@ package body Exp_Ch9 is
-- value type that is associated with the task type.
function Build_Unprotected_Subprogram_Body
- (N : Node_Id;
- Pid : Node_Id)
- return Node_Id;
+ (N : Node_Id;
+ Pid : Node_Id) return Node_Id;
-- This routine constructs the unprotected version of a protected
-- subprogram body, which is contains all of the code in the
-- original, unexpanded body. This is the version of the protected
@@ -248,8 +232,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id;
+ Ttyp : Entity_Id) return Node_Id;
-- Compute (Hi - Lo) for two entry family indices. Hi is the index in
-- an accept statement, or the upper bound in the discrete subtype of
-- an entry declaration. Lo is the corresponding lower bound. Ttyp is
@@ -259,8 +242,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id;
+ Ttyp : Entity_Id) return Node_Id;
-- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
-- a family, and handle properly the superflat case. This is equivalent
-- to the use of 'Length on the index type, but must use Family_Offset
@@ -275,9 +257,8 @@ package body Exp_Ch9 is
-- the entry name, and the entry family index.
function Find_Task_Or_Protected_Pragma
- (T : Node_Id;
- P : Name_Id)
- return Node_Id;
+ (T : Node_Id;
+ P : Name_Id) return Node_Id;
-- Searches the task or protected definition T for the first occurrence
-- of the pragma whose name is given by P. The caller has ensured that
-- the pragma is present in the task definition. A special case is that
@@ -302,8 +283,7 @@ package body Exp_Ch9 is
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
- Tsk : Entity_Id)
- return Node_Id
+ Tsk : Entity_Id) return Node_Id
is
Ttyp : constant Entity_Id := Etype (Tsk);
Expr : Node_Id;
@@ -746,8 +726,7 @@ package body Exp_Ch9 is
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id
+ Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
@@ -816,8 +795,7 @@ package body Exp_Ch9 is
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
begin
return Make_Function_Specification (Loc,
@@ -841,9 +819,8 @@ package body Exp_Ch9 is
--------------------------
function Build_Call_With_Task
- (N : Node_Id;
- E : Entity_Id)
- return Node_Id
+ (N : Node_Id;
+ E : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
@@ -861,8 +838,7 @@ package body Exp_Ch9 is
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
@@ -941,8 +917,7 @@ package body Exp_Ch9 is
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Eindx : Nat;
Ent : Entity_Id;
@@ -999,10 +974,7 @@ package body Exp_Ch9 is
-- Build_Find_Body_Index --
---------------------------
- function Build_Find_Body_Index
- (Typ : Entity_Id)
- return Node_Id
- is
+ function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Ent : Entity_Id;
E_Typ : Entity_Id;
@@ -1192,10 +1164,7 @@ package body Exp_Ch9 is
-- Build_Find_Body_Index_Spec --
--------------------------------
- function Build_Find_Body_Index_Spec
- (Typ : Entity_Id)
- return Node_Id
- is
+ function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
@@ -1285,10 +1254,9 @@ package body Exp_Ch9 is
---------------------------
function Build_Protected_Entry
- (N : Node_Id;
- Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Decls : constant List_Id := New_List;
@@ -1401,8 +1369,7 @@ package body Exp_Ch9 is
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
P : Entity_Id;
@@ -1440,8 +1407,7 @@ package body Exp_Ch9 is
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
- Ident : Entity_Id)
- return List_Id
+ Ident : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Formal : Entity_Id;
@@ -1494,8 +1460,7 @@ package body Exp_Ch9 is
function Build_Protected_Sub_Specification
(N : Node_Id;
Prottyp : Entity_Id;
- Unprotected : Boolean := False)
- return Node_Id
+ Unprotected : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
@@ -1556,8 +1521,7 @@ package body Exp_Ch9 is
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
- N_Op_Spec : Node_Id)
- return Node_Id
+ N_Op_Spec : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id;
@@ -1573,9 +1537,8 @@ package body Exp_Ch9 is
Service_Name : Node_Id;
Service_Stmt : Node_Id;
R : Node_Id;
- Return_Stmt : Node_Id := Empty;
- Pre_Stmts : List_Id := No_List;
- -- Initializations to avoid spurious warnings from GCC3.
+ Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
+ Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
Stmts : List_Id;
Object_Parm : Node_Id;
Exc_Safe : Boolean;
@@ -1906,7 +1869,6 @@ package body Exp_Ch9 is
then
Add_Shared_Var_Lock_Procs (N);
end if;
-
end Build_Protected_Subprogram_Call;
-------------------------
@@ -1915,8 +1877,7 @@ package body Exp_Ch9 is
function Build_Selected_Name
(Prefix, Selector : Name_Id;
- Append_Char : Character := ' ')
- return Name_Id
+ Append_Char : Character := ' ') return Name_Id
is
Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
Select_Len : Natural;
@@ -2336,7 +2297,6 @@ package body Exp_Ch9 is
Analyze (N);
end;
-
end Build_Simple_Entry_Call;
--------------------------------
@@ -2352,7 +2312,7 @@ package body Exp_Ch9 is
begin
-- Get the activation chain entity. Except in the case of a package
- -- body, this is in the node that was passed. For a package body, we
+ -- body, this is in the node that w as passed. For a package body, we
-- have to find the corresponding package declaration node.
if Nkind (N) = N_Package_Body then
@@ -2424,7 +2384,6 @@ package body Exp_Ch9 is
Analyze (Call);
Check_Task_Activation (N);
end if;
-
end Build_Task_Activation_Call;
-------------------------------
@@ -2492,9 +2451,63 @@ package body Exp_Ch9 is
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
-
end Build_Task_Allocate_Block;
+ -----------------------------------------------
+ -- Build_Task_Allocate_Block_With_Init_Stmts --
+ -----------------------------------------------
+
+ procedure Build_Task_Allocate_Block_With_Init_Stmts
+ (Actions : List_Id;
+ N : Node_Id;
+ Init_Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Chain : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_uChain);
+ Blkent : Entity_Id;
+ Block : Node_Id;
+
+ begin
+ Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+
+ Append_To (Init_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Chain, Loc),
+ Attribute_Name => Name_Unchecked_Access))));
+
+ Block :=
+ Make_Block_Statement (Loc,
+ Identifier => New_Reference_To (Blkent, Loc),
+ Declarations => New_List (
+
+ -- _Chain : Activation_Chain;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Chain,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Activation_Chain), Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
+
+ Has_Created_Identifier => True,
+ Is_Task_Allocation_Block => True);
+
+ Append_To (Actions,
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => Blkent,
+ Label_Construct => Block));
+
+ Append_To (Actions, Block);
+
+ Set_Activation_Chain_Entity (Block, Chain);
+ end Build_Task_Allocate_Block_With_Init_Stmts;
+
-----------------------------------
-- Build_Task_Proc_Specification --
-----------------------------------
@@ -2531,7 +2544,6 @@ package body Exp_Ch9 is
Subtype_Mark =>
New_Reference_To
(Corresponding_Record_Type (T), Loc)))));
-
end Build_Task_Proc_Specification;
---------------------------------------
@@ -2539,9 +2551,8 @@ package body Exp_Ch9 is
---------------------------------------
function Build_Unprotected_Subprogram_Body
- (N : Node_Id;
- Pid : Node_Id)
- return Node_Id
+ (N : Node_Id;
+ Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
N_Op_Spec : Node_Id;
@@ -2563,7 +2574,6 @@ package body Exp_Ch9 is
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N));
-
end Build_Unprotected_Subprogram_Body;
----------------------------
@@ -2800,9 +2810,8 @@ package body Exp_Ch9 is
------------------------
function Convert_Concurrent
- (N : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ (N : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
begin
if not Is_Concurrent_Type (Typ) then
@@ -2822,8 +2831,7 @@ package body Exp_Ch9 is
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id
+ Ttyp : Entity_Id) return Node_Id
is
Expr : Node_Id;
Num : Node_Id;
@@ -4550,7 +4558,6 @@ package body Exp_Ch9 is
Set_Privals (Dec, Next_Op, Loc);
Set_Discriminals (Dec);
end if;
-
end Expand_N_Entry_Body;
-----------------------------------
@@ -6049,7 +6056,6 @@ package body Exp_Ch9 is
Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr)));
Num_Accept := Num_Accept + 1;
-
end Add_Accept;
----------------------------
@@ -7716,8 +7722,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id
+ Ttyp : Entity_Id) return Node_Id
is
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If one of the bounds is a reference to a discriminant, replace
@@ -7790,8 +7795,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id
+ Ttyp : Entity_Id) return Node_Id
is
Ityp : Entity_Id;
@@ -7820,9 +7824,8 @@ package body Exp_Ch9 is
-----------------------------------
function Find_Task_Or_Protected_Pragma
- (T : Node_Id;
- P : Name_Id)
- return Node_Id
+ (T : Node_Id;
+ P : Name_Id) return Node_Id
is
N : Node_Id;
@@ -7898,8 +7901,7 @@ package body Exp_Ch9 is
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
- Prot : Entity_Id)
- return List_Id
+ Prot : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decls : constant List_Id := New_List;
@@ -8003,8 +8005,7 @@ package body Exp_Ch9 is
--------------------------------
function Make_Initialize_Protection
- (Protect_Rec : Entity_Id)
- return List_Id
+ (Protect_Rec : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Protect_Rec);
P_Arr : Entity_Id;
Index: exp_ch9.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.ads,v
retrieving revision 1.5
diff -u -p -r1.5 exp_ch9.ads
--- exp_ch9.ads 24 Apr 2003 17:54:00 -0000 1.5
+++ exp_ch9.ads 8 Dec 2003 10:31:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -163,6 +163,15 @@ package Exp_Ch9 is
-- for the initialization call, constructed by the caller, which uses
-- the Master_Id of the access type as the _Master parameter, and _Chain
-- (defined above) as the _Chain parameter.
+
+ procedure Build_Task_Allocate_Block_With_Init_Stmts
+ (Actions : List_Id;
+ N : Node_Id;
+ Init_Stmts : List_Id);
+ -- Ada0Y (AI-287): Similar to previous routine, but used to expand alloca-
+ -- ted aggregates with default initialized components. Init_Stmts contains
+ -- the list of statements required to initialize the allocated aggregate.
+ -- It replaces the call to Init (Args) done by Build_Task_Allocate_Block.
function Concurrent_Ref (N : Node_Id) return Node_Id;
-- Given the name of a concurrent object (task or protected object), or
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.7
diff -u -p -r1.7 gnatbind.adb
--- gnatbind.adb 21 Oct 2003 13:42:05 -0000 1.7
+++ gnatbind.adb 8 Dec 2003 10:31:51 -0000
@@ -471,7 +471,7 @@ begin
-- Add System.Standard_Library to list to ensure that these files are
-- included in the bind, even if not directly referenced from Ada code
- -- This is suppressed if the configurable run-time requests it.
+ -- This is suppressed if the appropriate targparm switch is set.
if not Suppress_Standard_Library_On_Target then
Name_Buffer (1 .. 12) := "s-stalib.ali";
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.8
diff -u -p -r1.8 lib.ads
--- lib.ads 24 Nov 2003 14:27:57 -0000 1.8
+++ lib.ads 8 Dec 2003 10:31:51 -0000
@@ -587,7 +587,7 @@ package Lib is
-- function returns True if the given generic unit entity E is for a
-- generic unit that should be separately compiled, and false otherwise.
--
- -- Now GNAT can compile any generic unit including predefifined ones, but
+ -- Now GNAT can compile any generic unit including predefined ones, but
-- because of the backward compatibility (to keep the ability to use old
-- compiler versions to build GNAT) compiling library generics is an
-- option. That is, now GNAT compiles a library generic as an ordinary
Index: par-ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch4.adb,v
retrieving revision 1.9
diff -u -p -r1.9 par-ch4.adb
--- par-ch4.adb 20 Nov 2003 09:54:00 -0000 1.9
+++ par-ch4.adb 8 Dec 2003 10:31:51 -0000
@@ -1167,6 +1167,20 @@ package body Ch4 is
end if;
end if;
+ -- Ada0Y (AI-287): The box notation is allowed only with named
+ -- notation because positional notation might be error prone. For
+ -- example, in "(X, <>, Y, <>)", there is no type associated with
+ -- the boxes, so you might not be leaving out the components you
+ -- thought you were leaving out.
+
+ if Extensions_Allowed and then Token = Tok_Box then
+ Error_Msg_SC ("(Ada 0Y) box notation only allowed with "
+ & "named notation");
+ Scan; -- past BOX
+ Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+ return Aggregate_Node;
+ end if;
+
Expr_Node := P_Expression_Or_Range_Attribute;
-- Extension aggregate case
@@ -1390,9 +1404,13 @@ package body Ch4 is
TF_Arrow;
if Token = Tok_Box then
+
+ -- Ada0Y (AI-287): The box notation is used to indicate the default
+ -- initialization of limited aggregate components
+
if not Extensions_Allowed then
Error_Msg_SP
- ("Limited aggregates are an Ada0X extension");
+ ("(Ada 0Y) limited aggregates are an Ada0X extension");
if OpenVMS then
Error_Msg_SP
Index: prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.adb,v
retrieving revision 1.13
diff -u -p -r1.13 prj.adb
--- prj.adb 20 Nov 2003 09:54:00 -0000 1.13
+++ prj.adb 8 Dec 2003 10:31:51 -0000
@@ -123,7 +123,8 @@ package body Prj is
Seen => False,
Flag1 => False,
Flag2 => False,
- Depth => 0);
+ Depth => 0,
+ Unkept_Comments => False);
-------------------
-- Add_To_Buffer --
@@ -386,15 +387,6 @@ package body Prj is
and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
and then Left.Separate_Suffix = Right.Separate_Suffix;
end Same_Naming_Scheme;
-
- ----------
- -- Scan --
- ----------
-
- procedure Scan is
- begin
- Scanner.Scan;
- end Scan;
--------------------------
-- Standard_Naming_Data --
Index: prj.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.ads,v
retrieving revision 1.15
diff -u -p -r1.15 prj.ads
--- prj.ads 20 Nov 2003 09:54:00 -0000 1.15
+++ prj.ads 8 Dec 2003 10:31:51 -0000
@@ -554,6 +554,10 @@ package Prj is
-- The maximum depth of a project in the project graph.
-- Depth of main project is 0.
+ Unkept_Comments : Boolean := False;
+ -- True if there are comments in the project sources that cannot
+ -- be kept in the project tree.
+
end record;
function Empty_Project return Project_Data;
@@ -609,10 +613,6 @@ package Prj is
-- imports B, directly or indirectly, Action will be called for A before
-- it is called for B. With_State may be used by Action to choose a
-- behavior or to report some global result.
-
- procedure Scan;
- pragma Inline (Scan);
- -- Scan a token. Change all operator symbols to literal strings.
private
Index: prj-dect.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-dect.adb,v
retrieving revision 1.8
diff -u -p -r1.8 prj-dect.adb
--- prj-dect.adb 21 Oct 2003 13:42:12 -0000 1.8
+++ prj-dect.adb 8 Dec 2003 10:31:51 -0000
@@ -125,6 +125,7 @@ package body Prj.Dect is
begin
Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
Set_Location_Of (Attribute, To => Token_Ptr);
+ Set_Previous_Line_Node (Attribute);
-- Scan past "for"
@@ -467,6 +468,9 @@ package body Prj.Dect is
if Current_Attribute = Empty_Attribute then
Attribute := Empty_Node;
end if;
+
+ Set_End_Of_Line (Attribute);
+ Set_Previous_Line_Node (Attribute);
end Parse_Attribute_Declaration;
-----------------------------
@@ -535,6 +539,9 @@ package body Prj.Dect is
Expect (Tok_Is, "IS");
if Token = Tok_Is then
+ Set_End_Of_Line (Case_Construction);
+ Set_Previous_Line_Node (Case_Construction);
+ Set_Next_End_Node (Case_Construction);
-- Scan past "is"
@@ -571,6 +578,8 @@ package body Prj.Dect is
Scan;
Expect (Tok_Arrow, "`=>`");
+ Set_End_Of_Line (Current_Item);
+ Set_Previous_Line_Node (Current_Item);
-- Empty_Node in Field1 of a Case_Item indicates
-- the "when others =>" branch.
@@ -596,6 +605,8 @@ package body Prj.Dect is
Set_First_Choice_Of (Current_Item, To => First_Choice);
Expect (Tok_Arrow, "`=>`");
+ Set_End_Of_Line (Current_Item);
+ Set_Previous_Line_Node (Current_Item);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
@@ -613,6 +624,7 @@ package body Prj.Dect is
End_Case_Construction;
Expect (Tok_End, "`END CASE`");
+ Remove_Next_End_Node;
if Token = Tok_End then
@@ -629,6 +641,7 @@ package body Prj.Dect is
Scan;
Expect (Tok_Semicolon, "`;`");
+ Set_Previous_End_Node (Case_Construction);
end Parse_Case_Construction;
@@ -673,6 +686,9 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package);
+ Set_End_Of_Line (Current_Declaration);
+ Set_Previous_Line_Node (Current_Declaration);
+
when Tok_For =>
Parse_Attribute_Declaration
@@ -681,6 +697,9 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package);
+ Set_End_Of_Line (Current_Declaration);
+ Set_Previous_Line_Node (Current_Declaration);
+
when Tok_Package =>
-- Package declaration
@@ -693,6 +712,8 @@ package body Prj.Dect is
(Package_Declaration => Current_Declaration,
Current_Project => Current_Project);
+ Set_Previous_End_Node (Current_Declaration);
+
when Tok_Type =>
-- Type String Declaration
@@ -706,6 +727,9 @@ package body Prj.Dect is
(String_Type => Current_Declaration,
Current_Project => Current_Project);
+ Set_End_Of_Line (Current_Declaration);
+ Set_Previous_Line_Node (Current_Declaration);
+
when Tok_Case =>
-- Case construction
@@ -716,6 +740,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package);
+ Set_Previous_End_Node (Current_Declaration);
+
when others =>
exit;
@@ -928,8 +954,13 @@ package body Prj.Dect is
end if;
Expect (Tok_Semicolon, "`;`");
+ Set_End_Of_Line (Package_Declaration);
+ Set_Previous_Line_Node (Package_Declaration);
elsif Token = Tok_Is then
+ Set_End_Of_Line (Package_Declaration);
+ Set_Previous_Line_Node (Package_Declaration);
+ Set_Next_End_Node (Package_Declaration);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
@@ -970,6 +1001,7 @@ package body Prj.Dect is
end if;
Expect (Tok_Semicolon, "`;`");
+ Remove_Next_End_Node;
else
Error_Msg ("expected IS or RENAMES", Token_Ptr);
Index: prj-part.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.adb,v
retrieving revision 1.9
diff -u -p -r1.9 prj-part.adb
--- prj-part.adb 10 Nov 2003 17:29:59 -0000 1.9
+++ prj-part.adb 8 Dec 2003 10:31:51 -0000
@@ -81,6 +81,7 @@ package body Prj.Part is
Path : Name_Id;
Location : Source_Ptr;
Limited_With : Boolean;
+ Node : Project_Node_Id;
Next : With_Id;
end record;
-- Information about an imported project, to be put in table Withs below
@@ -426,7 +427,8 @@ package body Prj.Part is
(Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean;
- Packages_To_Check : String_List_Access := All_Packages)
+ Packages_To_Check : String_List_Access := All_Packages;
+ Store_Comments : Boolean := False)
is
Current_Directory : constant String := Get_Current_Dir;
@@ -451,6 +453,8 @@ package body Prj.Part is
begin
Prj.Err.Initialize;
+ Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
+ Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
-- Parse the main project file
@@ -578,6 +582,8 @@ package body Prj.Part is
Current_With : With_Record;
+ Current_With_Node : Project_Node_Id := Empty_Node;
+
begin
-- Assume no context clause
@@ -588,6 +594,7 @@ package body Prj.Part is
-- or we have exhausted the with clauses.
while Token = Tok_With or else Token = Tok_Limited loop
+ Current_With_Node := Default_Project_Node (Of_Kind => N_With_Clause);
Limited_With := Token = Tok_Limited;
if Limited_With then
@@ -612,6 +619,7 @@ package body Prj.Part is
(Path => Token_Name,
Location => Token_Ptr,
Limited_With => Limited_With,
+ Node => Current_With_Node,
Next => No_With);
Withs.Increment_Last;
@@ -629,6 +637,8 @@ package body Prj.Part is
Scan;
if Token = Tok_Semicolon then
+ Set_End_Of_Line (Current_With_Node);
+ Set_Previous_Line_Node (Current_With_Node);
-- End of (possibly multiple) with clause;
@@ -639,6 +649,9 @@ package body Prj.Part is
Error_Msg ("expected comma or semi colon", Token_Ptr);
exit Comma_Loop;
end if;
+
+ Current_With_Node :=
+ Default_Project_Node (Of_Kind => N_With_Clause);
end loop Comma_Loop;
end loop With_Loop;
end Pre_Parse_Context_Clause;
@@ -714,13 +727,11 @@ package body Prj.Part is
-- First with clause of the context clause
- Current_Project := Default_Project_Node
- (Of_Kind => N_With_Clause);
+ Current_Project := Current_With.Node;
Imported_Projects := Current_Project;
else
- Next_Project := Default_Project_Node
- (Of_Kind => N_With_Clause);
+ Next_Project := Current_With.Node;
Set_Next_With_Clause_Of (Current_Project, Next_Project);
Current_Project := Next_Project;
end if;
@@ -829,6 +840,8 @@ package body Prj.Part is
use Tree_Private_Part;
+ Project_Comment_State : Tree.Comment_State;
+
begin
declare
Normed : String := Normalize_Pathname (Path_Name);
@@ -868,6 +881,8 @@ package body Prj.Part is
end if;
end loop;
+ -- Put the new path name on the stack
+
Project_Stack.Increment_Last;
Project_Stack.Table (Project_Stack.Last).Name := Canonical_Path_Name;
@@ -933,6 +948,7 @@ package body Prj.Part is
Save_Project_Scan_State (Project_Scan_State);
Source_Index := Load_Project_File (Path_Name);
+ Tree.Save (Project_Comment_State);
-- if we cannot find it, we stop
@@ -943,6 +959,7 @@ package body Prj.Part is
end if;
Prj.Err.Scanner.Initialize_Scanner (Types.No_Unit, Source_Index);
+ Tree.Reset_State;
Scan;
if Name_From_Path = No_Name then
@@ -962,6 +979,10 @@ package body Prj.Part is
Write_Eol;
end if;
+ -- Is there any imported project?
+
+ Pre_Parse_Context_Clause (First_With);
+
Project_Directory := Immediate_Directory_Of (Normed_Path_Name);
Project := Default_Project_Node (Of_Kind => N_Project);
Project_Stack.Table (Project_Stack.Last).Id := Project;
@@ -969,10 +990,6 @@ package body Prj.Part is
Set_Path_Name_Of (Project, Normed_Path_Name);
Set_Location_Of (Project, Token_Ptr);
- -- Is there any imported project?
-
- Pre_Parse_Context_Clause (First_With);
-
Expect (Tok_Project, "PROJECT");
-- Mark location of PROJECT token if present
@@ -1276,6 +1293,9 @@ package body Prj.Part is
end if;
Expect (Tok_Is, "IS");
+ Set_End_Of_Line (Project);
+ Set_Previous_Line_Node (Project);
+ Set_Next_End_Node (Project);
declare
Project_Declaration : Project_Node_Id := Empty_Node;
@@ -1296,6 +1316,7 @@ package body Prj.Part is
end;
Expect (Tok_End, "END");
+ Remove_Next_End_Node;
-- Skip "end" if present
@@ -1353,6 +1374,7 @@ package body Prj.Part is
-- source.
if Token = Tok_Semicolon then
+ Set_Previous_End_Node (Project);
Scan;
if Token /= Tok_EOF then
@@ -1368,6 +1390,15 @@ package body Prj.Part is
-- And remove the project from the project stack
Project_Stack.Decrement_Last;
+
+ -- Indicate if there are unkept comments
+
+ Tree.Set_Project_File_Includes_Unkept_Comments
+ (Node => Project, To => Tree.There_Are_Unkept_Comments);
+
+ -- And restore the comment state that was saved
+
+ Tree.Restore (Project_Comment_State);
end Parse_Single_Project;
-----------------------
Index: prj-part.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.ads,v
retrieving revision 1.5
diff -u -p -r1.5 prj-part.ads
--- prj-part.ads 21 Oct 2003 13:42:12 -0000 1.5
+++ prj-part.ads 8 Dec 2003 10:31:51 -0000
@@ -34,13 +34,15 @@ package Prj.Part is
(Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean;
- Packages_To_Check : String_List_Access := All_Packages);
+ Packages_To_Check : String_List_Access := All_Packages;
+ Store_Comments : Boolean := False);
-- Parse project file and all its imported project files and create a tree.
-- Return the node for the project (or Empty_Node if parsing failed). If
-- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,
-- Otherwise, Errout.Finalize is only called if there are errors (but not
-- if there are only warnings). Packages_To_Check indicates the packages
-- where any unknown attribute produces an error. For other packages, an
- -- unknown attribute produces a warning.
+ -- unknown attribute produces a warning. When Store_Comments is True,
+ -- comments are stored in the parse tree.
end Prj.Part;
Index: prj-pp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-pp.adb,v
retrieving revision 1.6
diff -u -p -r1.6 prj-pp.adb
--- prj-pp.adb 21 Oct 2003 13:42:12 -0000 1.6
+++ prj-pp.adb 8 Dec 2003 10:31:51 -0000
@@ -27,8 +27,8 @@
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Hostparm;
-with Namet; use Namet;
-with Output; use Output;
+with Namet; use Namet;
+with Output; use Output;
with Snames;
package body Prj.PP is
@@ -47,7 +47,6 @@ package body Prj.PP is
procedure Indicate_Tested (Kind : Project_Node_Kind);
-- Set the corresponding component of array Not_Tested to False.
-- Only called by pragmas Debug.
- --
---------------------
-- Indicate_Tested --
@@ -98,9 +97,13 @@ package body Prj.PP is
procedure Write_Line (S : String);
-- Outputs S followed by a new line
- procedure Write_String (S : String);
+ procedure Write_String (S : String; Truncated : Boolean := False);
-- Outputs S using Write_Str, starting a new line if line would
- -- become too long.
+ -- become too long, when Truncated = False.
+ -- When Truncated = True, only the part of the string that can fit on
+ -- the line is output.
+
+ procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
Write_Char : Write_Char_Ap := Output.Write_Char'Access;
Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
@@ -246,6 +249,21 @@ package body Prj.PP is
end if;
end Write_Empty_Line;
+ -------------------------------
+ -- Write_End_Of_Line_Comment --
+ -------------------------------
+
+ procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
+ Value : Name_Id := End_Of_Line_Comment (Node);
+ begin
+ if Value /= No_Name then
+ Write_String (" --");
+ Write_String (Get_Name_String (Value), Truncated => True);
+ end if;
+
+ Write_Line ("");
+ end Write_End_Of_Line_Comment;
+
----------------
-- Write_Line --
----------------
@@ -262,18 +280,24 @@ package body Prj.PP is
-- Write_String --
------------------
- procedure Write_String (S : String) is
+ procedure Write_String (S : String; Truncated : Boolean := False) is
+ Length : Natural := S'Length;
begin
-- If the string would not fit on the line,
-- start a new line.
- if Column + S'Length > Max_Line_Length then
- Write_Eol.all;
- Column := 0;
+ if Column + Length > Max_Line_Length then
+ if Truncated then
+ Length := Max_Line_Length - Column;
+
+ else
+ Write_Eol.all;
+ Column := 0;
+ end if;
end if;
- Write_Str (S);
- Column := Column + S'Length;
+ Write_Str (S (S'First .. S'First + Length - 1));
+ Column := Column + Length;
end Write_String;
-----------
@@ -296,6 +320,7 @@ package body Prj.PP is
Write_Empty_Line (Always => True);
end if;
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("project ");
Output_Name (Name_Of (Node));
@@ -307,21 +332,26 @@ package body Prj.PP is
Output_String (Extended_Project_Path_Of (Node));
end if;
- Write_Line (" is");
+ Write_String (" is");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
Write_Empty_Line (Always => True);
-- Output all of the declarations in the project
Print (Project_Declaration_Of (Node), Indent);
+ Print (First_Comment_Before_End (Node), Indent + Increment);
Start_Line (Indent);
Write_String ("end ");
Output_Name (Name_Of (Node));
Write_Line (";");
+ Print (First_Comment_After_End (Node), Indent);
when N_With_Clause =>
pragma Debug (Indicate_Tested (N_With_Clause));
if Name_Of (Node) /= No_Name then
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
if Non_Limited_Project_Node_Of (Node) = Empty_Node then
@@ -330,7 +360,9 @@ package body Prj.PP is
Write_String ("with ");
Output_String (String_Value_Of (Node));
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
end if;
Print (Next_With_Clause_Of (Node), Indent);
@@ -352,6 +384,7 @@ package body Prj.PP is
when N_Package_Declaration =>
pragma Debug (Indicate_Tested (N_Package_Declaration));
Write_Empty_Line (Always => True);
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("package ");
Output_Name (Name_Of (Node));
@@ -362,10 +395,14 @@ package body Prj.PP is
(Name_Of (Project_Of_Renamed_Package_Of (Node)));
Write_String (".");
Output_Name (Name_Of (Node));
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After_End (Node), Indent);
else
- Write_Line (" is");
+ Write_String (" is");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
if First_Declarative_Item_Of (Node) /= Empty_Node then
Print
@@ -373,15 +410,19 @@ package body Prj.PP is
Indent + Increment);
end if;
+ Print (First_Comment_Before_End (Node),
+ Indent + Increment);
Start_Line (Indent);
Write_String ("end ");
Output_Name (Name_Of (Node));
Write_Line (";");
+ Print (First_Comment_After_End (Node), Indent);
Write_Empty_Line;
end if;
when N_String_Type_Declaration =>
pragma Debug (Indicate_Tested (N_String_Type_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("type ");
Output_Name (Name_Of (Node));
@@ -404,7 +445,9 @@ package body Prj.PP is
end loop;
end;
- Write_Line (");");
+ Write_String (");");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Literal_String =>
pragma Debug (Indicate_Tested (N_Literal_String));
@@ -412,6 +455,7 @@ package body Prj.PP is
when N_Attribute_Declaration =>
pragma Debug (Indicate_Tested (N_Attribute_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("for ");
Output_Attribute_Name (Name_Of (Node));
@@ -424,26 +468,34 @@ package body Prj.PP is
Write_String (" use ");
Print (Expression_Of (Node), Indent);
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Typed_Variable_Declaration =>
pragma Debug
(Indicate_Tested (N_Typed_Variable_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Output_Name (Name_Of (Node));
Write_String (" : ");
Output_Name (Name_Of (String_Type_Of (Node)));
Write_String (" := ");
Print (Expression_Of (Node), Indent);
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Variable_Declaration =>
pragma Debug (Indicate_Tested (N_Variable_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Output_Name (Name_Of (Node));
Write_String (" := ");
Print (Expression_Of (Node), Indent);
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Expression =>
pragma Debug (Indicate_Tested (N_Expression));
@@ -566,10 +618,13 @@ package body Prj.PP is
if Is_Non_Empty then
Write_Empty_Line;
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("case ");
Print (Case_Variable_Reference_Of (Node), Indent);
- Write_Line (" is");
+ Write_String (" is");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
declare
Case_Item : Project_Node_Id :=
@@ -584,8 +639,11 @@ package body Prj.PP is
end loop;
end;
+ Print (First_Comment_Before_End (Node),
+ Indent + Increment);
Start_Line (Indent);
Write_Line ("end case;");
+ Print (First_Comment_After_End (Node), Indent);
end if;
end;
@@ -596,6 +654,7 @@ package body Prj.PP is
or else not Eliminate_Empty_Case_Constructions
then
Write_Empty_Line;
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("when ");
@@ -618,7 +677,9 @@ package body Prj.PP is
end;
end if;
- Write_Line (" =>");
+ Write_String (" =>");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
declare
First : constant Project_Node_Id :=
@@ -626,13 +687,39 @@ package body Prj.PP is
begin
if First = Empty_Node then
- Write_Eol.all;
+ Write_Empty_Line;
else
Print (First, Indent + Increment);
end if;
end;
end if;
+
+ when N_Comment_Zones =>
+
+ -- Nothing to do, because it will not be processed directly
+
+ null;
+
+ when N_Comment =>
+ pragma Debug (Indicate_Tested (N_Comment));
+
+ if Follows_Empty_Line (Node) then
+ Write_Empty_Line;
+ end if;
+
+ Start_Line (Indent);
+ Write_String ("--");
+ Write_String
+ (Get_Name_String (String_Value_Of (Node)),
+ Truncated => True);
+ Write_Line ("");
+
+ if Is_Followed_By_Empty_Line (Node) then
+ Write_Empty_Line;
+ end if;
+
+ Print (Next_Comment (Node), Indent);
end case;
end if;
end Print;
@@ -674,7 +761,7 @@ package body Prj.PP is
Output.Write_Line ("Project_Node_Kinds not tested:");
for Kind in Project_Node_Kind loop
- if Not_Tested (Kind) then
+ if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
Output.Write_Str (" ");
Output.Write_Line (Project_Node_Kind'Image (Kind));
end if;
Index: prj-tree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.adb,v
retrieving revision 1.8
diff -u -p -r1.8 prj-tree.adb
--- prj-tree.adb 10 Nov 2003 17:29:59 -0000 1.8
+++ prj-tree.adb 8 Dec 2003 10:31:51 -0000
@@ -24,17 +24,193 @@
-- --
------------------------------------------------------------------------------
+with Prj.Err;
+
package body Prj.Tree is
+ Node_With_Comments : constant array (Project_Node_Kind) of Boolean :=
+ (N_Project => True,
+ N_With_Clause => True,
+ N_Project_Declaration => False,
+ N_Declarative_Item => False,
+ N_Package_Declaration => True,
+ N_String_Type_Declaration => True,
+ N_Literal_String => False,
+ N_Attribute_Declaration => True,
+ N_Typed_Variable_Declaration => True,
+ N_Variable_Declaration => True,
+ N_Expression => False,
+ N_Term => False,
+ N_Literal_String_List => False,
+ N_Variable_Reference => False,
+ N_External_Value => False,
+ N_Attribute_Reference => False,
+ N_Case_Construction => True,
+ N_Case_Item => True,
+ N_Comment_Zones => True,
+ N_Comment => True);
+ -- Indicates the kinds of node that may have associated comments
+
+ package Next_End_Nodes is new Table.Table
+ (Table_Component_Type => Project_Node_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Next_End_Nodes");
+ -- A stack of nodes to indicates to what node the next "end" is associated
+
use Tree_Private_Part;
+ End_Of_Line_Node : Project_Node_Id := Empty_Node;
+ -- The node an end of line comment may be associated with
+
+ Previous_Line_Node : Project_Node_Id := Empty_Node;
+ -- The node an immediately following comment may be associated with
+
+ Previous_End_Node : Project_Node_Id := Empty_Node;
+ -- The node comments immediately following an "end" line may be
+ -- associated with.
+
+ Unkept_Comments : Boolean := False;
+ -- Set to True when some comments may not be associated with any node
+
+ function Comment_Zones_Of
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Returns the ID of the N_Comment_Zones node associated with node Node.
+ -- If there is not already an N_Comment_Zones node, create one and
+ -- associate it with node Node.
+
+ ------------------
+ -- Add_Comments --
+ ------------------
+
+ procedure Add_Comments (To : Project_Node_Id; Where : Comment_Location) is
+ Zone : Project_Node_Id := Empty_Node;
+ Previous : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert
+ (To /= Empty_Node
+ and then
+ Project_Nodes.Table (To).Kind /= N_Comment);
+
+ Zone := Project_Nodes.Table (To).Comments;
+
+ if Zone = Empty_Node then
+
+ -- Create new N_Comment_Zones node
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment_Zones,
+ Expr_Kind => Undefined,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+
+ Zone := Project_Nodes.Last;
+ Project_Nodes.Table (To).Comments := Zone;
+ end if;
+
+ if Where = End_Of_Line then
+ Project_Nodes.Table (Zone).Value := Comments.Table (1).Value;
+
+ else
+ -- Get each comments in the Comments table and link them to node To
+
+ for J in 1 .. Comments.Last loop
+
+ -- Create new N_Comment node
+
+ if (Where = After or else Where = After_End) and then
+ Token /= Tok_EOF and then
+ Comments.Table (J).Follows_Empty_Line
+ then
+ Comments.Table (1 .. Comments.Last - J + 1) :=
+ Comments.Table (J .. Comments.Last);
+ Comments.Set_Last (Comments.Last - J + 1);
+ return;
+ end if;
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment,
+ Expr_Kind => Undefined,
+ Flag1 => Comments.Table (J).Follows_Empty_Line,
+ Flag2 =>
+ Comments.Table (J).Is_Followed_By_Empty_Line,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => Comments.Table (J).Value,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Comments => Empty_Node);
+
+ -- If this is the first comment, put it in the right field of
+ -- the node Zone.
+
+ if Previous = Empty_Node then
+ case Where is
+ when Before =>
+ Project_Nodes.Table (Zone).Field1 := Project_Nodes.Last;
+
+ when After =>
+ Project_Nodes.Table (Zone).Field2 := Project_Nodes.Last;
+
+ when Before_End =>
+ Project_Nodes.Table (Zone).Field3 := Project_Nodes.Last;
+
+ when After_End =>
+ Project_Nodes.Table (Zone).Comments := Project_Nodes.Last;
+
+ when End_Of_Line =>
+ null;
+ end case;
+
+ else
+ -- When it is not the first, link it to the previous one
+
+ Project_Nodes.Table (Previous).Comments := Project_Nodes.Last;
+ end if;
+
+ -- This node becomes the previous one for the next comment, if
+ -- there is one.
+
+ Previous := Project_Nodes.Last;
+ end loop;
+ end if;
+
+ -- Empty the Comments table, so that there is no risk to link the same
+ -- comments to another node.
+
+ Comments.Set_Last (0);
+ end Add_Comments;
+
+
--------------------------------
-- Associative_Array_Index_Of --
--------------------------------
function Associative_Array_Index_Of
- (Node : Project_Node_Id)
- return Name_Id
+ (Node : Project_Node_Id) return Name_Id
is
begin
pragma Assert
@@ -51,8 +227,7 @@ package body Prj.Tree is
----------------------------
function Associative_Package_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -67,8 +242,7 @@ package body Prj.Tree is
----------------------------
function Associative_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -90,7 +264,7 @@ package body Prj.Tree is
(Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- return Project_Nodes.Table (Node).Case_Insensitive;
+ return Project_Nodes.Table (Node).Flag1;
end Case_Insensitive;
--------------------------------
@@ -98,8 +272,7 @@ package body Prj.Tree is
--------------------------------
function Case_Variable_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -109,13 +282,54 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end Case_Variable_Reference_Of;
+ ----------------------
+ -- Comment_Zones_Of --
+ ----------------------
+
+ function Comment_Zones_Of
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ -- If there is not already an N_Comment_Zones associated, create a new
+ -- one and associate it with node Node.
+
+ if Zone = Empty_Node then
+ Project_Nodes.Increment_Last;
+ Zone := Project_Nodes.Last;
+ Project_Nodes.Table (Zone) :=
+ (Kind => N_Comment_Zones,
+ Location => No_Location,
+ Directory => No_Name,
+ Expr_Kind => Undefined,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+ Project_Nodes.Table (Node).Comments := Zone;
+ end if;
+
+ return Zone;
+ end Comment_Zones_Of;
+
-----------------------
-- Current_Item_Node --
-----------------------
function Current_Item_Node
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -130,8 +344,7 @@ package body Prj.Tree is
------------------
function Current_Term
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -147,28 +360,118 @@ package body Prj.Tree is
function Default_Project_Node
(Of_Kind : Project_Node_Kind;
- And_Expr_Kind : Variable_Kind := Undefined)
- return Project_Node_Id
+ And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id
is
+ Result : Project_Node_Id;
+ Zone : Project_Node_Id;
+ Previous : Project_Node_Id;
+
begin
+ -- Create new node with specified kind and expression kind
+
Project_Nodes.Increment_Last;
Project_Nodes.Table (Project_Nodes.Last) :=
- (Kind => Of_Kind,
- Location => No_Location,
- Directory => No_Name,
- Expr_Kind => And_Expr_Kind,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Path_Name => No_Name,
- Value => No_Name,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Case_Insensitive => False,
- Extending_All => False);
- return Project_Nodes.Last;
+ (Kind => Of_Kind,
+ Location => No_Location,
+ Directory => No_Name,
+ Expr_Kind => And_Expr_Kind,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+
+ -- Save the new node for the returned value
+
+ Result := Project_Nodes.Last;
+
+ if Comments.Last > 0 then
+
+ -- If this is not a node with comments, then set the flag
+
+ if not Node_With_Comments (Of_Kind) then
+ Unkept_Comments := True;
+
+ elsif Of_Kind /= N_Comment and then Of_Kind /= N_Comment_Zones then
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment_Zones,
+ Expr_Kind => Undefined,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+
+ Zone := Project_Nodes.Last;
+ Project_Nodes.Table (Result).Comments := Zone;
+ Previous := Empty_Node;
+
+ for J in 1 .. Comments.Last loop
+
+ -- Create a new N_Comment node
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment,
+ Expr_Kind => Undefined,
+ Flag1 => Comments.Table (J).Follows_Empty_Line,
+ Flag2 =>
+ Comments.Table (J).Is_Followed_By_Empty_Line,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => Comments.Table (J).Value,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Comments => Empty_Node);
+
+ -- Link it to the N_Comment_Zones node, if it is the first,
+ -- otherwise to the previous one.
+
+ if Previous = Empty_Node then
+ Project_Nodes.Table (Zone).Field1 := Project_Nodes.Last;
+
+ else
+ Project_Nodes.Table (Previous).Comments :=
+ Project_Nodes.Last;
+ end if;
+
+ -- This new node will be the previous one for the next
+ -- N_Comment node, if there is one.
+
+ Previous := Project_Nodes.Last;
+ end loop;
+
+ -- Empty the Comments table after all comments have been processed
+
+ Comments.Set_Last (0);
+ end if;
+ end if;
+
+ return Result;
end Default_Project_Node;
------------------
@@ -184,6 +487,24 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Directory;
end Directory_Of;
+ -------------------------
+ -- End_Of_Line_Comment --
+ -------------------------
+
+ function End_Of_Line_Comment (Node : Project_Node_Id) return Name_Id is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return No_Name;
+ else
+ return Project_Nodes.Table (Zone).Value;
+ end if;
+ end End_Of_Line_Comment;
+
------------------------
-- Expression_Kind_Of --
------------------------
@@ -219,8 +540,7 @@ package body Prj.Tree is
-------------------
function Expression_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -240,8 +560,7 @@ package body Prj.Tree is
-------------------------
function Extended_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -256,8 +575,7 @@ package body Prj.Tree is
------------------------------
function Extended_Project_Path_Of
- (Node : Project_Node_Id)
- return Name_Id
+ (Node : Project_Node_Id) return Name_Id
is
begin
pragma Assert
@@ -271,8 +589,7 @@ package body Prj.Tree is
-- Extending_Project_Of --
--------------------------
function Extending_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -287,8 +604,7 @@ package body Prj.Tree is
---------------------------
function External_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -319,8 +635,7 @@ package body Prj.Tree is
------------------------
function First_Case_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -346,13 +661,96 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end First_Choice_Of;
+ -------------------------
+ -- First_Comment_After --
+ -------------------------
+
+ function First_Comment_After
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Field2;
+ end if;
+ end First_Comment_After;
+
+ -----------------------------
+ -- First_Comment_After_End --
+ -----------------------------
+
+ function First_Comment_After_End
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Comments;
+ end if;
+ end First_Comment_After_End;
+
+ --------------------------
+ -- First_Comment_Before --
+ --------------------------
+
+ function First_Comment_Before
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Field1;
+ end if;
+ end First_Comment_Before;
+
+ ------------------------------
+ -- First_Comment_Before_End --
+ ------------------------------
+
+ function First_Comment_Before_End
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Field3;
+ end if;
+ end First_Comment_Before_End;
+
-------------------------------
-- First_Declarative_Item_Of --
-------------------------------
function First_Declarative_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -376,8 +774,7 @@ package body Prj.Tree is
------------------------------
function First_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -392,8 +789,7 @@ package body Prj.Tree is
--------------------------
function First_Literal_String
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -408,8 +804,7 @@ package body Prj.Tree is
----------------------
function First_Package_Of
- (Node : Project_Node_Id)
- return Package_Declaration_Id
+ (Node : Project_Node_Id) return Package_Declaration_Id
is
begin
pragma Assert
@@ -424,8 +819,7 @@ package body Prj.Tree is
--------------------------
function First_String_Type_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -440,8 +834,7 @@ package body Prj.Tree is
----------------
function First_Term
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -456,8 +849,7 @@ package body Prj.Tree is
-----------------------
function First_Variable_Of
- (Node : Project_Node_Id)
- return Variable_Node_Id
+ (Node : Project_Node_Id) return Variable_Node_Id
is
begin
pragma Assert
@@ -475,8 +867,7 @@ package body Prj.Tree is
--------------------------
function First_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -486,18 +877,18 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end First_With_Clause_Of;
- ----------------------
- -- Is_Extending_All --
- ----------------------
+ ------------------------
+ -- Follows_Empty_Line --
+ ------------------------
- function Is_Extending_All (Node : Project_Node_Id) return Boolean is
+ function Follows_Empty_Line (Node : Project_Node_Id) return Boolean is
begin
pragma Assert
(Node /= Empty_Node
- and then
- Project_Nodes.Table (Node).Kind = N_Project);
- return Project_Nodes.Table (Node).Extending_All;
- end Is_Extending_All;
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ return Project_Nodes.Table (Node).Flag1;
+ end Follows_Empty_Line;
----------
-- Hash --
@@ -508,14 +899,51 @@ package body Prj.Tree is
return Header_Num (N mod Project_Node_Id (Header_Num'Last));
end Hash;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Project_Nodes.Set_Last (Empty_Node);
+ Projects_Htable.Reset;
+ end Initialize;
+
+ -------------------------------
+ -- Is_Followed_By_Empty_Line --
+ -------------------------------
+
+ function Is_Followed_By_Empty_Line
+ (Node : Project_Node_Id) return Boolean
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ return Project_Nodes.Table (Node).Flag2;
+ end Is_Followed_By_Empty_Line;
+
+ ----------------------
+ -- Is_Extending_All --
+ ----------------------
+
+ function Is_Extending_All (Node : Project_Node_Id) return Boolean is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ return Project_Nodes.Table (Node).Flag2;
+ end Is_Extending_All;
+
-------------------------------------
-- Imported_Or_Extended_Project_Of --
-------------------------------------
function Imported_Or_Extended_Project_Of
(Project : Project_Node_Id;
- With_Name : Name_Id)
- return Project_Node_Id
+ With_Name : Name_Id) return Project_Node_Id
is
With_Clause : Project_Node_Id := First_With_Clause_Of (Project);
Result : Project_Node_Id := Empty_Node;
@@ -548,16 +976,6 @@ package body Prj.Tree is
return Result;
end Imported_Or_Extended_Project_Of;
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Project_Nodes.Set_Last (Empty_Node);
- Projects_Htable.Reset;
- end Initialize;
-
-------------
-- Kind_Of --
-------------
@@ -593,8 +1011,7 @@ package body Prj.Tree is
--------------------
function Next_Case_Item
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -604,13 +1021,25 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field3;
end Next_Case_Item;
+ ------------------
+ -- Next_Comment --
+ ------------------
+
+ function Next_Comment (Node : Project_Node_Id) return Project_Node_Id is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ return Project_Nodes.Table (Node).Comments;
+ end Next_Comment;
+
---------------------------
-- Next_Declarative_Item --
---------------------------
function Next_Declarative_Item
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -625,8 +1054,7 @@ package body Prj.Tree is
-----------------------------
function Next_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -657,8 +1085,7 @@ package body Prj.Tree is
-----------------------------
function Next_Package_In_Project
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -689,8 +1116,7 @@ package body Prj.Tree is
---------------
function Next_Term
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -724,8 +1150,7 @@ package body Prj.Tree is
-------------------------
function Next_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -740,8 +1165,7 @@ package body Prj.Tree is
---------------------------------
function Non_Limited_Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -750,6 +1174,7 @@ package body Prj.Tree is
(Project_Nodes.Table (Node).Kind = N_With_Clause));
return Project_Nodes.Table (Node).Field3;
end Non_Limited_Project_Node_Of;
+
-------------------
-- Package_Id_Of --
-------------------
@@ -768,8 +1193,7 @@ package body Prj.Tree is
---------------------
function Package_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -801,8 +1225,7 @@ package body Prj.Tree is
----------------------------
function Project_Declaration_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -812,13 +1235,25 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field2;
end Project_Declaration_Of;
+ -------------------------------------------
+ -- Project_File_Includes_Unkept_Comments --
+ -------------------------------------------
+
+ function Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id) return Boolean
+ is
+ Declaration : constant Project_Node_Id :=
+ Project_Declaration_Of (Node);
+ begin
+ return Project_Nodes.Table (Declaration).Flag1;
+ end Project_File_Includes_Unkept_Comments;
+
---------------------
-- Project_Node_Of --
---------------------
function Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -837,8 +1272,7 @@ package body Prj.Tree is
-----------------------------------
function Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -848,6 +1282,181 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end Project_Of_Renamed_Package_Of;
+ --------------------------
+ -- Remove_Next_End_Node --
+ --------------------------
+
+ procedure Remove_Next_End_Node is
+ begin
+ Next_End_Nodes.Decrement_Last;
+ end Remove_Next_End_Node;
+
+ -----------------
+ -- Reset_State --
+ -----------------
+
+ procedure Reset_State is
+ begin
+ End_Of_Line_Node := Empty_Node;
+ Previous_Line_Node := Empty_Node;
+ Previous_End_Node := Empty_Node;
+ Unkept_Comments := False;
+ Comments.Set_Last (0);
+ end Reset_State;
+
+ -------------
+ -- Restore --
+ -------------
+
+ procedure Restore (S : in Comment_State) is
+ begin
+ End_Of_Line_Node := S.End_Of_Line_Node;
+ Previous_Line_Node := S.Previous_Line_Node;
+ Previous_End_Node := S.Previous_End_Node;
+ Next_End_Nodes.Set_Last (0);
+ Unkept_Comments := S.Unkept_Comments;
+
+ Comments.Set_Last (0);
+
+ for J in S.Comments'Range loop
+ Comments.Increment_Last;
+ Comments.Table (Comments.Last) := S.Comments (J);
+ end loop;
+ end Restore;
+
+ ----------
+ -- Save --
+ ----------
+
+ procedure Save (S : out Comment_State) is
+ Cmts : Comments_Ptr := new Comment_Array (1 .. Comments.Last);
+ begin
+ for J in 1 .. Comments.Last loop
+ Cmts (J) := Comments.Table (J);
+ end loop;
+
+ S :=
+ (End_Of_Line_Node => End_Of_Line_Node,
+ Previous_Line_Node => Previous_Line_Node,
+ Previous_End_Node => Previous_End_Node,
+ Unkept_Comments => Unkept_Comments,
+ Comments => Cmts);
+ end Save;
+
+ ----------
+ -- Scan --
+ ----------
+
+ procedure Scan is
+ Empty_Line : Boolean := False;
+ begin
+ -- If there are comments, then they will not be kept. Set the flag and
+ -- clear the comments.
+
+ if Comments.Last > 0 then
+ Unkept_Comments := True;
+ Comments.Set_Last (0);
+ end if;
+
+ -- Loop until a token other that End_Of_Line or Comment is found
+
+ loop
+ Prj.Err.Scanner.Scan;
+
+ case Token is
+ when Tok_End_Of_Line =>
+ if Prev_Token = Tok_End_Of_Line then
+ Empty_Line := True;
+
+ if Comments.Last > 0 then
+ Comments.Table (Comments.Last).Is_Followed_By_Empty_Line
+ := True;
+ end if;
+ end if;
+
+ when Tok_Comment =>
+ -- If this is a line comment, add it to the comment table
+
+ if Prev_Token = Tok_End_Of_Line
+ or else Prev_Token = No_Token
+ then
+ Comments.Increment_Last;
+ Comments.Table (Comments.Last) :=
+ (Value => Comment_Id,
+ Follows_Empty_Line => Empty_Line,
+ Is_Followed_By_Empty_Line => False);
+
+ -- Otherwise, it is an end of line comment. If there is
+ -- an end of line node specified, associate the comment with
+ -- this node.
+
+ elsif End_Of_Line_Node /= Empty_Node then
+ declare
+ Zones : constant Project_Node_Id :=
+ Comment_Zones_Of (End_Of_Line_Node);
+ begin
+ Project_Nodes.Table (Zones).Value := Comment_Id;
+ end;
+
+ -- Otherwise, this end of line node cannot be kept
+
+ else
+ Unkept_Comments := True;
+ Comments.Set_Last (0);
+ end if;
+
+ Empty_Line := False;
+
+ when others =>
+ -- If there are comments, where the first comment is not
+ -- following an empty line, put the initial uninterrupted
+ -- comment zone with the node of the preceding line (either
+ -- a Previous_Line or a Previous_End node), if any.
+
+ if Comments.Last > 0 and then
+ not Comments.Table (1).Follows_Empty_Line then
+ if Previous_Line_Node /= Empty_Node then
+ Add_Comments
+ (To => Previous_Line_Node, Where => After);
+
+ elsif Previous_End_Node /= Empty_Node then
+ Add_Comments
+ (To => Previous_End_Node, Where => After_End);
+ end if;
+ end if;
+
+ -- If there are still comments and the token is "end", then
+ -- put these comments with the Next_End node, if any;
+ -- otherwise, these comments cannot be kept. Always clear
+ -- the comments.
+
+ if Comments.Last > 0 and then Token = Tok_End then
+ if Next_End_Nodes.Last > 0 then
+ Add_Comments
+ (To => Next_End_Nodes.Table (Next_End_Nodes.Last),
+ Where => Before_End);
+
+ else
+ Unkept_Comments := True;
+ end if;
+
+ Comments.Set_Last (0);
+ end if;
+
+ -- Reset the End_Of_Line, Previous_Line and Previous_End nodes
+ -- so that they are not used again.
+
+ End_Of_Line_Node := Empty_Node;
+ Previous_Line_Node := Empty_Node;
+ Previous_End_Node := Empty_Node;
+
+ -- And return
+
+ exit;
+ end case;
+ end loop;
+ end Scan;
+
------------------------------------
-- Set_Associative_Array_Index_Of --
------------------------------------
@@ -913,7 +1522,7 @@ package body Prj.Tree is
(Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- Project_Nodes.Table (Node).Case_Insensitive := To;
+ Project_Nodes.Table (Node).Flag1 := To;
end Set_Case_Insensitive;
------------------------------------
@@ -980,6 +1589,15 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Directory := To;
end Set_Directory_Of;
+ ---------------------
+ -- Set_End_Of_Line --
+ ---------------------
+
+ procedure Set_End_Of_Line (To : Project_Node_Id) is
+ begin
+ End_Of_Line_Node := To;
+ end Set_End_Of_Line;
+
----------------------------
-- Set_Expression_Kind_Of --
----------------------------
@@ -1096,6 +1714,63 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field1 := To;
end Set_First_Choice_Of;
+ -----------------------------
+ -- Set_First_Comment_After --
+ -----------------------------
+
+ procedure Set_First_Comment_After
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Field2 := To;
+ end Set_First_Comment_After;
+
+ ---------------------------------
+ -- Set_First_Comment_After_End --
+ ---------------------------------
+
+ procedure Set_First_Comment_After_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Comments := To;
+ end Set_First_Comment_After_End;
+
+ ------------------------------
+ -- Set_First_Comment_Before --
+ ------------------------------
+
+ procedure Set_First_Comment_Before
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Field1 := To;
+ end Set_First_Comment_Before;
+
+ ----------------------------------
+ -- Set_First_Comment_Before_End --
+ ----------------------------------
+
+ procedure Set_First_Comment_Before_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Field2 := To;
+ end Set_First_Comment_Before_End;
+
------------------------
-- Set_Next_Case_Item --
------------------------
@@ -1112,6 +1787,22 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field3 := To;
end Set_Next_Case_Item;
+ ----------------------
+ -- Set_Next_Comment --
+ ----------------------
+
+ procedure Set_Next_Comment
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ Project_Nodes.Table (Node).Comments := To;
+ end Set_Next_Comment;
+
-----------------------------------
-- Set_First_Declarative_Item_Of --
-----------------------------------
@@ -1261,7 +1952,7 @@ package body Prj.Tree is
(Node /= Empty_Node
and then
Project_Nodes.Table (Node).Kind = N_Project);
- Project_Nodes.Table (Node).Extending_All := True;
+ Project_Nodes.Table (Node).Flag2 := True;
end Set_Is_Extending_All;
-----------------
@@ -1367,6 +2058,16 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field2 := To;
end Set_Next_Declarative_Item;
+ -----------------------
+ -- Set_Next_End_Node --
+ -----------------------
+
+ procedure Set_Next_End_Node (To : Project_Node_Id) is
+ begin
+ Next_End_Nodes.Increment_Last;
+ Next_End_Nodes.Table (Next_End_Nodes.Last) := To;
+ end Set_Next_End_Node;
+
---------------------------------
-- Set_Next_Expression_In_List --
---------------------------------
@@ -1533,6 +2234,23 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Path_Name := To;
end Set_Path_Name_Of;
+ ---------------------------
+ -- Set_Previous_End_Node --
+ ---------------------------
+ procedure Set_Previous_End_Node (To : Project_Node_Id) is
+ begin
+ Previous_End_Node := To;
+ end Set_Previous_End_Node;
+
+ ----------------------------
+ -- Set_Previous_Line_Node --
+ ----------------------------
+
+ procedure Set_Previous_Line_Node (To : Project_Node_Id) is
+ begin
+ Previous_Line_Node := To;
+ end Set_Previous_Line_Node;
+
--------------------------------
-- Set_Project_Declaration_Of --
--------------------------------
@@ -1549,6 +2267,20 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field2 := To;
end Set_Project_Declaration_Of;
+ -----------------------------------------------
+ -- Set_Project_File_Includes_Unkept_Comments --
+ -----------------------------------------------
+
+ procedure Set_Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id;
+ To : Boolean)
+ is
+ Declaration : constant Project_Node_Id :=
+ Project_Declaration_Of (Node);
+ begin
+ Project_Nodes.Table (Declaration).Flag1 := To;
+ end Set_Project_File_Includes_Unkept_Comments;
+
-------------------------
-- Set_Project_Node_Of --
-------------------------
@@ -1631,6 +2363,8 @@ package body Prj.Tree is
and then
(Project_Nodes.Table (Node).Kind = N_With_Clause
or else
+ Project_Nodes.Table (Node).Kind = N_Comment
+ or else
Project_Nodes.Table (Node).Kind = N_Literal_String));
Project_Nodes.Table (Node).Value := To;
end Set_String_Value_Of;
@@ -1639,8 +2373,9 @@ package body Prj.Tree is
-- String_Type_Of --
--------------------
- function String_Type_Of (Node : Project_Node_Id)
- return Project_Node_Id is
+ function String_Type_Of
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
begin
pragma Assert
(Node /= Empty_Node
@@ -1667,6 +2402,8 @@ package body Prj.Tree is
and then
(Project_Nodes.Table (Node).Kind = N_With_Clause
or else
+ Project_Nodes.Table (Node).Kind = N_Comment
+ or else
Project_Nodes.Table (Node).Kind = N_Literal_String));
return Project_Nodes.Table (Node).Value;
end String_Value_Of;
@@ -1677,8 +2414,7 @@ package body Prj.Tree is
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
- Value : Name_Id)
- return Boolean
+ Value : Name_Id) return Boolean
is
begin
pragma Assert
@@ -1705,5 +2441,15 @@ package body Prj.Tree is
end;
end Value_Is_Valid;
+
+ -------------------------------
+ -- There_Are_Unkept_Comments --
+ -------------------------------
+
+ function There_Are_Unkept_Comments return Boolean is
+ begin
+ return Unkept_Comments;
+ end There_Are_Unkept_Comments;
+
end Prj.Tree;
Index: prj-tree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.ads,v
retrieving revision 1.10
diff -u -p -r1.10 prj-tree.ads
--- prj-tree.ads 10 Nov 2003 17:29:59 -0000 1.10
+++ prj-tree.ads 8 Dec 2003 10:31:51 -0000
@@ -30,8 +30,8 @@ with GNAT.HTable;
with Prj.Attr; use Prj.Attr;
with Prj.Com; use Prj.Com;
+with Table; use Table;
with Types; use Types;
-with Table;
package Prj.Tree is
@@ -79,7 +79,9 @@ package Prj.Tree is
N_External_Value,
N_Attribute_Reference,
N_Case_Construction,
- N_Case_Item);
+ N_Case_Item,
+ N_Comment_Zones,
+ N_Comment);
-- Each node in the tree is of a Project_Node_Kind
-- For the signification of the fields in each node of a
-- Project_Node_Kind, look at package Tree_Private_Part.
@@ -90,8 +92,7 @@ package Prj.Tree is
function Default_Project_Node
(Of_Kind : Project_Node_Kind;
- And_Expr_Kind : Variable_Kind := Undefined)
- return Project_Node_Id;
+ And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id;
-- Returns a Project_Node_Record with the specified Kind and
-- Expr_Kind; all the other components have default nil values.
@@ -100,11 +101,85 @@ package Prj.Tree is
function Imported_Or_Extended_Project_Of
(Project : Project_Node_Id;
- With_Name : Name_Id)
- return Project_Node_Id;
+ With_Name : Name_Id) return Project_Node_Id;
-- Return the node of a project imported or extended by project Project and
-- whose name is With_Name. Return Empty_Node if there is no such project.
+ --------------
+ -- Comments --
+ --------------
+
+ type Comment_State is private;
+ -- A type to store the values of several global variables related to
+ -- comments.
+
+ procedure Save (S : out Comment_State);
+ -- Save in variable S the comment state. Called before scanning a new
+ -- project file.
+
+ procedure Restore (S : in Comment_State);
+ -- Restore the comment state to a previously saved value. Called after
+ -- scanning a project file.
+
+ procedure Reset_State;
+ -- Set the comment state to its initial value. Called before scanning a
+ -- new project file.
+
+ function There_Are_Unkept_Comments return Boolean;
+ -- Indicates that some of the comments in a project file could not be
+ -- stored in the parse tree.
+
+ procedure Set_Previous_Line_Node (To : Project_Node_Id);
+ -- Indicate the node on the previous line. If there are comments
+ -- immediately following this line, then they should be associated with
+ -- this node.
+
+ procedure Set_Previous_End_Node (To : Project_Node_Id);
+ -- Indicate that on the previous line the "end" belongs to node To.
+ -- If there are comments immediately following this "end" line, they
+ -- should be associated with this node.
+
+ procedure Set_End_Of_Line (To : Project_Node_Id);
+ -- Indicate the node on the current line. If there is an end of line
+ -- comment, then it should be associated with this node.
+
+ procedure Set_Next_End_Node (To : Project_Node_Id);
+ -- Put node To on the top of the end node stack. When an "end" line
+ -- is found with this node on the top of the end node stack, the comments,
+ -- if any, immediately preceding this "end" line will be associated with
+ -- this node.
+
+ procedure Remove_Next_End_Node;
+ -- Remove the top of the end node stack.
+
+ ------------------------
+ -- Comment Processing --
+ ------------------------
+
+ type Comment_Data is record
+ Value : Name_Id := No_Name;
+ Follows_Empty_Line : Boolean := False;
+ Is_Followed_By_Empty_Line : Boolean := False;
+ end record;
+
+ package Comments is new Table.Table
+ (Table_Component_Type => Comment_Data,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Prj.Tree.Comments");
+ -- A table to store the comments that may be stored is the tree
+
+ procedure Scan;
+ -- Scan the tokens and accumulate comments.
+
+ type Comment_Location is
+ (Before, After, Before_End, After_End, End_Of_Line);
+
+ procedure Add_Comments (To : Project_Node_Id; Where : Comment_Location);
+ -- Add comments to this node.
+
----------------------
-- Access Functions --
----------------------
@@ -125,6 +200,39 @@ package Prj.Tree is
pragma Inline (Location_Of);
-- Valid for all non empty nodes
+ function First_Comment_After
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function First_Comment_After_End
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function First_Comment_Before
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function First_Comment_Before_End
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function Next_Comment (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment nodes
+
+ function End_Of_Line_Comment (Node : Project_Node_Id) return Name_Id;
+ -- Valid only for non empty nodes
+
+ function Follows_Empty_Line (Node : Project_Node_Id) return Boolean;
+ -- Valid only for N_Comment nodes
+
+ function Is_Followed_By_Empty_Line (Node : Project_Node_Id) return Boolean;
+ -- Valid only for N_Comment nodes
+
+ function Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id)
+ return Boolean;
+ -- Valid only for N_Project nodes
+
function Directory_Of (Node : Project_Node_Id) return Name_Id;
pragma Inline (Directory_Of);
-- Only valid for N_Project nodes.
@@ -140,14 +248,12 @@ package Prj.Tree is
-- Only valid for N_Project
function First_Variable_Of
- (Node : Project_Node_Id)
- return Variable_Node_Id;
+ (Node : Project_Node_Id) return Variable_Node_Id;
pragma Inline (First_Variable_Of);
-- Only valid for N_Project or N_Package_Declaration nodes
function First_Package_Of
- (Node : Project_Node_Id)
- return Package_Declaration_Id;
+ (Node : Project_Node_Id) return Package_Declaration_Id;
pragma Inline (First_Package_Of);
-- Only valid for N_Project nodes
@@ -155,123 +261,105 @@ package Prj.Tree is
pragma Inline (Package_Id_Of);
-- Only valid for N_Package_Declaration nodes
- function Path_Name_Of (Node : Project_Node_Id) return Name_Id;
+ function Path_Name_Of (Node : Project_Node_Id) return Name_Id;
pragma Inline (Path_Name_Of);
-- Only valid for N_Project and N_With_Clause nodes.
- function String_Value_Of (Node : Project_Node_Id) return Name_Id;
+ function String_Value_Of (Node : Project_Node_Id) return Name_Id;
pragma Inline (String_Value_Of);
- -- Only valid for N_With_Clause or N_Literal_String nodes.
+ -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment
function First_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_With_Clause_Of);
-- Only valid for N_Project nodes
function Project_Declaration_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Project_Declaration_Of);
-- Only valid for N_Project nodes
function Extending_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Extending_Project_Of);
-- Only valid for N_Project_Declaration nodes
function First_String_Type_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_String_Type_Of);
-- Only valid for N_Project nodes
function Extended_Project_Path_Of
- (Node : Project_Node_Id)
- return Name_Id;
+ (Node : Project_Node_Id) return Name_Id;
pragma Inline (Extended_Project_Path_Of);
-- Only valid for N_With_Clause nodes
function Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Project_Node_Of);
-- Only valid for N_With_Clause, N_Variable_Reference and
-- N_Attribute_Reference nodes.
function Non_Limited_Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Non_Limited_Project_Node_Of);
-- Only valid for N_With_Clause nodes. Returns Empty_Node for limited
-- imported project files, otherwise returns the same result as
-- Project_Node_Of.
function Next_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_With_Clause_Of);
-- Only valid for N_With_Clause nodes
function First_Declarative_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Declarative_Item_Of);
-- Only valid for N_With_Clause nodes
function Extended_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Extended_Project_Of);
-- Only valid for N_Project_Declaration nodes
function Current_Item_Node
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Current_Item_Node);
-- Only valid for N_Declarative_Item nodes
function Next_Declarative_Item
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Declarative_Item);
-- Only valid for N_Declarative_Item node
function Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Project_Of_Renamed_Package_Of);
-- Only valid for N_Package_Declaration nodes.
-- May return Empty_Node.
function Next_Package_In_Project
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Package_In_Project);
-- Only valid for N_Package_Declaration nodes
function First_Literal_String
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Literal_String);
-- Only valid for N_String_Type_Declaration nodes
function Next_String_Type
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_String_Type);
-- Only valid for N_String_Type_Declaration nodes
function Next_Literal_String
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Literal_String);
-- Only valid for N_Literal_String nodes
function Expression_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Expression_Of);
-- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
-- or N_Variable_Declaration nodes
@@ -290,104 +378,88 @@ package Prj.Tree is
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
- Value : Name_Id)
- return Boolean;
+ Value : Name_Id) return Boolean;
pragma Inline (Value_Is_Valid);
-- Only valid for N_Typed_Variable_Declaration. Returns True if Value is
-- in the list of allowed strings for For_Typed_Variable. False otherwise.
function Associative_Array_Index_Of
- (Node : Project_Node_Id)
- return Name_Id;
+ (Node : Project_Node_Id) return Name_Id;
pragma Inline (Associative_Array_Index_Of);
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
-- Returns No_String for non associative array attributes.
function Next_Variable
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Variable);
-- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
-- nodes.
function First_Term
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Term);
-- Only valid for N_Expression nodes
function Next_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Expression_In_List);
-- Only valid for N_Expression nodes
function Current_Term
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Current_Term);
-- Only valid for N_Term nodes
function Next_Term
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Term);
-- Only valid for N_Term nodes
function First_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Expression_In_List);
-- Only valid for N_Literal_String_List nodes
function Package_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Package_Node_Of);
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
-- May return Empty_Node.
function String_Type_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (String_Type_Of);
-- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
-- nodes.
function External_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (External_Reference_Of);
-- Only valid for N_External_Value nodes
function External_Default_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (External_Default_Of);
-- Only valid for N_External_Value nodes
function Case_Variable_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Case_Variable_Reference_Of);
-- Only valid for N_Case_Construction nodes
function First_Case_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Case_Item_Of);
-- Only valid for N_Case_Construction nodes
function First_Choice_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Choice_Of);
-- Return the first choice in a N_Case_Item, or Empty_Node if
-- this is when others.
function Next_Case_Item
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Case_Item);
-- Only valid for N_Case_Item nodes
@@ -419,6 +491,35 @@ package Prj.Tree is
To : Source_Ptr);
pragma Inline (Set_Location_Of);
+ procedure Set_First_Comment_After
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_After);
+
+ procedure Set_First_Comment_After_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_After_End);
+
+ procedure Set_First_Comment_Before
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_Before);
+
+ procedure Set_First_Comment_Before_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_Before_End);
+
+ procedure Set_Next_Comment
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_Next_Comment);
+
+ procedure Set_Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id;
+ To : Boolean);
+
procedure Set_Directory_Of
(Node : Project_Node_Id;
To : Name_Id);
@@ -687,14 +788,32 @@ package Prj.Tree is
Field3 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind
- Case_Insensitive : Boolean := False;
- -- This flag is significant only for N_Attribute_Declaration and
- -- N_Atribute_Reference. It indicates for an associative array
- -- attribute, that the index is case insensitive.
-
- Extending_All : Boolean := False;
- -- This flag is significant only for N_Project. It indicates that
- -- the project "extends all" another project.
+ Flag1 : Boolean := False;
+ -- This flag is significant only for:
+ -- N_Attribute_Declaration and N_Atribute_Reference
+ -- It indicates for an associative array attribute, that the
+ -- index is case insensitive.
+ -- N_Comment - it indicates that the comment is preceded by an
+ -- empty line.
+ -- N_Project - it indicates that there are comments in the project
+ -- source that cannot be kept in the tree.
+ -- N_Project_Declaration
+ -- - it indixates that there are unkept comment in the
+ -- project.
+
+ Flag2 : Boolean := False;
+ -- This flag is significant only for:
+ -- N_Project - it indicates that the project "extends all" another
+ -- project.
+ -- N_Comment - it indicates that the comment is followed by an
+ -- empty line.
+
+ Comments : Project_Node_Id := Empty_Node;
+ -- For nodes other that N_Comment_Zones or N_Comment, designates the
+ -- comment zones associated with the node.
+ -- for N_Comment_Zones, designates the comment after the "end" of
+ -- the construct.
+ -- For N_Comment, designates the next comment, if any.
end record;
@@ -862,7 +981,7 @@ package Prj.Tree is
-- -- Field3: not used
-- -- Value: not used
- -- N_Case_Item);
+ -- N_Case_Item
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: not used
@@ -872,6 +991,28 @@ package Prj.Tree is
-- -- Field3: next case item
-- -- Value: not used
+ -- N_Comment_zones
+ -- -- Name: not used
+ -- -- Path_Name: not used
+ -- -- Expr_Kind: not used
+ -- -- Field1: comment before the construct
+ -- -- Field2: comment after the construct
+ -- -- Field3: comment before the "end" of the construct
+ -- -- Value: end of line comment
+ -- -- Comments: comment after the "end" of the construct
+
+ -- N_Comment
+ -- -- Name: not used
+ -- -- Path_Name: not used
+ -- -- Expr_Kind: not used
+ -- -- Field1: not used
+ -- -- Field2: not used
+ -- -- Field3: not used
+ -- -- Value: comment
+ -- -- Flag1: comment is preceded by an empty line
+ -- -- Flag2: comment is followed by an empty line
+ -- -- Comments: next comment
+
package Project_Nodes is
new Table.Table (Table_Component_Type => Project_Node_Record,
Table_Index_Type => Project_Node_Id,
@@ -910,5 +1051,21 @@ package Prj.Tree is
-- its name.
end Tree_Private_Part;
+
+private
+ type Comment_Array is array (Positive range <>) of Comment_Data;
+ type Comments_Ptr is access Comment_Array;
+
+ type Comment_State is record
+ End_Of_Line_Node : Project_Node_Id := Empty_Node;
+
+ Previous_Line_Node : Project_Node_Id := Empty_Node;
+
+ Previous_End_Node : Project_Node_Id := Empty_Node;
+
+ Unkept_Comments : Boolean := False;
+
+ Comments : Comments_Ptr := null;
+ end record;
end Prj.Tree;
Index: scans.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scans.ads,v
retrieving revision 1.8
diff -u -p -r1.8 scans.ads
--- scans.ads 21 Oct 2003 13:42:18 -0000 1.8
+++ scans.ads 8 Dec 2003 10:31:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -187,15 +187,21 @@ package Scans is
Tok_Dot_Dot, -- .. Sterm, Chtok
- -- The following three entries are used only when scanning
- -- project files.
+ -- The following three entries are used only when scanning project
+ -- files.
Tok_Project,
Tok_Extends,
Tok_External,
+ Tok_Comment,
+
+ -- The following entry is used by the preprocessor and when scanning
+ -- project files.
- -- The following two entries are used by the preprocessor
Tok_End_Of_Line,
+
+ -- The following entry is used by the preprocessor
+
Tok_Special,
No_Token);
@@ -403,6 +409,10 @@ package Scans is
Special_Character : Character;
-- Valid only when Token = Tok_Special
+
+ Comment_Id : Name_Id := No_Name;
+ -- Valid only when Token = Tok_Comment. Store the string that follows
+ -- the two '-' of a comment.
--------------------------------------------------------
-- Procedures for Saving and Restoring the Scan State --
Index: scng.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scng.adb,v
retrieving revision 1.1
diff -u -p -r1.1 scng.adb
--- scng.adb 21 Oct 2003 13:42:18 -0000 1.1
+++ scng.adb 8 Dec 2003 10:31:51 -0000
@@ -49,6 +49,9 @@ package body Scng is
Special_Characters : array (Character) of Boolean := (others => False);
-- For characters that are Special token, the value is True
+ Comment_Is_Token : Boolean := False;
+ -- True if comments are tokens
+
End_Of_Line_Is_Token : Boolean := False;
-- True if End_Of_Line is a token
@@ -229,6 +232,8 @@ package body Scng is
procedure Scan is
+ Start_Of_Comment : Source_Ptr;
+
procedure Check_End_Of_Line;
-- Called when end of line encountered. Checks that line is not
-- too long, and that other style checks for the end of line are met.
@@ -1394,6 +1399,7 @@ package body Scng is
else -- Source (Scan_Ptr + 1) = '-' then
if Style_Check then Style.Check_Comment; end if;
Scan_Ptr := Scan_Ptr + 2;
+ Start_Of_Comment := Scan_Ptr;
-- Loop to scan comment (this loop runs more than once only if
-- a horizontal tab or other non-graphic character is scanned)
@@ -1449,9 +1455,18 @@ package body Scng is
end loop;
- -- Note that we do NOT execute a return here, instead we fall
- -- through to reexecute the scan loop to look for a token.
-
+ -- Note that, except when comments are tokens, we do NOT
+ -- execute a return here, instead we fall through to reexecute
+ -- the scan loop to look for a token.
+
+ if Comment_Is_Token then
+ Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
+ Name_Buffer (1 .. Name_Len) :=
+ String (Source (Start_Of_Comment .. Scan_Ptr - 1));
+ Comment_Id := Name_Find;
+ Token := Tok_Comment;
+ return;
+ end if;
end if;
end Minus_Case;
@@ -2066,6 +2081,14 @@ package body Scng is
return;
end if;
end Scan;
+ --------------------------
+ -- Set_Comment_As_Token --
+ --------------------------
+
+ procedure Set_Comment_As_Token (Value : Boolean) is
+ begin
+ Comment_Is_Token := Value;
+ end Set_Comment_As_Token;
------------------------------
-- Set_End_Of_Line_As_Token --
Index: scng.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scng.ads,v
retrieving revision 1.1
diff -u -p -r1.1 scng.ads
--- scng.ads 21 Oct 2003 13:42:18 -0000 1.1
+++ scng.ads 8 Dec 2003 10:31:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -90,6 +90,10 @@ package Scng is
procedure Set_End_Of_Line_As_Token (Value : Boolean);
-- Indicate if End_Of_Line is a token or not.
-- By default, End_Of_Line is not a token.
+
+ procedure Set_Comment_As_Token (Value : Boolean);
+ -- Indicate if a comment is a token or not.
+ -- By default, a comment is not a token.
function Set_Start_Column return Column_Number;
-- This routine is called with Scan_Ptr pointing to the first character
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_aggr.adb
--- sem_aggr.adb 20 Nov 2003 09:54:00 -0000 1.11
+++ sem_aggr.adb 8 Dec 2003 10:31:51 -0000
@@ -29,6 +29,7 @@ with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
@@ -334,7 +335,7 @@ package body Sem_Aggr is
--
-- Typ is the context type in which N occurs.
--
- -- This routine creates an implicit array subtype whose bouds are
+ -- This routine creates an implicit array subtype whose bounds are
-- those defined by the aggregate. When this routine is invoked
-- Resolve_Array_Aggregate has already processed aggregate N. Thus the
-- Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the
@@ -962,6 +963,8 @@ package body Sem_Aggr is
-- formal parameter. Consequently we also need to test for
-- N_Procedure_Call_Statement or N_Function_Call.
+ Set_Etype (N, Aggr_Typ); -- may be overridden later on.
+
if Is_Constrained (Typ) and then
(Pkind = N_Assignment_Statement or else
Pkind = N_Parameter_Association or else
@@ -1641,9 +1644,27 @@ package body Sem_Aggr is
end if;
end loop;
- if not
- Resolve_Aggr_Expr
- (Expression (Assoc), Single_Elmt => Single_Choice)
+ -- Ada0Y (AI-287): In case of default initialized component
+ -- we delay the resolution to the expansion phase
+
+ if Box_Present (Assoc) then
+
+ -- Ada0Y (AI-287): In case of default initialization of a
+ -- component the expander will generate calls to the
+ -- corresponding initialization subprogram.
+
+ if Present (Base_Init_Proc (Etype (Component_Typ)))
+ or else Has_Task (Base_Type (Component_Typ))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("(Ada 0Y): no value supplied for this component",
+ Assoc);
+ end if;
+
+ elsif not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => Single_Choice)
then
return Failure;
end if;
@@ -1764,8 +1785,26 @@ package body Sem_Aggr is
if Others_Present then
Assoc := Last (Component_Associations (N));
- if not Resolve_Aggr_Expr (Expression (Assoc),
- Single_Elmt => False)
+
+ -- Ada0Y (AI-287): In case of default initialized component
+ -- we delay the resolution to the expansion phase.
+
+ if Box_Present (Assoc) then
+
+ -- Ada0Y (AI-287): In case of default initialization of a
+ -- component the expander will generate calls to the
+ -- corresponding initialization subprogram.
+
+ if Present (Base_Init_Proc (Etype (Component_Typ))) then
+ null;
+ else
+ Error_Msg_N
+ ("(Ada 0Y): no value supplied for these components",
+ Assoc);
+ end if;
+
+ elsif not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => False)
then
return Failure;
end if;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.28
diff -u -p -r1.28 sem_ch12.adb
--- sem_ch12.adb 20 Nov 2003 09:54:01 -0000 1.28
+++ sem_ch12.adb 8 Dec 2003 10:31:52 -0000
@@ -1466,7 +1466,10 @@ package body Sem_Ch12 is
end if;
if K = E_Generic_In_Parameter then
- if Is_Limited_Type (T) then
+
+ -- Ada0Y (AI-287): Limited aggregates allowed in generic formals
+
+ if not Extensions_Allowed and then Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
Explain_Limited_Type (T, N);
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.24
diff -u -p -r1.24 sem_ch3.adb
--- sem_ch3.adb 27 Nov 2003 11:40:45 -0000 1.24
+++ sem_ch3.adb 8 Dec 2003 10:31:53 -0000
@@ -6246,6 +6246,7 @@ package body Sem_Ch3 is
if (Is_Limited_Type (T)
or else Is_Limited_Composite (T))
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
-- limited aggregates and extension aggregates.
@@ -8438,18 +8439,6 @@ package body Sem_Ch3 is
Init_Size_Align (Implicit_Base);
- -- Complete entity for first subtype
-
- Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
- Set_Etype (T, Implicit_Base);
- Set_Size_Info (T, Implicit_Base);
- Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
- Set_Digits_Value (T, Digs_Val);
- Set_Delta_Value (T, Delta_Val);
- Set_Small_Value (T, Delta_Val);
- Set_Scale_Value (T, Scale_Val);
- Set_Is_Constrained (T);
-
-- If there are bounds given in the declaration use them as the
-- bounds of the first named subtype.
@@ -8491,6 +8480,18 @@ package body Sem_Ch3 is
else
Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
end if;
+
+ -- Complete entity for first subtype
+
+ Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Set_Size_Info (T, Implicit_Base);
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Digits_Value (T, Digs_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Small_Value (T, Delta_Val);
+ Set_Scale_Value (T, Scale_Val);
+ Set_Is_Constrained (T);
end Decimal_Fixed_Point_Type_Declaration;
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_util.adb
--- sem_util.adb 20 Nov 2003 09:54:01 -0000 1.15
+++ sem_util.adb 8 Dec 2003 10:31:53 -0000
@@ -6371,6 +6371,9 @@ package body Sem_Util is
Error_Msg_N (
"operator of the type is not directly visible!", Expr);
+ elsif Ekind (Found_Type) = E_Void then
+ Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
+
else
Error_Msg_NE ("found}!", Expr, Found_Type);
end if;
Index: sinput-p.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinput-p.adb,v
retrieving revision 1.5
diff -u -p -r1.5 sinput-p.adb
--- sinput-p.adb 21 Oct 2003 13:42:22 -0000 1.5
+++ sinput-p.adb 8 Dec 2003 10:31:53 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -24,7 +24,6 @@
-- --
------------------------------------------------------------------------------
-with Prj; use Prj;
with Prj.Err;
with Sinput.C;
@@ -97,7 +96,7 @@ package body Sinput.P is
or else Token = Tok_Private
or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
loop
- Scan;
+ Prj.Err.Scanner.Scan;
end loop;
return Token = Tok_Separate;
Index: targparm.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.ads,v
retrieving revision 1.6
diff -u -p -r1.6 targparm.ads
--- targparm.ads 21 Oct 2003 13:42:22 -0000 1.6
+++ targparm.ads 8 Dec 2003 10:31:53 -0000
@@ -322,12 +322,6 @@ package Targparm is
--
-- The variable __gnat_exit_status is generated within the binder file
-- instead of being imported from the run-time library.
- --
- -- No -Ldir switches are added for the linker step
- --
- -- No standard switches are added after user file entries to the
- -- linker line. All such switches must be explicit. In other words
- -- the option -nostdlib is implicit with a configurable run-time.
Suppress_Standard_Library_On_Target : Boolean;
-- If this flag is True, then the standard library is not included by
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.58
diff -u -p -r1.58 Makefile.in
--- Makefile.in 5 Dec 2003 10:24:05 -0000 1.58
+++ Makefile.in 8 Dec 2003 10:31:53 -0000
@@ -1843,6 +1843,8 @@ rts-zfp: force
-$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
+ $(AR) r rts-zfp/adalib/libgnat.a
+ $(CHMOD) a-wx rts-zfp/adalib/libgnat.a
rts-none: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
@@ -1861,6 +1863,8 @@ rts-ravenscar: force
-$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
$(CHMOD) a-wx rts-ravenscar/adalib/*.ali
+ $(AR) r rts-ravenscar/adalib/libgnat.a
+ $(CHMOD) a-wx rts-ravenscar/adalib/libgnat.a
# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
gnatlib-shared-default:
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.61
diff -u -p -r1.61 Make-lang.in
--- Make-lang.in 5 Dec 2003 10:24:04 -0000 1.61
+++ Make-lang.in 8 Dec 2003 10:31:53 -0000
@@ -915,8 +915,8 @@ ada.distclean:
-$(RM) ada/tools/*
-$(RMDIR) ada/tools
ada.maintainer-clean:
- -$(RM) ada/a-sinfo.h
- -$(RM) ada/a-einfo.h
+ -$(RM) ada/sinfo.h
+ -$(RM) ada/einfo.h
-$(RM) ada/nmake.adb
-$(RM) ada/nmake.ads
-$(RM) ada/treeprs.ads
@@ -1213,6 +1213,11 @@ ada/a-charac.o : ada/ada.ads ada/a-chara
ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
ada/system.ads
+ada/a-elchha.o : ada/ada.ads ada/a-except.ads ada/a-elchha.ads \
+ ada/a-elchha.adb ada/system.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traent.ads ada/unchconv.ads
+
ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \
ada/a-excach.adb ada/a-exexda.adb ada/a-exexpr.adb ada/a-exextr.adb \
ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads ada/a-uncdea.ads \
@@ -1525,26 +1530,26 @@ ada/exp_aggr.o : ada/ada.ads ada/a-excep
ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \
ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \
- ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/exp_util.adb ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
- ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads \
- ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb \
- ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
- ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads
+ ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_tss.ads \
+ ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \
+ ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
+ ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
@@ -1679,13 +1684,13 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except
ada/sem_intr.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_res.adb \
ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
- ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-05 10:25 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-05 10:25 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-05 Thomas Quinot <quinot@act-europe.fr>
* 3ssoliop.ads: Fix comment (this is the Solaris, not the UnixWare,
version of this unit).
2003-12-05 Olivier Hainque <hainque@act-europe.fr>
* 53osinte.ads, 54osinte.ads, 55osinte.ads, 56osinte.ads, 5bosinte.ads,
5cosinte.ads, 5hosinte.ads, 5iosinte.ads, 5losinte.ads,
5tosinte.ads: Define the SA_SIGINFO constant, to allow references from
the body of System.Interrupt_Management common to several targets.
Update copyright notice when appropriate.
* 52osinte.ads, 5posinte.ads: Define a dummy value for the SA_SIGINFO
constant.
* 7sintman.adb (elaboration): Set SA_SIGINFO in the sigaction flags,
to ensure that the kernel fills in the interrupted context structure
before calling a signal handler, which is necessary to be able to
unwind past it. Update the copyright notice.
2003-12-05 Jerome Guitton <guitton@act-europe.fr>
* a-elchha.ads: New file.
* a-elchha.adb: New default last chance handler. Contents taken from
Ada.Exceptions.Exception_Traces.Unhandled_Exception_Terminate.
* a-exextr.adb (Unhandled_Exception_Terminate): Most of this routine
is moved to a-elchha.adb to provide a target-independent default last
chance handler.
* Makefile.rtl: Add a-elchha.o
* Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Add a-elchha.o.
2003-12-05 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Expand_Call): If the subprogram is inlined and is
declared in an instance, do not inline the call if the instance is not
frozen yet, to prevent order of elaboration problems.
* sem_prag.adb: Add comments for previous fix.
2003-12-05 Samuel Tardieu <tardieu@act-europe.fr>
* g-table.adb: Use the right variable in Set_Item.
Update copyright notice.
2003-12-05 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.in: Remove unused rules.
2003-12-05 Vincent Celier <celier@gnat.com>
* switch-c.adb (Scan_Front_End_Switches): Remove processing of
-nostdlib. Not needed here after all.
--
Index: 3ssoliop.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3ssoliop.ads,v
retrieving revision 1.4
diff -u -p -r1.4 3ssoliop.ads
--- 3ssoliop.ads 21 Oct 2003 13:41:51 -0000 1.4
+++ 3ssoliop.ads 5 Dec 2003 09:33:12 -0000
@@ -34,7 +34,7 @@
-- This package is used to provide target specific linker_options for the
-- support of scokets as required by the package GNAT.Sockets.
--- This is the UnixWare version of this package
+-- This is the Solaris version of this package
package GNAT.Sockets.Linker_Options is
private
Index: 52osinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/52osinte.ads,v
retrieving revision 1.5
diff -u -p -r1.5 52osinte.ads
--- 52osinte.ads 21 Oct 2003 13:41:51 -0000 1.5
+++ 52osinte.ads 5 Dec 2003 09:33:12 -0000
@@ -153,6 +153,8 @@ package System.OS_Interface is
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+ SA_SIGINFO : constant := 16#80#;
+
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
SIG_SETMASK : constant := 2;
Index: 53osinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/53osinte.ads,v
retrieving revision 1.5
diff -u -p -r1.5 53osinte.ads
--- 53osinte.ads 21 Oct 2003 13:41:51 -0000 1.5
+++ 53osinte.ads 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 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- --
@@ -152,6 +152,8 @@ package System.OS_Interface is
end record;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#10#;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
Index: 54osinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/54osinte.ads,v
retrieving revision 1.4
diff -u -p -r1.4 54osinte.ads
--- 54osinte.ads 21 Oct 2003 13:41:51 -0000 1.4
+++ 54osinte.ads 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, 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- --
@@ -156,6 +156,8 @@ package System.OS_Interface is
end record;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#0008#;
SIG_BLOCK : constant := 1;
SIG_UNBLOCK : constant := 2;
Index: 55osinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/55osinte.ads,v
retrieving revision 1.1
diff -u -p -r1.1 55osinte.ads
--- 55osinte.ads 20 Nov 2003 17:51:26 -0000 1.1
+++ 55osinte.ads 5 Dec 2003 09:33:12 -0000
@@ -171,6 +171,8 @@ package System.OS_Interface is
SIG_DFL : constant := 0;
SIG_IGN : constant := 1;
+ SA_SIGINFO : constant := 16#0040#;
+
function sigaction
(sig : Signal;
act : struct_sigaction_ptr;
Index: 56osinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/56osinte.ads,v
retrieving revision 1.1
diff -u -p -r1.1 56osinte.ads
--- 56osinte.ads 21 Oct 2003 13:41:51 -0000 1.1
+++ 56osinte.ads 5 Dec 2003 09:33:12 -0000
@@ -167,6 +167,8 @@ package System.OS_Interface is
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+ SA_SIGINFO : constant := 16#80#;
+
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
SIG_SETMASK : constant := 2;
Index: 5bosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5bosinte.ads,v
retrieving revision 1.5
diff -u -p -r1.5 5bosinte.ads
--- 5bosinte.ads 21 Oct 2003 13:41:51 -0000 1.5
+++ 5bosinte.ads 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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- --
@@ -162,6 +162,7 @@ package System.OS_Interface is
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+ SA_SIGINFO : constant := 16#0100#;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
Index: 5cosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5cosinte.ads,v
retrieving revision 1.5
diff -u -p -r1.5 5cosinte.ads
--- 5cosinte.ads 21 Oct 2003 13:41:51 -0000 1.5
+++ 5cosinte.ads 5 Dec 2003 09:33:12 -0000
@@ -162,6 +162,8 @@ package System.OS_Interface is
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+ SA_SIGINFO : constant := 16#0100#;
+
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
SIG_SETMASK : constant := 2;
Index: 5hosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5hosinte.ads,v
retrieving revision 1.4
diff -u -p -r1.4 5hosinte.ads
--- 5hosinte.ads 21 Oct 2003 13:41:52 -0000 1.4
+++ 5hosinte.ads 5 Dec 2003 09:33:12 -0000
@@ -164,6 +164,7 @@ package System.OS_Interface is
type struct_sigaction_ptr is access all struct_sigaction;
SA_RESTART : constant := 16#40#;
+ SA_SIGINFO : constant := 16#10#;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
Index: 5iosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5iosinte.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5iosinte.ads
--- 5iosinte.ads 1 May 2003 14:14:35 -0000 1.6
+++ 5iosinte.ads 5 Dec 2003 09:33:12 -0000
@@ -196,6 +196,8 @@ package System.OS_Interface is
end record;
type Machine_State_Ptr is access all Machine_State;
+ SA_SIGINFO : constant := 16#04#;
+
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
SIG_SETMASK : constant := 2;
Index: 5losinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5losinte.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5losinte.ads
--- 5losinte.ads 21 Oct 2003 13:41:52 -0000 1.6
+++ 5losinte.ads 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2003 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- --
@@ -161,6 +161,8 @@ package System.OS_Interface is
edi : unsigned_long;
end record;
type Machine_State_Ptr is access all Machine_State;
+
+ SA_SIGINFO : constant := 16#04#;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
Index: 5posinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5posinte.ads,v
retrieving revision 1.5
diff -u -p -r1.5 5posinte.ads
--- 5posinte.ads 21 Oct 2003 13:41:52 -0000 1.5
+++ 5posinte.ads 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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- --
@@ -154,6 +154,10 @@ package System.OS_Interface is
SIG_DFL : constant := 0;
SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 0;
+ -- Dummy constant for a sa_flags bit. A proper definition is needed only
+ -- for the GCC/ZCX EH scheme (see System.Interrupt_Management).
function sigaction
(sig : Signal;
Index: 5tosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5tosinte.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5tosinte.ads
--- 5tosinte.ads 21 Oct 2003 13:41:52 -0000 1.6
+++ 5tosinte.ads 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003, 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- --
@@ -248,6 +248,8 @@ package System.OS_Interface is
end record;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#08;
SIG_BLOCK : constant := 1;
SIG_UNBLOCK : constant := 2;
Index: 7sintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7sintman.adb,v
retrieving revision 1.6
diff -u -p -r1.6 7sintman.adb
--- 7sintman.adb 21 Oct 2003 13:41:53 -0000 1.6
+++ 7sintman.adb 5 Dec 2003 09:33:12 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, 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- --
@@ -175,7 +175,16 @@ begin
act.sa_handler := Notify_Exception'Address;
- act.sa_flags := 0;
+ act.sa_flags := SA_SIGINFO;
+
+ -- Setting SA_SIGINFO asks the kernel to pass more than just the signal
+ -- number argument to the handler when it is called. The set of extra
+ -- parameters typically includes a pointer to a structure describing
+ -- the interrupted context. Although the Notify_Exception handler does
+ -- not use this information, it is actually required for the GCC/ZCX
+ -- exception propagation scheme because on some targets (at least
+ -- alpha-tru64), the structure contents are not even filled when this
+ -- flag is not set.
-- On some targets, we set sa_flags to SA_NODEFER so that during the
-- handler execution we do not change the Signal_Mask to be masked for
Index: a-exextr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-exextr.adb,v
retrieving revision 1.1
diff -u -p -r1.1 a-exextr.adb
--- a-exextr.adb 21 Oct 2003 13:41:53 -0000 1.1
+++ a-exextr.adb 5 Dec 2003 09:33:12 -0000
@@ -50,6 +50,14 @@ package body Exception_Traces is
pragma Export
(Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
+ procedure Last_Chance_Handler
+ (Except : Exception_Occurrence);
+ pragma Import
+ (C, Last_Chance_Handler, "__gnat_last_chance_handler");
+ pragma No_Return (Last_Chance_Handler);
+ -- Users can replace the default version of this routine,
+ -- Ada.Exceptions.Last_Chance_Handler.
+
function To_Action is new Unchecked_Conversion
(Raise_Action, Exception_Action);
@@ -95,11 +103,6 @@ package body Exception_Traces is
pragma Propagate_Exceptions;
- procedure Unhandled_Terminate;
- pragma No_Return (Unhandled_Terminate);
- pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
- -- Perform system dependent shutdown code
-
----------------------
-- Notify_Exception --
----------------------
@@ -186,89 +189,8 @@ package body Exception_Traces is
-- could be overwritten if an exception is raised during finalization
-- (even if that exception is caught).
- Msg : constant String := Excep.Msg (1 .. Excep.Msg_Length);
-
- Max_Static_Exc_Info : constant := 1024;
- -- That should be enough for most exception information cases
- -- eventhough tailorising introduces some uncertainty. the
- -- name+message should not exceed 320 chars, so that leaves at
- -- least 35 backtrace slots (each slot needs 19 chars for
- -- representing a 64 bit address).
- -- And what happens on overflow ???
-
- subtype Exc_Info_Type is String (1 .. Max_Static_Exc_Info);
- type Str_Ptr is access Exc_Info_Type;
- Exc_Info : Str_Ptr;
- Exc_Info_Last : Natural := 0;
- -- Buffer that is allocated to store the tailored exception
- -- information while Adafinal is run. This buffer is allocated
- -- on the heap only when it is needed. It is better to allocate
- -- on the heap than on the stack since stack overflows are more
- -- common that heap overflows.
-
- -- Start of processing for Unhandled_Exception_Terminate
-
begin
- -- First allocate & store the exception info in a buffer when
- -- we know it will be needed. This needs to be done before
- -- Adafinal because it implicitly uses the secondary stack.
-
- if Excep.Id.Full_Name.all (1) /= '_'
- and then Excep.Num_Tracebacks /= 0
- then
- Exc_Info := new Exc_Info_Type;
- if Exc_Info /= null then
- Tailored_Exception_Information
- (Excep.all, Exc_Info.all, Exc_Info_Last);
- end if;
- end if;
-
- -- Let's shutdown the runtime now. The rest of the procedure
- -- needs to be careful not to use anything that would require
- -- runtime support. In particular, function returing strings
- -- are banned since the sec stack is not functional anymore
-
- System.Standard_Library.Adafinal;
-
- -- Check for special case of raising _ABORT_SIGNAL, which is not
- -- really an exception at all. We recognize this by the fact that
- -- it is the only exception whose name starts with underscore.
-
- if Excep.Id.Full_Name.all (1) = '_' then
- To_Stderr (Nline);
- To_Stderr ("Execution terminated by abort of environment task");
- To_Stderr (Nline);
-
- -- If no tracebacks, we print the unhandled exception in the old style
- -- (i.e. the style used before ZCX was implemented). We do this to
- -- retain compatibility, especially with the nightly scripts, but
- -- this can be removed at some point ???
-
- elsif Excep.Num_Tracebacks = 0 then
- To_Stderr (Nline);
- To_Stderr ("raised ");
- To_Stderr (Excep.Id.Full_Name.all (1 .. Excep.Id.Name_Length - 1));
-
- if Msg'Length /= 0 then
- To_Stderr (" : ");
- To_Stderr (Msg);
- end if;
-
- To_Stderr (Nline);
-
- else
- -- Traceback exists
-
- -- Note we can have this whole information output twice if
- -- this occurrence gets reraised up to here.
-
- To_Stderr (Nline);
- To_Stderr ("Execution terminated by unhandled exception");
- To_Stderr (Nline);
- To_Stderr (Exc_Info (1 .. Exc_Info_Last));
- end if;
-
- Unhandled_Terminate;
+ Last_Chance_Handler (Excep.all);
end Unhandled_Exception_Terminate;
---------------
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.14
diff -u -p -r1.14 exp_ch6.adb
--- exp_ch6.adb 1 Dec 2003 13:29:27 -0000 1.14
+++ exp_ch6.adb 5 Dec 2003 09:33:13 -0000
@@ -1941,6 +1941,7 @@ package body Exp_Ch6 is
Bod : Node_Id;
Must_Inline : Boolean := False;
Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+ Scop : constant Entity_Id := Scope (Subp);
begin
-- Verify that the body to inline has already been seen,
@@ -1954,6 +1955,26 @@ package body Exp_Ch6 is
then
Must_Inline := False;
+ -- If this an inherited function that returns a private
+ -- type, do not inline if the full view is an unconstrained
+ -- array, because such calls cannot be inlined.
+
+ elsif Present (Orig_Subp)
+ and then Is_Array_Type (Etype (Orig_Subp))
+ and then not Is_Constrained (Etype (Orig_Subp))
+ then
+ Must_Inline := False;
+
+ -- If the subprogram comes from an instance in the same
+ -- unit, and the instance is not yet frozen, inlining might
+ -- trigger order-of-elaboration problems in gigi.
+
+ elsif Is_Generic_Instance (Scop)
+ and then Present (Freeze_Node (Scop))
+ and then not Analyzed (Freeze_Node (Scop))
+ then
+ Must_Inline := False;
+
else
Bod := Body_To_Inline (Spec);
@@ -2531,7 +2552,8 @@ package body Exp_Ch6 is
Temp_Typ := Etype (A);
end if;
- -- Comments needed here ???
+ -- If the actual is a simple name or a literal, no need to
+ -- create a temporary, object can be used directly.
if (Is_Entity_Name (A)
and then
Index: g-table.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-table.adb,v
retrieving revision 1.5
diff -u -p -r1.5 g-table.adb
--- g-table.adb 21 Oct 2003 13:42:05 -0000 1.5
+++ g-table.adb 5 Dec 2003 09:33:13 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 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- --
@@ -224,7 +224,7 @@ package body GNAT.Table is
Item : Table_Component_Type)
is
begin
- if Integer (Index) > Max then
+ if Integer (Index) > Last_Val then
Set_Last (Index);
end if;
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.60
diff -u -p -r1.60 Make-lang.in
--- Make-lang.in 1 Dec 2003 13:29:28 -0000 1.60
+++ Make-lang.in 5 Dec 2003 09:33:13 -0000
@@ -118,7 +118,7 @@ GNAT1_C_OBJS = ada/b_gnat1.o ada/adadeco
# Object files from Ada sources that are used by gnat1
GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \
- ada/a-ioexce.o \
+ ada/a-elchha.o ada/a-ioexce.o \
ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-purexc.o \
ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/s-except.o ada/ali.o \
ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \
@@ -173,6 +173,7 @@ GNATBIND_OBJS = \
ada/tracebak.o \
ada/a-except.o \
ada/ada.o \
+ ada/a-elchha.o \
ada/ali-util.o \
ada/ali.o \
ada/alloc.o \
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_prag.adb
--- sem_prag.adb 3 Dec 2003 11:47:53 -0000 1.13
+++ sem_prag.adb 5 Dec 2003 09:33:13 -0000
@@ -9631,6 +9631,10 @@ package body Sem_Prag is
E_Id := Expression (Arg2);
Analyze (E_Id);
+ -- In the expansion of an inlined body, a reference to
+ -- the formal may be wrapped in a conversion if the actual
+ -- is a conversion. Retrieve the real entity name.
+
if In_Instance_Body
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.8
diff -u -p -r1.8 switch-c.adb
--- switch-c.adb 1 Dec 2003 13:29:27 -0000 1.8
+++ switch-c.adb 5 Dec 2003 09:33:13 -0000
@@ -97,7 +97,7 @@ package body Switch.C is
when False =>
-- There are few front-end switches that
- -- do not start with -gnat: -I, --RTS, -nostdlib
+ -- do not start with -gnat: -I, --RTS
if Switch_Chars (Ptr) = 'I' then
Store_Switch := False;
@@ -117,14 +117,6 @@ package body Switch.C is
Add_Src_Search_Dir (Switch_Chars (Ptr .. Max));
end if;
- Ptr := Max + 1;
-
- -- Processing of -nostdlib
-
- elsif Ptr + 7 = Max
- and then Switch_Chars (Ptr .. Ptr + 7) = "nostdlib"
- then
- Opt.No_Stdlib := True;
Ptr := Max + 1;
-- Processing of the --RTS switch. --RTS has been modified by
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.2
diff -u -p -r1.2 Makefile.rtl
--- Makefile.rtl 30 Oct 2003 11:50:12 -0000 1.2
+++ Makefile.rtl 5 Dec 2003 09:33:13 -0000
@@ -87,6 +87,7 @@ GNATRTL_NONTASKING_OBJS= \
a-diocst$(objext) \
a-direio$(objext) \
a-einuoc$(objext) \
+ a-elchha$(objext) \
a-except$(objext) \
a-exctra$(objext) \
a-filico$(objext) \
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-03 11:49 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-03 11:49 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-03 Thomas Quinot <quinot@act-europe.fr>
PR ada/11724
* adaint.h, adaint.c, g-os_lib.ads:
Do not assume that the offset argument to lseek(2) is a 32 bit integer,
on some platforms (including FreeBSD), it is a 64 bit value.
Introduce a __gnat_lseek wrapper in adaint.c to allow for portability.
2003-12-03 Arnaud Charlet <charlet@act-europe.fr>
* gnatvsn.ads (Library_Version): Now contain only the relevant
version info.
(Verbose_Library_Version): New constant.
* g-spipat.adb, g-awk.adb, g-debpoo.adb,
g-memdum.adb, g-thread.adb, s-geveop.adb, s-interr.adb,
s-taskin.adb, s-tassta.adb: Make code compile with -gnatwa.
* gnatlbr.adb: Clean up: replace Library_Version by
Verbose_Library_Version.
* make.adb, lib-writ.adb, exp_attr.adb:
Clean up: replace Library_Version by Verbose_Library_Version.
* 5lintman.adb: Removed.
* Makefile.in:
Update and simplify computation of LIBRARY_VERSION.
Fix computation of GSMATCH_VERSION.
5lintman.adb is no longer used: replaced by 7sintman.adb.
2003-12-03 Robert Dewar <dewar@gnat.com>
* exp_ch5.adb:
(Possible_Bit_Aligned_Component): Maybe_Bit_Aligned_Large_Component new
name. Modified to consider small non-bit-packed arrays as troublesome
and in need of component-by-component assigment expansion.
2003-12-03 Vincent Celier <celier@gnat.com>
* lang-specs.h: Process nostdlib as nostdinc
* back_end.adb: Update Copyright notice
(Scan_Compiler_Arguments): Process -nostdlib directly.
2003-12-03 Jose Ruiz <ruiz@act-europe.fr>
* Makefile.in:
When defining LIBGNAT_TARGET_PAIRS for bare board targets, remove the
redundant inclusion of EXTRA_HIE_NONE_TARGET_PAIRS, which is always
included in HIE_NONE_TARGET_PAIRS.
2003-12-03 Ed Schonberg <schonberg@gnat.com>
* sem_attr.adb:
(Legal_Formal_Attribute): Attribute is legal in an inlined body, as it
is legal in an instance, because legality is cheched in the template.
* sem_prag.adb:
(Analyze_Pragma, case Warnings): In an inlined body, the pragma may be
appplied to an unchecked conversion of a formal parameter.
* sem_warn.adb:
(Output_Unreferenced_Messages): Suppress "not read" warnings on imported
variables.
2003-12-03 Olivier Hainque <hainque@act-europe.fr>
* tb-alvms.c (unwind_regular_code, unwind_kernel_handler): New
routines. The second one is new functionality to deal with backtracing
through signal handlers.
(unwind): Split into the two separate subroutines above.
Update the documentation, and deal properly with sizeof (REG) different
from sizeof (void*).
--
Index: adaint.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.h,v
retrieving revision 1.13
diff -u -r1.13 adaint.h
--- adaint.h 21 Oct 2003 13:41:58 -0000 1.13
+++ adaint.h 3 Dec 2003 11:41:53 -0000
@@ -140,6 +140,7 @@
extern void __gnat_set_binary_mode (int);
extern void __gnat_set_text_mode (int);
extern char *__gnat_ttyname (int);
+extern int __gnat_lseek (int, long, int);
#ifdef __MINGW32__
extern void __gnat_plist_init (void);
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.24
diff -u -r1.24 adaint.c
--- adaint.c 21 Nov 2003 10:46:37 -0000 1.24
+++ adaint.c 3 Dec 2003 11:41:54 -0000
@@ -2481,3 +2481,9 @@
a no-op in this case. */
#endif
}
+
+int
+__gnat_lseek (int fd, long offset, int whence)
+{
+ return (int) lseek (fd, offset, whence);
+}
Index: back_end.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/back_end.adb,v
retrieving revision 1.5
diff -u -r1.5 back_end.adb
--- back_end.adb 24 Apr 2003 17:53:58 -0000 1.5
+++ back_end.adb 3 Dec 2003 11:41:54 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -269,6 +269,12 @@
elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then
Opt.No_Stdinc := True;
Scan_Back_End_Switches (Argv);
+
+ -- We must recognize -nostdlib to suppress visibility on the
+ -- standard GNAT RTL objects.
+
+ elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then
+ Opt.No_Stdlib := True;
elsif Is_Front_End_Switch (Argv) then
Scan_Front_End_Switches (Argv);
Index: exp_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_attr.adb,v
retrieving revision 1.7
diff -u -r1.7 exp_attr.adb
--- exp_attr.adb 21 Oct 2003 13:41:59 -0000 1.7
+++ exp_attr.adb 3 Dec 2003 11:41:54 -0000
@@ -907,8 +907,9 @@
if Pent = Standard_Standard
or else Pent = Standard_ASCII
then
- Name_Buffer (1 .. Library_Version'Length) := Library_Version;
- Name_Len := Library_Version'Length;
+ Name_Buffer (1 .. Verbose_Library_Version'Length) :=
+ Verbose_Library_Version;
+ Name_Len := Verbose_Library_Version'Length;
Rewrite (N,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.11
diff -u -r1.11 exp_ch5.adb
--- exp_ch5.adb 29 Oct 2003 10:26:13 -0000 1.11
+++ exp_ch5.adb 3 Dec 2003 11:41:54 -0000
@@ -95,24 +95,6 @@
-- either because the target is not byte aligned, or there is a change
-- of representation.
- function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
- -- This function is used in processing the assignment of a record or
- -- indexed component. The back end can handle such assignments fine
- -- if the objects involved are small (64-bits) or are both aligned on
- -- a byte boundary (starts on a byte, and ends on a byte). However,
- -- problems arise for large components that are not byte aligned,
- -- since the assignment may clobber other components that share bit
- -- positions in the starting or ending bytes, and in the case of
- -- components not starting on a byte boundary, the back end cannot
- -- even manage to extract the value. This function is used to detect
- -- such situations, so that the assignment can be handled component-wise.
- -- A value of False means that either the object is known to be greater
- -- than 64 bits, or that it is known to be byte aligned (and occupy an
- -- integral number of bytes. True is returned if the object is known to
- -- be greater than 64 bits, and is known to be unaligned. As implied
- -- by the name, the result is conservative, in that if the compiler
- -- cannot determine these conditions at compile time, True is returned.
-
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
-- that is to say, finalization of the target before, adjustement of
@@ -120,13 +102,41 @@
-- pointers which are not 'part of the value' and must not be changed
-- upon assignment. N is the original Assignment node.
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
+ -- This function is used in processing the assignment of a record or
+ -- indexed component. The back end can handle such assignments fine
+ -- if the objects involved are small (64-bits or less) records or
+ -- scalar items (including bit-packed arrays represented with modular
+ -- types) or are both aligned on a byte boundary (starting on a byte
+ -- boundary, and occupying an integral number of bytes).
+ --
+ -- However, problems arise for records larger than 64 bits, or for
+ -- arrays (other than bit-packed arrays represented with a modular
+ -- type) if the component starts on a non-byte boundary, or does
+ -- not occupy an integral number of bytes (i.e. there are some bits
+ -- possibly shared with fields at the start or beginning of the
+ -- component). The back end cannot handle loading and storing such
+ -- components in a single operation.
+ --
+ -- This function is used to detect the troublesome situation. it is
+ -- conservative in the sense that it produces True unless it knows
+ -- for sure that the component is safe (as outlined in the first
+ -- paragraph above). The code generation for record and array
+ -- assignment checks for trouble using this function, and if so
+ -- the assignment is generated component-wise, which the back end
+ -- is required to handle correctly.
+ --
+ -- Note that in GNAT 3, the back end will reject such components
+ -- anyway, so the hard work in checking for this case is wasted
+ -- in GNAT 3, but it's harmless, so it is easier to do it in
+ -- all cases, rather than conditionalize it in GNAT 5 or beyond.
+
------------------------------
-- Change_Of_Representation --
------------------------------
function Change_Of_Representation (N : Node_Id) return Boolean is
Rhs : constant Node_Id := Expression (N);
-
begin
return
Nkind (Rhs) = N_Type_Conversion
@@ -372,9 +382,9 @@
-- We require a loop if the left side is possibly bit unaligned
- elsif Maybe_Bit_Aligned_Large_Component (Lhs)
+ elsif Possible_Bit_Aligned_Component (Lhs)
or else
- Maybe_Bit_Aligned_Large_Component (Rhs)
+ Possible_Bit_Aligned_Component (Rhs)
then
Loop_Required := True;
@@ -1026,9 +1036,9 @@
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
- elsif Maybe_Bit_Aligned_Large_Component (Lhs)
+ elsif Possible_Bit_Aligned_Component (Lhs)
or
- Maybe_Bit_Aligned_Large_Component (Rhs)
+ Possible_Bit_Aligned_Component (Rhs)
then
null;
@@ -3221,11 +3231,11 @@
return Empty_List;
end Make_Tag_Ctrl_Assignment;
- ---------------------------------------
- -- Maybe_Bit_Aligned_Large_Component --
- ---------------------------------------
+ ------------------------------------
+ -- Possible_Bit_Aligned_Component --
+ ------------------------------------
- function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean is
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
begin
case Nkind (N) is
@@ -3250,7 +3260,7 @@
-- indexing from a possibly unaligned component.
else
- return Maybe_Bit_Aligned_Large_Component (P);
+ return Possible_Bit_Aligned_Component (P);
end if;
end;
@@ -3268,17 +3278,22 @@
-- only the recursive test on the prefix.
if No (Component_Clause (Comp)) then
- return Maybe_Bit_Aligned_Large_Component (P);
+ return Possible_Bit_Aligned_Component (P);
-- Otherwise we have a component clause, which means that
-- the Esize and Normalized_First_Bit fields are set and
-- contain static values known at compile time.
else
- -- If we know the size is 64 bits or less we are fine
- -- since the back end always handles small fields right.
-
- if Esize (Comp) <= 64 then
+ -- If we know that we have a small (64 bits or less) record
+ -- or bit-packed array, then everything is fine, since the
+ -- back end can handle these cases correctly.
+
+ if Esize (Comp) <= 64
+ and then (Is_Record_Type (Etype (Comp))
+ or else
+ Is_Bit_Packed_Array (Etype (Comp)))
+ then
return False;
-- Otherwise if the component is not byte aligned, we
@@ -3293,7 +3308,7 @@
-- but we still need to test our prefix recursively.
else
- return Maybe_Bit_Aligned_Large_Component (P);
+ return Possible_Bit_Aligned_Component (P);
end if;
end if;
end;
@@ -3306,6 +3321,6 @@
return False;
end case;
- end Maybe_Bit_Aligned_Large_Component;
+ end Possible_Bit_Aligned_Component;
end Exp_Ch5;
Index: g-awk.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-awk.adb,v
retrieving revision 1.6
diff -u -r1.6 g-awk.adb
--- g-awk.adb 21 Oct 2003 13:42:00 -0000 1.6
+++ g-awk.adb 3 Dec 2003 11:41:54 -0000
@@ -873,8 +873,7 @@
Callbacks : Callback_Mode := None;
Session : Session_Type := Current_Session)
is
- Filter_Active : Boolean;
- Quit : Boolean;
+ Quit : Boolean;
begin
Open (Separators, Filename, Session);
@@ -884,7 +883,12 @@
Split_Line (Session);
if Callbacks in Only .. Pass_Through then
- Filter_Active := Apply_Filters (Session);
+ declare
+ Discard : Boolean;
+ pragma Unreferenced (Discard);
+ begin
+ Discard := Apply_Filters (Session);
+ end;
end if;
if Callbacks /= Only then
Index: g-debpoo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-debpoo.adb,v
retrieving revision 1.6
diff -u -r1.6 g-debpoo.adb
--- g-debpoo.adb 21 Oct 2003 13:42:00 -0000 1.6
+++ g-debpoo.adb 3 Dec 2003 11:41:54 -0000
@@ -116,7 +116,7 @@
return Tracebacks_Array_Access;
function Hash (T : Tracebacks_Array_Access) return Header;
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
- pragma Inline (Set_Next, Next, Get_Key, Equal, Hash);
+ pragma Inline (Set_Next, Next, Get_Key, Hash);
-- Subprograms required for instantiation of the htable. See GNAT.HTable.
package Backtrace_Htable is new GNAT.HTable.Static_HTable
@@ -374,7 +374,6 @@
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
use Ada.Exceptions.Traceback;
-
begin
return K1.all = K2.all;
end Equal;
Index: g-memdum.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-memdum.adb,v
retrieving revision 1.1
diff -u -r1.1 g-memdum.adb
--- g-memdum.adb 21 Oct 2003 13:42:03 -0000 1.1
+++ g-memdum.adb 3 Dec 2003 11:41:54 -0000
@@ -66,7 +66,7 @@
Line_Buf : String (1 .. Line_Len);
- Hex : array (0 .. 15) of Character := "0123456789ABCDEF";
+ Hex : constant array (0 .. 15) of Character := "0123456789ABCDEF";
type Char_Ptr is access all Character;
Index: gnatlbr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlbr.adb,v
retrieving revision 1.9
diff -u -r1.9 gnatlbr.adb
--- gnatlbr.adb 21 Nov 2003 10:46:37 -0000 1.9
+++ gnatlbr.adb 3 Dec 2003 11:41:54 -0000
@@ -254,7 +254,8 @@
& F_ADC_File (1 .. F_ADC_File_Len));
Make_Args (6) :=
- new String'("LIBRARY_VERSION=" & '"' & Library_Version & '"');
+ new String'("LIBRARY_VERSION=" & '"' &
+ Verbose_Library_Version & '"');
Make_Args (7) :=
new String'("-f");
Index: g-os_lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-os_lib.ads,v
retrieving revision 1.8
diff -u -r1.8 g-os_lib.ads
--- g-os_lib.ads 20 Nov 2003 09:53:58 -0000 1.8
+++ g-os_lib.ads 3 Dec 2003 11:41:54 -0000
@@ -359,7 +359,7 @@
(FD : File_Descriptor;
offset : Long_Integer;
origin : Integer);
- pragma Import (C, Lseek, "lseek");
+ pragma Import (C, Lseek, "__gnat_lseek");
-- Sets the current file pointer to the indicated offset value,
-- relative to the current position (origin = SEEK_CUR), end of
-- file (origin = SEEK_END), or start of file (origin = SEEK_SET).
Index: g-spipat.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-spipat.adb,v
retrieving revision 1.6
diff -u -r1.6 g-spipat.adb
--- g-spipat.adb 21 Oct 2003 13:42:05 -0000 1.6
+++ g-spipat.adb 3 Dec 2003 11:41:54 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002, Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003, 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- --
@@ -343,30 +343,28 @@
-- structure (i.e. it is a pattern that is guaranteed to match at least
-- one character on success, and not to make any entries on the stack.
- OK_For_Simple_Arbno :
- array (Pattern_Code) of Boolean := (
- PC_Any_CS |
- PC_Any_CH |
- PC_Any_VF |
- PC_Any_VP |
- PC_Char |
- PC_Len_Nat |
- PC_NotAny_CS |
- PC_NotAny_CH |
- PC_NotAny_VF |
- PC_NotAny_VP |
- PC_Span_CS |
- PC_Span_CH |
- PC_Span_VF |
- PC_Span_VP |
- PC_String |
- PC_String_2 |
- PC_String_3 |
- PC_String_4 |
- PC_String_5 |
- PC_String_6 => True,
-
- others => False);
+ OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
+ (PC_Any_CS |
+ PC_Any_CH |
+ PC_Any_VF |
+ PC_Any_VP |
+ PC_Char |
+ PC_Len_Nat |
+ PC_NotAny_CS |
+ PC_NotAny_CH |
+ PC_NotAny_VF |
+ PC_NotAny_VP |
+ PC_Span_CS |
+ PC_Span_CH |
+ PC_Span_VF |
+ PC_Span_VP |
+ PC_String |
+ PC_String_2 |
+ PC_String_3 |
+ PC_String_4 |
+ PC_String_5 |
+ PC_String_6 => True,
+ others => False);
-------------------------------
-- The Pattern History Stack --
Index: g-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-thread.adb,v
retrieving revision 1.4
diff -u -r1.4 g-thread.adb
--- g-thread.adb 21 Oct 2003 13:42:05 -0000 1.4
+++ g-thread.adb 3 Dec 2003 11:41:54 -0000
@@ -81,8 +81,7 @@
(Code : Address;
Parm : Void_Ptr;
Size : Natural;
- Prio : Integer)
- return System.Address
+ Prio : Integer) return System.Address
is
TP : Tptr;
@@ -108,7 +107,6 @@
procedure Unregister_Thread is
Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self;
-
begin
Self_Id.Common.State := Tasking.Terminated;
Destroy_TSD (Self_Id.Common.Compiler_Data);
@@ -150,7 +148,6 @@
procedure Destroy_Thread (Id : Address) is
Tid : constant Task_Id := To_Id (Id);
-
begin
Abort_Task (Tid);
end Destroy_Thread;
@@ -161,9 +158,7 @@
procedure Get_Thread (Id : Address; Thread : Address) is
use System.OS_Interface;
-
- Thr : Thread_Id_Ptr := To_Thread (Thread);
-
+ Thr : constant Thread_Id_Ptr := To_Thread (Thread);
begin
Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
end Get_Thread;
@@ -173,8 +168,7 @@
----------------
function To_Task_Id
- (Id : System.Address)
- return Ada.Task_Identification.Task_Id
+ (Id : System.Address) return Ada.Task_Identification.Task_Id
is
begin
return To_Tid (Id);
Index: lang-specs.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lang-specs.h,v
retrieving revision 1.6
diff -u -r1.6 lang-specs.h
--- lang-specs.h 21 Oct 2003 13:42:09 -0000 1.6
+++ lang-specs.h 3 Dec 2003 11:41:54 -0000
@@ -35,6 +35,7 @@
%{!gnatc*:%{!gnatz*:%{!gnats*:%{!S:%{!c:\
%eone of -c, -S, -gnatc, -gnatz, or -gnats is required for Ada}}}}}\
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
+ %{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.10
diff -u -r1.10 lib-writ.adb
--- lib-writ.adb 20 Nov 2003 09:53:58 -0000 1.10
+++ lib-writ.adb 3 Dec 2003 11:41:54 -0000
@@ -729,7 +729,7 @@
Write_Info_Initiate ('V');
Write_Info_Str (" """);
- Write_Info_Str (Library_Version);
+ Write_Info_Str (Verbose_Library_Version);
Write_Info_Char ('"');
Write_Info_EOL;
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.26
diff -u -r1.26 make.adb
--- make.adb 27 Nov 2003 11:40:45 -0000 1.26
+++ make.adb 3 Dec 2003 11:41:54 -0000
@@ -1356,7 +1356,7 @@
return;
elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /=
- Library_Version
+ Verbose_Library_Version
then
Verbose_Msg (Full_Lib_File, "compiled with old GNAT version");
ALI := No_ALI_Id;
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.15
diff -u -r1.15 sem_attr.adb
--- sem_attr.adb 20 Nov 2003 09:54:00 -0000 1.15
+++ sem_attr.adb 3 Dec 2003 11:41:55 -0000
@@ -1364,7 +1364,8 @@
Error_Attr ("prefix of % attribute must be generic type", N);
elsif Is_Generic_Actual_Type (Entity (P))
- or In_Instance
+ or else In_Instance
+ or else In_Inlined_Body
then
null;
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.12
diff -u -r1.12 sem_prag.adb
--- sem_prag.adb 4 Nov 2003 12:51:46 -0000 1.12
+++ sem_prag.adb 3 Dec 2003 11:41:55 -0000
@@ -9631,6 +9631,12 @@
E_Id := Expression (Arg2);
Analyze (E_Id);
+ if In_Instance_Body
+ and then Nkind (E_Id) = N_Unchecked_Type_Conversion
+ then
+ E_Id := Expression (E_Id);
+ end if;
+
if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg
("second argument of pragma% must be entity name",
Index: sem_warn.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_warn.adb,v
retrieving revision 1.10
diff -u -r1.10 sem_warn.adb
--- sem_warn.adb 21 Oct 2003 13:42:22 -0000 1.10
+++ sem_warn.adb 3 Dec 2003 11:41:55 -0000
@@ -1440,14 +1440,16 @@
when E_Variable =>
-- Case of variable that is assigned but not read. We
- -- suppress the message if the variable is volatile or
- -- has an address clause.
+ -- suppress the message if the variable is volatile,
+ -- has an address clause, or is imported.
if Referenced_As_LHS (E)
and then No (Address_Clause (E))
and then not Is_Volatile (E)
then
- if Warn_On_Modified_Unread then
+ if Warn_On_Modified_Unread
+ and then not Is_Imported (E)
+ then
Error_Msg_N
("variable & is assigned but never read?", E);
end if;
Index: s-geveop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-geveop.adb,v
retrieving revision 1.1
diff -u -r1.1 s-geveop.adb
--- s-geveop.adb 21 Oct 2003 13:42:14 -0000 1.1
+++ s-geveop.adb 3 Dec 2003 11:41:55 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2003 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 @@
function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_Ptr);
- SA : Address := XA + ((Length + 0) / VU * VU
+ SA : constant Address := XA + ((Length + 0) / VU * VU
and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing
@@ -102,7 +102,7 @@
function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_Ptr);
- SA : Address := XA + ((Length + 0) / VU * VU
+ SA : constant Address := XA + ((Length + 0) / VU * VU
and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing
Index: s-interr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-interr.adb,v
retrieving revision 1.7
diff -u -r1.7 s-interr.adb
--- s-interr.adb 21 Oct 2003 13:42:14 -0000 1.7
+++ s-interr.adb 3 Dec 2003 11:41:55 -0000
@@ -598,7 +598,7 @@
Ptr := Registered_Handler_Head;
- while (Ptr /= null) loop
+ while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
@@ -946,7 +946,7 @@
Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
end if;
- if (New_Handler = null) then
+ if New_Handler = null then
if Old_Handler /= null then
Unbind_Handler (Interrupt);
end if;
Index: s-taskin.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-taskin.adb,v
retrieving revision 1.5
diff -u -r1.5 s-taskin.adb
--- s-taskin.adb 21 Oct 2003 13:42:15 -0000 1.5
+++ s-taskin.adb 3 Dec 2003 11:41:55 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, 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- --
@@ -122,7 +122,7 @@
All_Tasks_List := T;
end Initialize_ATCB;
- Main_Task_Image : String := "main_task";
+ Main_Task_Image : constant String := "main_task";
-- Image of environment task.
Main_Priority : Integer;
Index: s-tassta.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-tassta.adb,v
retrieving revision 1.6
diff -u -r1.6 s-tassta.adb
--- s-tassta.adb 21 Oct 2003 13:42:15 -0000 1.6
+++ s-tassta.adb 3 Dec 2003 11:41:55 -0000
@@ -1089,7 +1089,8 @@
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
- Excep : Exception_Occurrence_Access := SSL.Get_Current_Excep.all;
+ Excep : constant Exception_Occurrence_Access :=
+ SSL.Get_Current_Excep.all;
begin
-- This procedure is called by the task outermost handler in
Index: tb-alvms.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/tb-alvms.c,v
retrieving revision 1.3
diff -u -r1.3 tb-alvms.c
--- tb-alvms.c 31 Oct 2003 01:08:43 -0000 1.3
+++ tb-alvms.c 3 Dec 2003 11:41:55 -0000
@@ -40,33 +40,38 @@
document, sections of which we will refer to as ABI-<section_number>. */
#include <pdscdef.h>
+#include <libicb.h>
+#include <chfctxdef.h>
+#include <chfdef.h>
-/* We still use a number of macros similar to the ones for the generic
- __gnat_backtrace implementation. */
-#define SKIP_FRAME 1
-#define PC_ADJUST -4
-
-#define STOP_FRAME (frame_state.saved_ra == RA_STOP)
-
-/* Mask for PDSC$V_BASE_FRAME in procedure descriptors, missing from the
- header file included above. */
+/* A couple of items missing from the header file included above. */
+extern void * SYS$GL_CALL_HANDL;
#define PDSC$M_BASE_FRAME (1 << 10)
-typedef unsigned long REG;
-
-#define REG_AT(address) (*(REG *)(address))
+/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */
+typedef void * ADDR;
+typedef unsigned long long REG;
+
+#define REG_AT(addr) (*(REG *)(addr))
+
+#define AS_REG(addr) ((REG)(unsigned long)(addr))
+#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg))
+#define ADDR_IN(reg) (AS_ADDR(reg))
/* The following structure defines the state maintained during the
unwinding process. */
typedef struct
{
- void * pc; /* Address of the call insn involved in the chain. */
- void * sp; /* Stack Pointer at the time of this call. */
- void * fp; /* Frame Pointer at the time of this call. */
+ ADDR pc; /* Address of the call insn involved in the chain. */
+ ADDR sp; /* Stack Pointer at the time of this call. */
+ ADDR fp; /* Frame Pointer at the time of this call. */
+
+ /* The values above are fetched as saved REGisters on the stack. They are
+ typed ADDR because this is what the values in those registers are. */
/* Values of the registers saved by the functions in the chain,
- incrementally updated through consecutive calls to the "unwind"
- function below. */
+ incrementally updated through consecutive calls to the "unwind" function
+ below. */
REG saved_regs [32];
} frame_state_t;
@@ -79,69 +84,111 @@
This is from ABI-3.1.1 [Integer Registers]. */
-#define saved_fp saved_regs[29]
-#define saved_sp saved_regs[30]
-#define saved_ra saved_regs[26]
-#define saved_pv saved_regs[27]
+#define saved_fpr saved_regs[29]
+#define saved_spr saved_regs[30]
+#define saved_rar saved_regs[26]
+#define saved_pvr saved_regs[27]
-/* Special values for saved_ra, used to control the overall unwinding
+/* Special values for saved_rar, used to control the overall unwinding
process. */
#define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((REG)0)
-/* Compute Procedure Value from a live Frame Pointer value. */
+/* We still use a number of macros similar to the ones for the generic
+ __gnat_backtrace implementation. */
+#define PC_ADJUST 4
+#define STOP_FRAME (frame_state.saved_rar == RA_STOP)
+
+/* Compute Procedure Value from Frame Pointer value. This follows the rules
+ in ABI-3.6.1 [Current Procedure]. */
#define PV_FOR(FP) \
- ((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP);
+ (((FP) != 0) \
+ ? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0)
+
/**********
* unwind *
**********/
-/* Helper for __gnat_backtrace. Update FS->pc/sp/fp to represent the
- state computed in FS->saved_regs during the previous call, and update
- FS->saved_regs in preparation of the next call. */
+/* Helper for __gnat_backtrace.
+
+ FS represents some call frame, identified by a pc and associated frame
+ pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the
+ general registers upon entry in this frame. Of most interest in this set
+ are the saved return address and frame pointer registers, which actually
+ allow identifying the caller's frame.
+
+ This routine "unwinds" the input frame state by adjusting it to eventually
+ represent its caller's frame. The basic principle is to shift the fp and pc
+ saved values into the current state, and then compute the corresponding new
+ saved registers set.
+
+ If the call chain goes through a signal handler, special processing is
+ required when we process the kernel frame which has called the handler, to
+ switch it to the interrupted context frame. */
+
+#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL)
+
+static void unwind_regular_code (frame_state_t * fs);
+static void unwind_kernel_handler (frame_state_t * fs);
void
unwind (frame_state_t * fs)
{
- REG frame_base;
- PDSCDEF * pv;
-
/* Don't do anything if requested so. */
- if (fs->saved_ra == RA_STOP)
+ if (fs->saved_rar == RA_STOP)
return;
/* Retrieve the values of interest computed during the previous
call. PC_ADJUST gets us from the return address to the call insn
address. */
- fs->pc = (void *) fs->saved_ra + PC_ADJUST;
- fs->sp = (void *) fs->saved_sp;
- fs->fp = (void *) fs->saved_fp;
+ fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST;
+ fs->sp = ADDR_IN (fs->saved_spr);
+ fs->fp = ADDR_IN (fs->saved_fpr);
/* Unless we are able to determine otherwise, set the frame state's
saved return address such that the unwinding process will stop. */
- fs->saved_ra = RA_STOP;
+ fs->saved_rar = RA_STOP;
- /* Now we want to update fs->saved_regs to reflect what the procedure
- described by pc/fp/sp has done. */
+ /* Now we want to update fs->saved_regs to reflect the state of the caller
+ of the procedure described by pc/fp.
- /* Compute the corresponding "procedure value", following the rules in
- ABI-3.6.1 [Current Procedure]. Return immediatly if this value mandates
- us to stop. */
- if (fs->fp == 0)
- return;
+ The condition to check for a special kernel frame which has called a
+ signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame
+ of the call to the handler can be identified by the return address of
+ SYS$CALL_HANDL+4". We use the equivalent procedure value identification
+ here because SYS$CALL_HANDL appears to be undefined. */
+
+ if (K_HANDLER_FRAME (fs))
+ unwind_kernel_handler (fs);
+ else
+ unwind_regular_code (fs);
+}
+
+/***********************
+ * unwind_regular_code *
+ ***********************/
- pv = PV_FOR (fs->fp);
+/* Helper for unwind, for the case of unwinding through regular code which
+ is not a signal handler. */
+
+static void
+unwind_regular_code (frame_state_t * fs)
+{
+ PDSCDEF * pv = PV_FOR (fs->fp);
+
+ ADDR frame_base;
+
+ /* Use the procedure value to unwind, in a way depending on the kind of
+ procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4
+ [Procedure Types]. */
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
return;
- /* Use the procedure value to unwind, in a way depending on the kind of
- procedure at hand. This is based on ABI-3.3 [Procedure Representation]
- and ABI-3.4 [Procedure Types]. */
frame_base
- = (REG) ((pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp);
+ = (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp;
switch (pv->pdsc$w_flags & 0xf)
{
@@ -149,21 +196,21 @@
/* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
from the Register Save Area in the frame. */
{
- REG rsa_base = frame_base + pv->pdsc$w_rsa_offset;
+ ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset;
int i, j;
- fs->saved_ra = REG_AT (rsa_base);
- fs->saved_pv = REG_AT (frame_base);
-
+ fs->saved_rar = REG_AT (rsa_base);
+ fs->saved_pvr = REG_AT (frame_base);
+
for (i = 0, j = 0; i < 32; i++)
if (pv->pdsc$l_ireg_mask & (1 << i))
fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
- /* Note that the loop above is guaranteed to set fs->saved_fp, because
- "The preserved register set must always include R29(FP) since it
- will always be used." (ABI-3.4.3.4 [Register Save Area for All
- Stack Frames]).
-
+ /* Note that the loop above is guaranteed to set fs->saved_fpr,
+ because "The preserved register set must always include R29(FP)
+ since it will always be used." (ABI-3.4.3.4 [Register Save Area for
+ All Stack Frames]).
+
Also note that we need to run through all the registers to ensure
that unwinding through register procedures (see below) gets the
right values out of the saved_regs array. */
@@ -174,8 +221,8 @@
/* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
the registers where they have been saved. */
{
- fs->saved_ra = fs->saved_regs[pv->pdsc$b_save_ra];
- fs->saved_fp = fs->saved_regs[pv->pdsc$b_save_fp];
+ fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra];
+ fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp];
}
break;
@@ -187,19 +234,111 @@
/* SP is actually never part of the saved registers area, so we use the
corresponding entry in the saved_regs array to manually keep track of
it's evolution. */
- fs->saved_sp = frame_base + pv->pdsc$l_size;
+ fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size;
+}
+
+/*************************
+ * unwind_kernel_handler *
+ *************************/
+
+/* Helper for unwind, for the specific case of unwinding through a signal
+ handler.
+
+ The input frame state describes the kernel frame which has called a signal
+ handler. We fill the corresponding saved_regs to have it's "caller" frame
+ represented as the interrupted context. */
+
+static void
+unwind_kernel_handler (frame_state_t * fs)
+{
+ PDSCDEF * pv = PV_FOR (fs->fp);
+
+ CHFDEF1 *sigargs;
+ CHFDEF2 *mechargs;
+
+ /* Retrieve the arguments passed to the handler, by way of a VMS service
+ providing the corresponding "Invocation Context Block". */
+ {
+ long handler_ivhandle;
+ INVO_CONTEXT_BLK handler_ivcb;
+
+ CHFCTX *chfctx;
+
+ handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp);
+ handler_ivcb.libicb$q_ireg [30] = 0;
+
+ handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb);
+
+ if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1)
+ return;
+
+ chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr);
+
+ sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst);
+ mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst);
+ }
+
+ /* Compute the saved return address as the PC of the instruction causing the
+ condition, accounting for the fact that it will be adjusted by the next
+ call to "unwind" as if it was an actual call return address. */
+ {
+ /* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address
+ is available from the sigargs argument to the handler, designed to
+ support both 32 and 64 bit addresses. The initial reference we get
+ is a pointer to the 32bit form, from which one may extract a pointer
+ to the 64bit version if need be. We work directly from the 32bit
+ form here. */
+
+ /* The sigargs vector structure for 32bits addresses is:
+
+ <......32bit......>
+ +-----------------+
+ | Vsize | :chf$is_sig_args
+ +-----------------+ -+-
+ | Condition Value | : [0]
+ +-----------------+ :
+ | ... | :
+ +-----------------+ : vector of Vsize entries
+ | Signal PC | :
+ +-----------------+ :
+ | PS | : [Vsize - 1]
+ +-----------------+ -+-
+
+ */
+
+ unsigned long * sigargs_vector
+ = ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1;
+
+ long sigargs_vsize
+ = sigargs->chf$is_sig_args;
+
+ fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST;
+ }
+
+ fs->saved_spr = RA_UNKNOWN;
+ fs->saved_fpr = (REG) mechargs->chf$q_mch_frame;
+ fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27;
+
+ fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16;
+ fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17;
+ fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18;
+ fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19;
+ fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20;
}
/* Structure representing a traceback entry in the tracebacks array to be
filled by __gnat_backtrace below.
+ !! This should match what is in System.Traceback_Entries, so beware of
+ !! the REG/ADDR difference here.
+
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
typedef struct {
- void * pc;
- void * pv;
+ ADDR pc;
+ ADDR pv;
} tb_entry_t;
/********************
@@ -207,11 +346,8 @@
********************/
int
-__gnat_backtrace (void **array,
- int size,
- void *exclude_min,
- void *exclude_max,
- int skip_frames)
+__gnat_backtrace (void **array, int size,
+ void *exclude_min, void *exclude_max, int skip_frames)
{
int cnt;
@@ -223,9 +359,9 @@
register REG this_FP __asm__("$29");
register REG this_SP __asm__("$30");
- frame_state.saved_fp = this_FP;
- frame_state.saved_sp = this_SP;
- frame_state.saved_ra = RA_UNKNOWN;
+ frame_state.saved_fpr = this_FP;
+ frame_state.saved_spr = this_SP;
+ frame_state.saved_rar = RA_UNKNOWN;
unwind (&frame_state);
@@ -239,15 +375,18 @@
cnt = 0;
while (cnt < size)
{
+ PDSCDEF * pv = PV_FOR (frame_state.fp);
+
+ /* Stop if either the frame contents or the unwinder say so. */
if (STOP_FRAME)
break;
- if (frame_state.pc < exclude_min
- || frame_state.pc > exclude_max)
+ if (! K_HANDLER_FRAME (&frame_state)
+ && (frame_state.pc < exclude_min || frame_state.pc > exclude_max))
{
- tbe->pc = frame_state.pc;
- tbe->pv = PV_FOR (frame_state.fp);
-
+ tbe->pc = (ADDR) frame_state.pc;
+ tbe->pv = (ADDR) PV_FOR (frame_state.fp);
+
cnt ++;
tbe ++;
}
Index: gnatvsn.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatvsn.ads,v
retrieving revision 1.132
diff -u -r1.132 gnatvsn.ads
--- gnatvsn.ads 10 Nov 2003 17:30:00 -0000 1.132
+++ gnatvsn.ads 3 Dec 2003 11:41:55 -0000
@@ -71,13 +71,16 @@
-- value should never be decreased in the future, but it would be
-- OK to increase it if absolutely necessary.
- Library_Version : constant String := "GNAT Lib v3.4";
+ Library_Version : constant String := "3.4";
-- Library version. This value must be updated whenever any change to the
-- compiler affects the library formats in such a way as to obsolete
-- previously compiled library modules.
--
-- Note: Makefile.in relies on the precise format of the library version
-- string in order to correctly construct the soname value.
+
+ Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version;
+ -- Version string stored in e.g. ALI files.
ASIS_Version_Number : constant := 2;
-- ASIS Version. This is used to check for consistency between the compiler
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.56
diff -u -r1.56 Makefile.in
--- Makefile.in 1 Dec 2003 13:29:27 -0000 1.56
+++ Makefile.in 3 Dec 2003 11:41:55 -0000
@@ -375,6 +375,8 @@
../../libiberty/xstrdup.o \
../../libiberty/xexit.o
+LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
+
# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
# $(strip STRING) removes leading and trailing spaces from STRING.
# If what's left is null then it's a match.
@@ -450,7 +452,7 @@
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
@@ -692,8 +694,7 @@
system.ads<59system.ads
LIBGNAT_TARGET_PAIRS = \
- $(HIE_NONE_TARGET_PAIRS) \
- $(EXTRA_HIE_NONE_TARGET_PAIRS)
+ $(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
@@ -701,8 +702,7 @@
system.ads<5rsystem.ads
LIBGNAT_TARGET_PAIRS = \
- $(HIE_NONE_TARGET_PAIRS) \
- $(EXTRA_HIE_NONE_TARGET_PAIRS)
+ $(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
@@ -819,7 +819,7 @@
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@@ -903,7 +903,7 @@
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
@@ -912,7 +912,7 @@
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \
s-osinte.adb<5iosinte.adb \
s-osinte.ads<5iosinte.ads \
@@ -929,7 +929,7 @@
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@@ -937,7 +937,7 @@
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \
s-osinte.adb<7sosinte.adb \
s-osinte.ads<5losinte.ads \
@@ -967,7 +967,7 @@
system.ads<56system.ads
THREADSLIB=
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
@@ -1021,7 +1021,7 @@
MISCLIB = -lexc
SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
@@ -1069,7 +1069,7 @@
SO_OPTS = -Wl,+h,
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-dual
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@@ -1220,7 +1220,7 @@
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
@@ -1290,8 +1290,7 @@
../../gnatlbr$(exeext) \
,,/../gnatsym$(exeext)
# This command transforms (YYYYMMDD) into YY,MMDD
- GSMATCH_VERSION := $(shell grep "^ *Gnat_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/' -e 's/\./_/g'))
+ GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
endif
@@ -1328,14 +1327,14 @@
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
soext = .dll
GNATLIB_SHARED = gnatlib-shared-win32
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \
@@ -1349,14 +1348,14 @@
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \
@@ -1370,7 +1369,7 @@
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
# The runtime library for gnat comprises two directories. One contains the
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-12-01 13:30 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-12-01 13:30 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-12-01 Nicolas Setton <setton@act-europe.fr>
* a-except.adb (Raise_Current_Excep): Add a pragma Inspection_Point,
so that the debugger can reliably access the value of the parameter,
and therefore is able to display the exception name when an exception
breakpoint is reached.
2003-12-01 Thomas Quinot <quinot@act-europe.fr>
* fmap.adb: Fix typo in warning message.
* g-socket.ads, g-socket.adb: Make Free a visible instance of
Ada.Unchecked_Deallocation (no need to wrap it in a subprogram).
2003-12-01 Vincent Celier <celier@gnat.com>
* mlib-prj.adb (Build_Library.Process): Do not check a withed unit if
ther is no Afile.
(Build_Library): Get the switches only if Default_Switches is declared
in package Binder.
2003-12-01 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Expand_Actuals): When applying validity checks to
actuals that are indexed components, reanalyze actual to ensure that
packed array references are properly expanded.
* sem_ch5.adb (Diagnose_Non_Variable_Lhs): Add special case for
attempted assignment to a discriminant.
2003-12-01 Robert Dewar <dewar@gnat.com>
* rtsfind.adb, exp_ch4.adb, s-exnint.ads, s-exnint.adb: Minor
reformatting.
* switch-c.adb: Minor reformatting of comments
2003-12-01 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.in: Clean ups.
2003-12-01 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: a-except.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-except.adb,v
retrieving revision 1.9
diff -u -p -r1.9 a-except.adb
--- a-except.adb 21 Oct 2003 13:41:53 -0000 1.9
+++ a-except.adb 1 Dec 2003 11:35:59 -0000
@@ -859,6 +859,8 @@ package body Ada.Exceptions is
-------------------------
procedure Raise_Current_Excep (E : Exception_Id) is
+ pragma Inspection_Point (E);
+ -- This is so the debugger can reliably inspect the parameter
begin
Process_Raise_Exception (E => E, From_Signal_Handler => False);
end Raise_Current_Excep;
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_ch4.adb
--- exp_ch4.adb 27 Nov 2003 11:40:45 -0000 1.12
+++ exp_ch4.adb 1 Dec 2003 11:35:59 -0000
@@ -5349,6 +5349,7 @@ package body Exp_Ch4 is
function Is_Procedure_Actual (N : Node_Id) return Boolean is
Par : Node_Id := Parent (N);
+
begin
while Present (Par)
and then Nkind (Par) not in N_Statement_Other_Than_Procedure_Call
@@ -5448,8 +5449,9 @@ package body Exp_Ch4 is
-- with generating the error message).
if not Is_Packed (Typ) then
- -- apply transformation for actuals of a function call, where
- -- Expand_Actuals is not used.
+
+ -- Apply transformation for actuals of a function call,
+ -- where Expand_Actuals is not used.
if Nkind (Parent (N)) = N_Function_Call
and then Is_Possibly_Unaligned_Slice (N)
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.13
diff -u -p -r1.13 exp_ch6.adb
--- exp_ch6.adb 27 Nov 2003 11:40:45 -0000 1.13
+++ exp_ch6.adb 1 Dec 2003 11:35:59 -0000
@@ -547,8 +547,9 @@ package body Exp_Ch6 is
Var := Make_Var (Expression (Actual));
- Crep := not Same_Representation
- (Etype (Formal), Etype (Expression (Actual)));
+ Crep := not Same_Representation
+ (Etype (Formal), Etype (Expression (Actual)));
+
else
V_Typ := Etype (Actual);
Var := Make_Var (Actual);
@@ -1528,8 +1529,16 @@ package body Exp_Ch6 is
if Validity_Checks_On then
if Ekind (Formal) = E_In_Parameter
and then Validity_Check_In_Params
- and then Is_Entity_Name (Actual)
then
+ -- If the actual is an indexed component of a packed
+ -- type, it has not been expanded yet. It will be
+ -- copied in the validity code that follows, and has
+ -- to be expanded appropriately, so reanalyze it.
+
+ if Nkind (Actual) = N_Indexed_Component then
+ Set_Analyzed (Actual, False);
+ end if;
+
Ensure_Valid (Actual);
elsif Ekind (Formal) = E_In_Out_Parameter
Index: fmap.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/fmap.adb,v
retrieving revision 1.7
diff -u -p -r1.7 fmap.adb
--- fmap.adb 21 Oct 2003 13:41:59 -0000 1.7
+++ fmap.adb 1 Dec 2003 11:35:59 -0000
@@ -292,7 +292,7 @@ package body Fmap is
then
Write_Str ("warning: mapping file """);
Write_Str (File_Name);
- Write_Line (""" is incorrectly formated");
+ Write_Line (""" is incorrectly formatted");
Empty_Tables;
return;
end if;
Index: g-socket.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.adb,v
retrieving revision 1.7
diff -u -p -r1.7 g-socket.adb
--- g-socket.adb 27 Nov 2003 11:40:45 -0000 1.7
+++ g-socket.adb 1 Dec 2003 11:35:59 -0000
@@ -34,7 +34,6 @@
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings;
@@ -777,17 +776,6 @@ package body GNAT.Sockets is
Thin.Finalize;
end if;
end Finalize;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Stream : in out Stream_Access) is
- procedure Do_Free is new Ada.Unchecked_Deallocation
- (Ada.Streams.Root_Stream_Type'Class, Stream_Access);
- begin
- Do_Free (Stream);
- end Free;
---------
-- Get --
Index: g-socket.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.ads,v
retrieving revision 1.8
diff -u -p -r1.8 g-socket.ads
--- g-socket.ads 27 Nov 2003 11:40:45 -0000 1.8
+++ g-socket.ads 1 Dec 2003 11:35:59 -0000
@@ -54,6 +54,7 @@
with Ada.Exceptions;
with Ada.Streams;
+with Ada.Unchecked_Deallocation;
with System;
@@ -902,10 +903,11 @@ package GNAT.Sockets is
-- Return the socket address from which the last message was
-- received.
- procedure Free (Stream : in out Stream_Access);
- -- Destroy a stream created by one of the Stream functions above, and
- -- release associated resources. The user is responsible for calling
- -- this subprogram when the stream is not needed anymore.
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Ada.Streams.Root_Stream_Type'Class, Stream_Access);
+ -- Destroy a stream created by one of the Stream functions above,
+ -- releasing the corresponding resources. The user is responsible
+ -- for calling this subprogram when the stream is not needed anymore.
type Socket_Set_Type is limited private;
-- This type allows to manipulate sets of sockets. It allows to
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.6
diff -u -p -r1.6 mlib-prj.adb
--- mlib-prj.adb 27 Nov 2003 11:40:45 -0000 1.6
+++ mlib-prj.adb 1 Dec 2003 11:35:59 -0000
@@ -576,7 +576,7 @@ package body MLib.Prj is
for W in Unit_Data.First_With .. Unit_Data.Last_With loop
Afile := Withs.Table (W).Afile;
- if Library_ALIs.Get (Afile)
+ if Afile /= No_Name and then Library_ALIs.Get (Afile)
and then not Processed_ALIs.Get (Afile)
then
if not Interface_ALIs.Get (Afile) then
@@ -811,9 +811,10 @@ package body MLib.Prj is
declare
Binder_Package : constant Package_Id :=
- Value_Of
- (Name => Name_Binder,
- In_Packages => Data.Decl.Packages);
+ Value_Of
+ (Name => Name_Binder,
+ In_Packages => Data.Decl.Packages);
+
begin
if Binder_Package /= No_Package then
declare
@@ -823,20 +824,26 @@ package body MLib.Prj is
In_Arrays =>
Packages.Table
(Binder_Package).Decl.Arrays);
- Switches : Variable_Value :=
- Value_Of
- (Index => Name_Ada, In_Array => Defaults);
+ Switches : Variable_Value := Nil_Variable_Value;
+
Switch : String_List_Id := Nil_String;
- begin
- if not Switches.Default then
- Switch := Switches.Values;
- while Switch /= Nil_String loop
- Add_Argument
- (Get_Name_String
- (String_Elements.Table (Switch).Value));
- Switch := String_Elements.Table (Switch).Next;
- end loop;
+ begin
+ if Defaults /= No_Array_Element then
+ Switches :=
+ Value_Of
+ (Index => Name_Ada, In_Array => Defaults);
+
+ if not Switches.Default then
+ Switch := Switches.Values;
+
+ while Switch /= Nil_String loop
+ Add_Argument
+ (Get_Name_String
+ (String_Elements.Table (Switch).Value));
+ Switch := String_Elements.Table (Switch).Next;
+ end loop;
+ end if;
end if;
end;
end if;
Index: rtsfind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/rtsfind.adb,v
retrieving revision 1.9
diff -u -p -r1.9 rtsfind.adb
--- rtsfind.adb 20 Nov 2003 09:54:00 -0000 1.9
+++ rtsfind.adb 1 Dec 2003 11:35:59 -0000
@@ -550,7 +550,6 @@ package body Rtsfind is
declare
Loaded : Boolean;
pragma Warnings (Off, Loaded);
-
begin
Loaded := Is_Loaded (U.Uname);
end;
@@ -569,7 +568,6 @@ package body Rtsfind is
if U.Unum = No_Unit then
Load_Fail ("not found", U_Id, Id);
-
elsif Fatal_Error (U.Unum) then
Load_Fail ("had parser errors", U_Id, Id);
end if;
@@ -601,7 +599,6 @@ package body Rtsfind is
Set_Analyzed (Cunit (Current_Sem_Unit), True);
if not Analyzed (Cunit (U.Unum)) then
-
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
Index: sem_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch5.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_ch5.adb
--- sem_ch5.adb 10 Nov 2003 17:29:59 -0000 1.10
+++ sem_ch5.adb 1 Dec 2003 11:35:59 -0000
@@ -115,11 +115,9 @@ package body Sem_Ch5 is
-- Some special bad cases of entity names
elsif Is_Entity_Name (N) then
-
if Ekind (Entity (N)) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
- return;
-- Private declarations in a protected object are turned into
-- constants when compiling a protected function.
@@ -133,27 +131,38 @@ package body Sem_Ch5 is
then
Error_Msg_N
("protected function cannot modify protected object", N);
- return;
elsif Ekind (Entity (N)) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
- return;
+ else
+ Error_Msg_N
+ ("left hand side of assignment must be a variable", N);
end if;
- -- For indexed components, or selected components, test prefix
+ -- For indexed components or selected components, test prefix
- elsif Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Selected_Component
- then
+ elsif Nkind (N) = N_Indexed_Component then
Diagnose_Non_Variable_Lhs (Prefix (N));
- return;
- end if;
- -- If we fall through, we have no special message to issue!
+ -- Another special case for assignment to discriminant.
+
+ elsif Nkind (N) = N_Selected_Component then
+ if Present (Entity (Selector_Name (N)))
+ and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
+ then
+ Error_Msg_N
+ ("assignment to discriminant not allowed", N);
+ else
+ Diagnose_Non_Variable_Lhs (Prefix (N));
+ end if;
+
+ else
+ -- If we fall through, we have no special message to issue!
- Error_Msg_N ("left hand side of assignment must be a variable", N);
+ Error_Msg_N ("left hand side of assignment must be a variable", N);
+ end if;
end Diagnose_Non_Variable_Lhs;
-------------------------
@@ -396,7 +405,6 @@ package body Sem_Ch5 is
(Nkind (Rhs) /= N_Type_Conversion
or else Is_Constrained (Etype (Rhs)))
then
-
-- Assignment verifies that the length of the Lsh and Rhs are equal,
-- but of course the indices do not have to match. If the right-hand
-- side is a type conversion to an unconstrained type, a length check
@@ -597,7 +605,7 @@ package body Sem_Ch5 is
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Statements);
use Case_Choices_Processing;
- -- Instantiation of the generic choice processing package.
+ -- Instantiation of the generic choice processing package
-----------------------------
-- Non_Static_Choice_Error --
@@ -668,11 +676,10 @@ package body Sem_Ch5 is
return;
end if;
- -- If the case expression is a formal object of mode in out,
- -- then treat it as having a nonstatic subtype by forcing
- -- use of the base type (which has to get passed to
- -- Check_Case_Choices below). Also use base type when
- -- the case expression is parenthesized.
+ -- If the case expression is a formal object of mode in out, then
+ -- treat it as having a nonstatic subtype by forcing use of the base
+ -- type (which has to get passed to Check_Case_Choices below). Also
+ -- use base type when the case expression is parenthesized.
if Paren_Count (Exp) > 0
or else (Is_Entity_Name (Exp)
@@ -681,7 +688,7 @@ package body Sem_Ch5 is
Exp_Type := Exp_Btype;
end if;
- -- Call the instantiated Analyze_Choices which does the rest of the work
+ -- Call instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
(N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
@@ -778,7 +785,7 @@ package body Sem_Ch5 is
end if;
end loop;
- -- Verify that if present the condition is a Boolean expression.
+ -- Verify that if present the condition is a Boolean expression
if Present (Cond) then
Analyze_And_Resolve (Cond, Any_Boolean);
@@ -991,7 +998,6 @@ package body Sem_Ch5 is
procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
Id : constant Node_Id := Defining_Identifier (N);
-
begin
Enter_Name (Id);
Set_Ekind (Id, E_Label);
@@ -1003,7 +1009,6 @@ package body Sem_Ch5 is
-- Analyze_Iteration_Scheme --
------------------------------
-
procedure Analyze_Iteration_Scheme (N : Node_Id) is
procedure Check_Controlled_Array_Attribute (DS : Node_Id);
-- If the bounds are given by a 'Range reference on a function call
@@ -1101,7 +1106,6 @@ package body Sem_Ch5 is
declare
H : constant Entity_Id := Homonym (Id);
-
begin
if Present (H)
and then Enclosing_Dynamic_Scope (H) =
@@ -1248,7 +1252,6 @@ package body Sem_Ch5 is
procedure Analyze_Label (N : Node_Id) is
pragma Warnings (Off, N);
-
begin
Kill_Current_Values;
end Analyze_Label;
@@ -1329,7 +1332,6 @@ package body Sem_Ch5 is
procedure Analyze_Null_Statement (N : Node_Id) is
pragma Warnings (Off, N);
-
begin
null;
end Analyze_Null_Statement;
Index: s-exnint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-exnint.adb,v
retrieving revision 1.1
diff -u -p -r1.1 s-exnint.adb
--- s-exnint.adb 21 Oct 2003 13:42:13 -0000 1.1
+++ s-exnint.adb 1 Dec 2003 11:35:59 -0000
@@ -37,11 +37,7 @@ package body System.Exn_Int is
-- Exn_Integer --
-----------------
- function Exn_Integer
- (Left : Integer;
- Right : Natural)
- return Integer
- is
+ function Exn_Integer (Left : Integer; Right : Natural) return Integer is
pragma Suppress (Division_Check);
pragma Suppress (Overflow_Check);
Index: s-exnint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-exnint.ads,v
retrieving revision 1.5
diff -u -p -r1.5 s-exnint.ads
--- s-exnint.ads 21 Oct 2003 13:42:13 -0000 1.5
+++ s-exnint.ads 1 Dec 2003 11:35:59 -0000
@@ -36,9 +36,6 @@
package System.Exn_Int is
pragma Pure (Exn_Int);
- function Exn_Integer
- (Left : Integer;
- Right : Natural)
- return Integer;
+ function Exn_Integer (Left : Integer; Right : Natural) return Integer;
end System.Exn_Int;
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.7
diff -u -p -r1.7 switch-c.adb
--- switch-c.adb 10 Nov 2003 17:30:00 -0000 1.7
+++ switch-c.adb 1 Dec 2003 11:35:59 -0000
@@ -296,20 +296,21 @@ package body Switch.C is
Xref_Active := False;
Set_Debug_Flag ('g');
- -- Processing for e switch
+ -- -gnate? (extended switches)
when 'e' =>
- -- Only -gnateD and -gnatep= are stored
-
Ptr := Ptr + 1;
+ -- The -gnate? switches are all double character switches
+ -- so we must always have a character after the e.
+
if Ptr > Max then
raise Bad_Switch;
end if;
case Switch_Chars (Ptr) is
- -- Configuration pragmas
+ -- -gnatec (configuration pragmas)
when 'c' =>
Store_Switch := False;
@@ -359,7 +360,7 @@ package body Switch.C is
return;
- -- Symbol definition
+ -- -gnateD switch (symbol definition)
when 'D' =>
Store_Switch := False;
@@ -381,7 +382,7 @@ package body Switch.C is
(Storing'First .. First_Stored + Max - Ptr + 2));
return;
- -- Full source path for brief error messages
+ -- -gnatef (full source path for brief error messages)
when 'f' =>
Store_Switch := False;
@@ -389,7 +390,7 @@ package body Switch.C is
Full_Path_Name_For_Brief_Errors := True;
return;
- -- Mapping file
+ -- -gnatem (mapping file)
when 'm' =>
Store_Switch := False;
@@ -410,7 +411,7 @@ package body Switch.C is
new String'(Switch_Chars (Ptr .. Max));
return;
- -- Preprocessing data file
+ -- -gnatep (preprocessing data file)
when 'p' =>
Store_Switch := False;
@@ -445,19 +446,21 @@ package body Switch.C is
Store_Compilation_Switch (To_Store);
end;
- return;
+ return;
+
+ -- All other -gnate? switches are unassigned
when others =>
raise Bad_Switch;
end case;
- -- Processing for E switch
+ -- -gnatE (dynamic elaboration checks)
when 'E' =>
Ptr := Ptr + 1;
Dynamic_Elaboration_Checks := True;
- -- Processing for f switch
+ -- -gnatf (full error messages)
when 'f' =>
Ptr := Ptr + 1;
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.59
diff -u -p -r1.59 Make-lang.in
--- Make-lang.in 29 Nov 2003 23:57:40 -0000 1.59
+++ Make-lang.in 1 Dec 2003 11:36:00 -0000
@@ -1417,17 +1417,17 @@ ada/cstand.o : ada/ada.ads ada/a-except.
ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \
ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
- ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \
- ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
- ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
- ada/widechar.ads
+ ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \
+ ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
+ ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/urealp.adb ada/widechar.ads
ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads
@@ -2305,7 +2305,8 @@ ada/gnatbind.o : ada/ada.ads ada/a-excep
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads
-ada/gnatvsn.o : ada/gnatvsn.ads ada/gnatvsn.adb ada/system.ads
+ada/gnatvsn.o : ada/gnatvsn.ads ada/gnatvsn.adb ada/system.ads \
+ ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/hlo.o : ada/hlo.ads ada/hlo.adb ada/output.ads ada/system.ads \
ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \
@@ -2533,9 +2534,11 @@ ada/nmake.o : ada/ada.ads ada/a-except.a
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads
-ada/opt.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ada/opt.o : ada/ada.ads ada/a-except.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads \
+ ada/opt.adb ada/system.ads ada/s-exctab.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-27 13:11 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-27 13:11 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-11-26 Arnaud Charlet <charlet@act-europe.fr>
(Cond_Timed_Wait): Introduce new constant Time_Out_Max,
since NT 4 cannot handle timeout values that are too large,
e.g. DWORD'Last - 1.
2003-11-26 Ed Schonberg <schonberg@gnat.com>
* exp_ch4.adb:
(Expand_N_Slice): Recognize all cases of slices that appear as actuals
in procedure calls and whose expansion must be deferred.
* exp_ch6.adb (Add_Call_By_Copy_Node): Remove previous fix. Proper fix
is in exp_ch4.
* sem_ch3.adb:
(Build_Derived_Array_Type): Create operator for unconstrained type
if ancestor is unconstrained.
2003-11-26 Vincent Celier <celier@gnat.com>
* make.adb (Project_Object_Directory): New global variable
(Change_To_Object_Directory): New procedure
(Collect_Arguments_And_Compile): Call Change_To_Object_Directory instead
of Change_Dir directly. Do not change working directory to object
directory of main project after each compilation.
(Gnatmake): Use Change_To_Object_Directory instead of Change_Dir
directly.
Change to object directory of main project before binding step.
(Initialize): Initialize Project_Object_Directory to No_Project
* mlib-prj.adb:
(Build_Library): Take into account Builder'Default_Switches ("Ada") when
binding a Stand-Alone Library.
* output.adb: Update Copyright notice
(Write_Char): Output buffer when full
2003-11-26 Robert Dewar <dewar@gnat.com>
* sem_ch13.adb: (Check_Size): Reset size if size is too small
* sem_ch13.ads:
(Check_Size): Fix documentation to include bit-packed array case
* sem_res.adb: Implement restriction No_Direct_Boolean_Operators
* s-rident.ads: Put No_Direct_Boolean_Operators in proper order
* s-rident.ads: Add new restriction No_Direct_Boolean_Operators
2003-11-26 Thomas Quinot <quinot@act-europe.fr>
* g-socket.ads, g-socket.adb:
Clarify documentation of function Stream. Introduce a Free procedure
to release the returned Stream once it becomes unused.
* 5asystem.ads: For Alpha Tru64, enable ZCX by default.
--
Index: 5asystem.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5asystem.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5asystem.ads
--- 5asystem.ads 21 Oct 2003 13:41:51 -0000 1.6
+++ 5asystem.ads 26 Nov 2003 09:04:24 -0000
@@ -138,8 +138,8 @@ private
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
- GCC_ZCX_Support : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!)
Index: 5wtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wtaprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5wtaprop.adb
--- 5wtaprop.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5wtaprop.adb 26 Nov 2003 09:04:25 -0000
@@ -296,9 +296,13 @@ package body System.Task_Primitives.Oper
Timed_Out : out Boolean;
Status : out Integer)
is
- Time_Out : DWORD;
- Result : BOOL;
- Wait_Result : DWORD;
+ Time_Out_Max : constant DWORD := 16#FFFF0000#;
+ -- NT 4 cannot handle timeout values that are too large,
+ -- e.g. DWORD'Last - 1
+
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
begin
-- Must reset Cond BEFORE L is unlocked.
@@ -315,8 +319,8 @@ package body System.Task_Primitives.Oper
Wait_Result := 0;
else
- if Rel_Time >= Duration (DWORD'Last - 1) / 1000 then
- Time_Out := DWORD'Last - 1;
+ if Rel_Time >= Duration (Time_Out_Max) / 1000 then
+ Time_Out := Time_Out_Max;
else
Time_Out := DWORD (Rel_Time * 1000);
end if;
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch4.adb
--- exp_ch4.adb 24 Nov 2003 14:27:57 -0000 1.11
+++ exp_ch4.adb 26 Nov 2003 09:04:26 -0000
@@ -5333,11 +5333,36 @@ package body Exp_Ch4 is
Pfx : constant Node_Id := Prefix (N);
Ptp : Entity_Id := Etype (Pfx);
+ function Is_Procedure_Actual (N : Node_Id) return Boolean;
+ -- Check whether context is a procedure call, in which case
+ -- expansion of a bit-packed slice is deferred until the call
+ -- itself is expanded.
+
procedure Make_Temporary;
-- Create a named variable for the value of the slice, in
-- cases where the back-end cannot handle it properly, e.g.
-- when packed types or unaligned slices are involved.
+ -------------------------
+ -- Is_Procedure_Actual --
+ -------------------------
+
+ function Is_Procedure_Actual (N : Node_Id) return Boolean is
+ Par : Node_Id := Parent (N);
+ begin
+ while Present (Par)
+ and then Nkind (Par) not in N_Statement_Other_Than_Procedure_Call
+ loop
+ if Nkind (Par) = N_Procedure_Call_Statement then
+ return True;
+ else
+ Par := Parent (Par);
+ end if;
+ end loop;
+
+ return False;
+ end Is_Procedure_Actual;
+
--------------------
-- Make_Temporary --
--------------------
@@ -5422,26 +5447,34 @@ package body Exp_Ch4 is
-- is caught elsewhere, and the expansion would intefere
-- with generating the error message).
- if Is_Packed (Typ)
- and then Nkind (Parent (N)) /= N_Assignment_Statement
- and then (Nkind (Parent (Parent (N))) /= N_Assignment_Statement
- or else
- Parent (N) /= Name (Parent (Parent (N))))
- and then Nkind (Parent (N)) /= N_Indexed_Component
- and then not Is_Renamed_Object (N)
- and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
- and then (Nkind (Parent (N)) /= N_Attribute_Reference
- or else
- Attribute_Name (Parent (N)) /= Name_Address)
+ if not Is_Packed (Typ) then
+ -- apply transformation for actuals of a function call, where
+ -- Expand_Actuals is not used.
+
+ if Nkind (Parent (N)) = N_Function_Call
+ and then Is_Possibly_Unaligned_Slice (N)
+ then
+ Make_Temporary;
+ end if;
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
+ and then Parent (N) = Name (Parent (Parent (N))))
then
- Make_Temporary;
+ return;
- -- Same transformation for actuals in a function call, where
- -- Expand_Actuals is not used.
+ elsif Nkind (Parent (N)) = N_Indexed_Component
+ or else Is_Renamed_Object (N)
+ or else Is_Procedure_Actual (N)
+ then
+ return;
- elsif Nkind (Parent (N)) = N_Function_Call
- and then Is_Possibly_Unaligned_Slice (N)
+ elsif (Nkind (Parent (N)) = N_Attribute_Reference
+ and then Attribute_Name (Parent (N)) = Name_Address)
then
+ return;
+
+ else
Make_Temporary;
end if;
end Expand_N_Slice;
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_ch6.adb
--- exp_ch6.adb 20 Nov 2003 09:53:58 -0000 1.12
+++ exp_ch6.adb 26 Nov 2003 09:04:26 -0000
@@ -544,24 +544,8 @@ package body Exp_Ch6 is
-- If the formal is an (in-)out parameter, capture the name
-- of the variable in order to build the post-call assignment.
- -- The variable itself may have been expanded, for example if
- -- it is a complex bit-packed array, so we need to recover the
- -- original to ensure that we have the proper target for the
- -- assignment. Examine the slocs of the two nodes to determine
- -- whether the rewriting is an expansion, or a substitution done
- -- on an inlined body, in which case it must be respected.
- declare
- Orig : constant Node_Id := Original_Node (Expression (Actual));
- begin
- if Orig /= Expression (Actual)
- and then Sloc (Orig) = Sloc (Expression (Actual))
- then
- Var := Make_Var (Orig);
- else
- Var := Make_Var (Expression (Actual));
- end if;
- end;
+ Var := Make_Var (Expression (Actual));
Crep := not Same_Representation
(Etype (Formal), Etype (Expression (Actual)));
Index: g-socket.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.adb,v
retrieving revision 1.6
diff -u -p -r1.6 g-socket.adb
--- g-socket.adb 21 Oct 2003 13:42:05 -0000 1.6
+++ g-socket.adb 26 Nov 2003 09:04:26 -0000
@@ -34,6 +34,7 @@
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings;
@@ -776,6 +777,17 @@ package body GNAT.Sockets is
Thin.Finalize;
end if;
end Finalize;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Stream : in out Stream_Access) is
+ procedure Do_Free is new Ada.Unchecked_Deallocation
+ (Ada.Streams.Root_Stream_Type'Class, Stream_Access);
+ begin
+ Do_Free (Stream);
+ end Free;
---------
-- Get --
Index: g-socket.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.ads,v
retrieving revision 1.7
diff -u -p -r1.7 g-socket.ads
--- g-socket.ads 21 Oct 2003 13:42:05 -0000 1.7
+++ g-socket.ads 26 Nov 2003 09:04:26 -0000
@@ -885,15 +885,15 @@ package GNAT.Sockets is
function Stream
(Socket : Socket_Type)
return Stream_Access;
- -- Associate a stream with a stream-based socket that is already
- -- connected.
+ -- Create a stream associated with a stream-based socket that is
+ -- already connected.
function Stream
(Socket : Socket_Type;
Send_To : Sock_Addr_Type)
return Stream_Access;
- -- Associate a stream with a datagram-based socket that is already
- -- bound. Send_To is the socket address to which messages are
+ -- Create a stream associated with a datagram-based socket that is
+ -- already bound. Send_To is the socket address to which messages are
-- being sent.
function Get_Address
@@ -901,6 +901,11 @@ package GNAT.Sockets is
return Sock_Addr_Type;
-- Return the socket address from which the last message was
-- received.
+
+ procedure Free (Stream : in out Stream_Access);
+ -- Destroy a stream created by one of the Stream functions above, and
+ -- release associated resources. The user is responsible for calling
+ -- this subprogram when the stream is not needed anymore.
type Socket_Set_Type is limited private;
-- This type allows to manipulate sets of sockets. It allows to
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.25
diff -u -p -r1.25 make.adb
--- make.adb 24 Nov 2003 14:27:57 -0000 1.25
+++ make.adb 26 Nov 2003 09:04:27 -0000
@@ -312,6 +312,11 @@ package body Make is
Main_Project : Prj.Project_Id := No_Project;
-- The project id of the main project file, if any
+ Project_Object_Directory : Project_Id := No_Project;
+ -- The object directory of the project for the last compilation.
+ -- Avoid calling Change_Dir if the current working directory is already
+ -- this directory
+
-- Packages of project files where unknown attributes are errors.
Naming_String : aliased String := "naming";
@@ -344,6 +349,10 @@ package body Make is
procedure Add_Object_Directories is
new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir);
+ procedure Change_To_Object_Directory (Project : Project_Id);
+ -- Change to the object directory of project Project, if this is not
+ -- already the current working directory.
+
type Bad_Compilation_Info is record
File : File_Name_Type;
Unit : Unit_Name_Type;
@@ -1107,6 +1116,36 @@ package body Make is
end if;
end Bind;
+ --------------------------------
+ -- Change_To_Object_Directory --
+ --------------------------------
+
+ procedure Change_To_Object_Directory (Project : Project_Id) is
+ begin
+ -- Nothing to do if the current working directory is alresdy the one
+ -- we want.
+
+ if Project_Object_Directory /= Project then
+ Project_Object_Directory := Project;
+
+ -- If in a real project, set the working directory to the object
+ -- directory of the project.
+
+ if Project /= No_Project then
+ Change_Dir
+ (Get_Name_String (Projects.Table (Project).Object_Directory));
+
+ -- Otherwise, for sources outside of any project, set the working
+ -- directory to the object directory of the main project.
+
+ elsif Main_Project /= No_Project then
+ Change_Dir
+ (Get_Name_String
+ (Projects.Table (Main_Project).Object_Directory));
+ end if;
+ end if;
+ end Change_To_Object_Directory;
+
-----------
-- Check --
-----------
@@ -2204,28 +2243,23 @@ package body Make is
end;
end if;
- -- Change to the object directory of the project file, if it is
- -- not the main project file.
+ -- Change to the object directory of the project file,
+ -- if necessary.
- if Arguments_Project /= Main_Project then
- Change_Dir
- (Get_Name_String
- (Projects.Table (Arguments_Project).Object_Directory));
- end if;
+ Change_To_Object_Directory (Arguments_Project);
Pid := Compile (Arguments_Path_Name, Lib_File,
Arguments (1 .. Last_Argument));
- -- Change back to the object directory of the main project file,
- -- if necessary.
+ else
+ -- If this is a source outside of any project file, make sure
+ -- it will be compiled in the object directory of the main project
+ -- file.
- if Arguments_Project /= Main_Project then
- Change_Dir
- (Get_Name_String
- (Projects.Table (Main_Project).Object_Directory));
+ if Main_Project /= No_Project then
+ Change_To_Object_Directory (Arguments_Project);
end if;
- else
Pid := Compile (Full_Source_File, Lib_File,
Arguments (1 .. Last_Argument));
end if;
@@ -3761,9 +3795,8 @@ package body Make is
-- project.
begin
- Change_Dir
- (Get_Name_String
- (Projects.Table (Main_Project).Object_Directory));
+ Project_Object_Directory := No_Project;
+ Change_To_Object_Directory (Main_Project);
exception
when Directory_Error =>
@@ -4623,6 +4656,13 @@ package body Make is
end Recursive_Compilation_Step;
end if;
+ -- For binding and linking, we need to be in the object directory of
+ -- the main project.
+
+ if Main_Project /= No_Project then
+ Change_To_Object_Directory (Main_Project);
+ end if;
+
-- If we are here, it means that we need to rebuilt the current
-- main. So we set Executable_Obsolete to True to make sure that
-- the subsequent mains will be rebuilt.
@@ -5712,6 +5752,10 @@ package body Make is
Make_Failed (Exception_Message (Err));
end;
end if;
+
+ -- Make sure no project object directory is recorded
+
+ Project_Object_Directory := No_Project;
-- Set the marking label to a value that is not zero
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.5
diff -u -p -r1.5 mlib-prj.adb
--- mlib-prj.adb 20 Nov 2003 09:54:00 -0000 1.5
+++ mlib-prj.adb 26 Nov 2003 09:04:27 -0000
@@ -806,6 +806,42 @@ package body MLib.Prj is
(B_Start & Get_Name_String (Data.Library_Name) & ".adb");
Add_Argument ("-L" & Get_Name_String (Data.Library_Name));
+ -- Check if Binder'Default_Switches ("Ada) is defined. If it is,
+ -- add these switches to call gnatbind.
+
+ declare
+ Binder_Package : constant Package_Id :=
+ Value_Of
+ (Name => Name_Binder,
+ In_Packages => Data.Decl.Packages);
+ begin
+ if Binder_Package /= No_Package then
+ declare
+ Defaults : constant Array_Element_Id :=
+ Value_Of
+ (Name => Name_Default_Switches,
+ In_Arrays =>
+ Packages.Table
+ (Binder_Package).Decl.Arrays);
+ Switches : Variable_Value :=
+ Value_Of
+ (Index => Name_Ada, In_Array => Defaults);
+ Switch : String_List_Id := Nil_String;
+ begin
+ if not Switches.Default then
+ Switch := Switches.Values;
+
+ while Switch /= Nil_String loop
+ Add_Argument
+ (Get_Name_String
+ (String_Elements.Table (Switch).Value));
+ Switch := String_Elements.Table (Switch).Next;
+ end loop;
+ end if;
+ end;
+ end if;
+ end;
+
-- Get all the ALI files of the project file
declare
Index: output.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/output.adb,v
retrieving revision 1.5
diff -u -p -r1.5 output.adb
--- output.adb 24 Apr 2003 17:54:07 -0000 1.5
+++ output.adb 26 Nov 2003 09:04:27 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, 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- --
@@ -236,10 +236,12 @@ package body Output is
procedure Write_Char (C : Character) is
begin
- if Next_Column < Buffer'Length then
- Buffer (Natural (Next_Column)) := C;
- Next_Column := Next_Column + 1;
+ if Next_Column = Buffer'Length then
+ Write_Eol;
end if;
+
+ Buffer (Natural (Next_Column)) := C;
+ Next_Column := Next_Column + 1;
end Write_Char;
---------------
Index: sem_ch13.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_ch13.adb
--- sem_ch13.adb 17 Nov 2003 14:58:16 -0000 1.11
+++ sem_ch13.adb 26 Nov 2003 09:04:27 -0000
@@ -2898,6 +2898,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := Asiz;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
+ Set_Esize (T, Asiz);
+ Set_RM_Size (T, Asiz);
end if;
end;
@@ -2939,6 +2941,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := M;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
+ Set_Esize (T, M);
+ Set_RM_Size (T, M);
else
Biased := True;
end if;
Index: sem_ch13.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.ads,v
retrieving revision 1.6
diff -u -p -r1.6 sem_ch13.ads
--- sem_ch13.ads 21 Oct 2003 13:42:19 -0000 1.6
+++ sem_ch13.ads 26 Nov 2003 09:04:27 -0000
@@ -79,14 +79,17 @@ package Sem_Ch13 is
Biased : out Boolean);
-- Called when size Siz is specified for subtype T. This subprogram checks
-- that the size is appropriate, posting errors on node N as required.
- -- For non-elementary types, a check is only made if an explicit size
- -- has been given for the type (and the specified size must match). The
- -- parameter Biased is set False if the size specified did not require
+ -- This check is effective for elementary types and bit-packed arrays.
+ -- For other non-elementary types, a check is only made if an explicit
+ -- size has been given for the type (and the specified size must match).
+ -- The parameter Biased is set False if the size specified did not require
-- the use of biased representation, and True if biased representation
-- was required to meet the size requirement. Note that Biased is only
-- set if the type is not currently biased, but biasing it is the only
-- way to meet the requirement. If the type is currently biased, then
-- this biased size is used in the initial check, and Biased is False.
+ -- If the size is too small, and an error message is given, then both
+ -- Esize and RM_Size are reset to the allowed minimum value in T.
procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
-- N is the node for either a representation pragma or an attribute
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.23
diff -u -p -r1.23 sem_ch3.adb
--- sem_ch3.adb 24 Nov 2003 14:27:57 -0000 1.23
+++ sem_ch3.adb 26 Nov 2003 09:04:28 -0000
@@ -3061,14 +3061,21 @@ package body Sem_Ch3 is
-- declared in a closed scope (e.g., a subprogram), then we
-- need to explicitly introduce the new type's concatenation
-- operator since Derive_Subprograms will not inherit the
- -- parent's operator.
+ -- parent's operator. If the parent type is unconstrained, the
+ -- operator is of the unconstrained base type.
if Number_Dimensions (Parent_Type) = 1
and then not Is_Limited_Type (Parent_Type)
and then not Is_Derived_Type (Parent_Type)
and then not Is_Package (Scope (Base_Type (Parent_Type)))
then
- New_Concatenation_Op (Derived_Type);
+ if not Is_Constrained (Parent_Type)
+ and then Is_Constrained (Derived_Type)
+ then
+ New_Concatenation_Op (Implicit_Base);
+ else
+ New_Concatenation_Op (Derived_Type);
+ end if;
end if;
end Build_Derived_Array_Type;
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_res.adb
--- sem_res.adb 14 Nov 2003 10:24:43 -0000 1.13
+++ sem_res.adb 26 Nov 2003 09:04:28 -0000
@@ -88,6 +88,11 @@ package body Sem_Res is
-- Give list of candidate interpretations when a character literal cannot
-- be resolved.
+ procedure Check_Direct_Boolean_Op (N : Node_Id);
+ -- N is a binary operator node which may possibly operate on Boolean
+ -- operands. If the operator does have Boolean operands, then a call is
+ -- made to check the restriction No_Direct_Boolean_Operators.
+
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
@@ -342,6 +347,17 @@ package body Sem_Res is
end if;
end Analyze_And_Resolve;
+ -----------------------------
+ -- Check_Direct_Boolean_Op --
+ -----------------------------
+
+ procedure Check_Direct_Boolean_Op (N : Node_Id) is
+ begin
+ if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then
+ Check_Restriction (No_Direct_Boolean_Operators, N);
+ end if;
+ end Check_Direct_Boolean_Op;
+
----------------------------
-- Check_Discriminant_Use --
----------------------------
@@ -3852,6 +3868,8 @@ package body Sem_Res is
T : Entity_Id;
begin
+ Check_Direct_Boolean_Op (N);
+
-- If this is an intrinsic operation which is not predefined, use
-- the types of its declared arguments to resolve the possibly
-- overloaded operands. Otherwise the operands are unambiguous and
@@ -4591,6 +4609,8 @@ package body Sem_Res is
-- Start of processing for Resolve_Equality_Op
begin
+ Check_Direct_Boolean_Op (N);
+
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
@@ -4972,6 +4992,8 @@ package body Sem_Res is
B_Typ : Entity_Id;
begin
+ Check_Direct_Boolean_Op (N);
+
-- Predefined operations on scalar types yield the base type. On
-- the other hand, logical operations on arrays yield the type of
-- the arguments (and the context).
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.1
diff -u -p -r1.1 s-rident.ads
--- s-rident.ads 21 Oct 2003 13:42:14 -0000 1.1
+++ s-rident.ads 26 Nov 2003 09:04:28 -0000
@@ -56,6 +56,7 @@ package System.Rident is
No_Asynchronous_Control, -- (RM D.7(10))
No_Calendar, -- GNAT
No_Delay, -- (RM H.4(21))
+ No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19))
No_Dynamic_Interrupts, -- GNAT
No_Dynamic_Priorities, -- (RM D.9(9))
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-24 15:19 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-24 15:19 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-11-24 Jose Ruiz <ruiz@act-europe.fr>
* Makefile.in:
Use 5zintman.ads for VxWorks targets. This file avoid confusion between
signals and interrupts.
* 5zintman.ads: New File.
* 5zintman.adb: Replace Exception_Interrupts by Exception_Signals, and
add exception signals to the set of unmasked signals.
* 5ztaprop.adb:
Use Abort_Task_Signal instead of Abort_Task_Interrupt to avoid confusion
between signals and interrupts.
Add to Unblocked_Signal_Mask the set of signals that are in
Keep_Unmasked.
* 7sinmaop.adb:
Adding a check to see whether the Interrupt_ID we want to unmask is in
the range of Keep_Unmasked (in procedure Interrupt_Self_Process). The
reason is that the index type of the Keep_Unmasked array is not always
Interrupt_ID; it may be a subtype of Interrupt_ID.
2003-11-24 Gary Dismukes <dismukes@gnat.com>
* exp_util.adb:
(Remove_Side_Effects): Condition constantness of object created for a
an unchecked type conversion on the constantness of the expression
to ensure the correct value for 'Constrained when passing components
of view-converted class-wide objects.
2003-11-24 Robert Dewar <dewar@gnat.com>
* par-load.adb (Load): Improve handling of misspelled and missing units
Removes several cases of compilation abandoned messages
* lib.adb: (Remove_Unit): New procedure
* lib.ads: (Remove_Unit): New procedure
* lib-load.adb: Minor reformatting
2003-11-24 Vincent Celier <celier@gnat.com>
* make.adb:
(Gnatmake, Initialize): Call Usage instead of Makeusg directly
(Marking_Label): Label to mark processed source files. Incremented for
each executable.
(Gnatmake): Increase Marking_Labet for each executable
(Is_Marked): Compare against marking label
(Mark): Mark with marking label
2003-11-24 Jerome Guitton <guitton@act-europe.fr>
* s-thread.ads:
Move the declaration of the TSD for System.Threads to System.Soft_Links.
Add some comments.
* Makefile.in: Added target pair for s-thread.adb for cert runtime.
(rts-cert): build a single relocatable object for the run-time lib.
Fix perms.
2003-11-24 Vasiliy Fofanov <fofanov@act-europe.fr>
* Make-lang.in:
Use gnatls rather than gcc to obtain the location of GNAT RTL for
crosstools build.
2003-11-24 Sergey Rybin <rybin@act-europe.fr>
* opt.adb (Tree_Write): Gnat_Version_String is now a function, so we
can not use it as before (that is, as a variable) when dumping it into
the tree file. Add a local variable to store the result of this
function and to be used as the string to be written into the tree.
* scn.adb (Initialize_Scanner): Add comments explaining the recent
changes.
* sinput.adb (Source_First, Source_Last): In case of
Internal_Source_File, replace returning attributes of
Internal_Source_Ptr (which is wrong) with returning attributes of
Internal_Source.
2003-11-24 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb:
(New_Concatenation_Op): Proper name for New_Binary_Operator, only
used for implicit concatenation operators.
Code cleanup.
* sem_elab.adb:
(Check_Elab_Call): Set No_Elaboration_Check appropriately on calls in
task bodies that are in the scope of a Suppress pragma.
(Check_A Call): Use the flag to prevent spurious elaboration checks.
* sinfo.ads, sinfo.adb:
New flag No_Elaboration_Check on function/procedure calls, to properly
suppress checks on calls in task bodies that are within a local suppress
pragma.
* exp_ch4.adb:
(Expand_Concatenate_Other): Use the proper integer type for the
expression for the upper bound, to avoid universal_integer computations
when possible.
--
Index: 5zintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zintman.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5zintman.adb
--- 5zintman.adb 21 Oct 2003 13:41:52 -0000 1.6
+++ 5zintman.adb 24 Nov 2003 11:49:36 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -62,22 +62,27 @@ package body System.Interrupt_Management
use System.OS_Interface;
use type Interfaces.C.int;
- type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
- Exception_Interrupts : constant Interrupt_List (1 .. 4) :=
- (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+ type Signal_List is array (Signal_ID range <>) of Signal_ID;
+ Exception_Signals : constant Signal_List (1 .. 4) :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
- -- Keep these variables global so that they are initialized only once.
+ -- Keep these variables global so that they are initialized only once
+ -- What are "these variables" ???, I see only one
Exception_Action : aliased struct_sigaction;
- ----------------------
- -- Notify_Exception --
- ----------------------
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
procedure Notify_Exception (signo : Signal);
-- Identify the Ada exception to be raised using
-- the information when the system received a synchronous signal.
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
procedure Notify_Exception (signo : Signal) is
Mask : aliased sigset_t;
Result : int;
@@ -126,10 +131,10 @@ package body System.Interrupt_Management
old_act : aliased struct_sigaction;
begin
- for J in Exception_Interrupts'Range loop
+ for J in Exception_Signals'Range loop
Result :=
sigaction
- (Signal (Exception_Interrupts (J)), Exception_Action'Access,
+ (Signal (Exception_Signals (J)), Exception_Action'Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end loop;
@@ -160,15 +165,15 @@ begin
-- Change this if you want to use another signal for task abort.
-- SIGTERM might be a good one.
- Abort_Task_Interrupt := SIGABRT;
+ Abort_Task_Signal := SIGABRT;
Exception_Action.sa_handler := Notify_Exception'Address;
Exception_Action.sa_flags := SA_ONSTACK;
Result := sigemptyset (mask'Access);
pragma Assert (Result = 0);
- for J in Exception_Interrupts'Range loop
- Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
+ for J in Exception_Signals'Range loop
+ Result := sigaddset (mask'Access, Signal (Exception_Signals (J)));
pragma Assert (Result = 0);
end loop;
@@ -185,5 +190,15 @@ begin
Reserve (J) := True;
end if;
end loop;
+
+ -- Add exception signals to the set of unmasked signals
+
+ for J in Exception_Signals'Range loop
+ Keep_Unmasked (Exception_Signals (J)) := True;
+ end loop;
+
+ -- The abort signal must also be unmasked
+
+ Keep_Unmasked (Abort_Task_Signal) := True;
end;
end System.Interrupt_Management;
Index: 5ztaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ztaprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5ztaprop.adb
--- 5ztaprop.adb 21 Oct 2003 13:41:53 -0000 1.8
+++ 5ztaprop.adb 24 Nov 2003 11:49:36 -0000
@@ -45,8 +45,8 @@ with System.Tasking.Debug;
with System.Interrupt_Management;
-- used for Keep_Unmasked
--- Abort_Task_Interrupt
--- Interrupt_ID
+-- Abort_Task_Signal
+-- Signal_ID
-- Initialize_Interrupts
with System.Soft_Links;
@@ -262,7 +262,7 @@ package body System.Task_Primitives.Oper
Result :=
sigaction
- (Signal (Interrupt_Management.Abort_Task_Interrupt),
+ (Signal (Interrupt_Management.Abort_Task_Signal),
act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
@@ -1008,7 +1008,7 @@ package body System.Task_Primitives.Oper
begin
Result := kill (T.Common.LL.Thread,
- Signal (Interrupt_Management.Abort_Task_Interrupt));
+ Signal (Interrupt_Management.Abort_Task_Signal));
pragma Assert (Result = 0);
end Abort_Task;
@@ -1125,6 +1125,13 @@ package body System.Task_Primitives.Oper
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
+
+ for J in Interrupt_Management.Signal_ID loop
+ if System.Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
Environment_Task_ID := Environment_Task;
Index: 7sinmaop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7sinmaop.adb,v
retrieving revision 1.4
diff -u -p -r1.4 7sinmaop.adb
--- 7sinmaop.adb 21 Oct 2003 13:41:53 -0000 1.4
+++ 7sinmaop.adb 24 Nov 2003 11:49:36 -0000
@@ -325,11 +325,16 @@ begin
Storage_Elements.To_Address
(Storage_Elements.Integer_Address (SIG_IGN));
- for I in Interrupt_ID loop
- if Keep_Unmasked (I) then
- Result := sigaddset (mask'Access, Signal (I));
+ for J in Interrupt_ID loop
+
+ -- We need to check whether J is in Keep_Unmasked because
+ -- the index type of the Keep_Unmasked array is not always
+ -- Interrupt_ID; it may be a subtype of Interrupt_ID.
+
+ if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then
+ Result := sigaddset (mask'Access, Signal (J));
pragma Assert (Result = 0);
- Result := sigdelset (allmask'Access, Signal (I));
+ Result := sigdelset (allmask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_ch4.adb
--- exp_ch4.adb 4 Nov 2003 12:51:45 -0000 1.10
+++ exp_ch4.adb 24 Nov 2003 11:49:36 -0000
@@ -1472,7 +1472,7 @@ package body Exp_Ch4 is
-- their base type, Ind_Typ their index type, and Arr_Typ the original
-- array type to which the concatenantion operator applies, then the
-- following subprogram is constructed:
- --
+
-- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
-- L : Ind_Typ;
-- begin
@@ -1489,7 +1489,7 @@ package body Exp_Ch4 is
-- else
-- return Sn;
-- end if;
- --
+
-- declare
-- P : Ind_Typ;
-- H : Ind_Typ :=
@@ -1516,9 +1516,9 @@ package body Exp_Ch4 is
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
- --
+
-- ...
- --
+
-- if Sn'Length /= 0 then
-- P := Sn'First;
-- loop
@@ -1528,7 +1528,7 @@ package body Exp_Ch4 is
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
- --
+
-- return R;
-- end;
-- end Cnn;]
@@ -1598,7 +1598,9 @@ package body Exp_Ch4 is
-- Builds reference to identifier L.
function L_Pos return Node_Id;
- -- Builds expression Ind_Typ'Pos (L).
+ -- Builds expression Integer_Type'(Ind_Typ'Pos (L)).
+ -- We qualify the expression to avoid universal_integer computations
+ -- whenever possible, in the expression for the upper bound H.
function L_Succ return Node_Id;
-- Builds expression Ind_Typ'Succ (L).
@@ -1743,12 +1745,31 @@ package body Exp_Ch4 is
-----------
function L_Pos return Node_Id is
+ Target_Type : Entity_Id;
+
begin
+ -- If the index type is an enumeration type, the computation
+ -- can be done in standard integer. Otherwise, choose a large
+ -- enough integer type.
+
+ if Is_Enumeration_Type (Ind_Typ)
+ or else Root_Type (Ind_Typ) = Standard_Integer
+ or else Root_Type (Ind_Typ) = Standard_Short_Integer
+ or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
+ then
+ Target_Type := Standard_Integer;
+ else
+ Target_Type := Root_Type (Ind_Typ);
+ end if;
+
return
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (L));
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Reference_To (Target_Type, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (L)));
end L_Pos;
------------
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_util.adb
--- exp_util.adb 21 Oct 2003 13:41:59 -0000 1.15
+++ exp_util.adb 24 Nov 2003 11:49:37 -0000
@@ -3510,7 +3510,7 @@ package body Exp_Util is
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
Object_Definition => New_Reference_To (Exp_Type, Loc),
- Constant_Present => True,
+ Constant_Present => not Is_Variable (Exp),
Expression => Relocate_Node (Exp));
Set_Assignment_OK (E);
Index: lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.adb,v
retrieving revision 1.8
diff -u -p -r1.8 lib.adb
--- lib.adb 10 Nov 2003 17:29:59 -0000 1.8
+++ lib.adb 24 Nov 2003 11:49:37 -0000
@@ -870,6 +870,17 @@ package body Lib is
return Int (Units.Last) - Int (Main_Unit) + 1;
end Num_Units;
+ -----------------
+ -- Remove_Unit --
+ -----------------
+
+ procedure Remove_Unit (U : Unit_Number_Type) is
+ begin
+ if U = Units.Last then
+ Units.Decrement_Last;
+ end if;
+ end Remove_Unit;
+
----------------------------------
-- Replace_Linker_Option_String --
----------------------------------
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.7
diff -u -p -r1.7 lib.ads
--- lib.ads 10 Nov 2003 17:29:59 -0000 1.7
+++ lib.ads 24 Nov 2003 11:49:37 -0000
@@ -417,6 +417,10 @@ package Lib is
function Num_Units return Nat;
-- Number of units currently in unit table
+ procedure Remove_Unit (U : Unit_Number_Type);
+ -- Remove unit U from unit table. Currently this is effective only
+ -- if U is the last unit currently stored in the unit table.
+
function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean;
-- Returns True if the entity E is declared in the main unit, or, in
-- its corresponding spec, or one of its subunits. Entities declared
Index: lib-load.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-load.adb,v
retrieving revision 1.8
diff -u -p -r1.8 lib-load.adb
--- lib-load.adb 20 Nov 2003 09:53:58 -0000 1.8
+++ lib-load.adb 24 Nov 2003 11:49:37 -0000
@@ -688,14 +688,11 @@ package body Lib.Load is
procedure Make_Instance_Unit (N : Node_Id) is
Sind : constant Source_File_Index := Source_Index (Main_Unit);
-
begin
Units.Increment_Last;
-
Units.Table (Units.Last) := Units.Table (Main_Unit);
Units.Table (Units.Last).Cunit := Library_Unit (N);
Units.Table (Units.Last).Generate_Code := True;
-
Units.Table (Main_Unit).Cunit := N;
Units.Table (Main_Unit).Unit_Name :=
Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
@@ -713,7 +710,6 @@ package body Lib.Load is
is
Sunit : constant Node_Id := Cunit (Spec_Unit);
Bunit : constant Node_Id := Cunit (Body_Unit);
-
begin
-- The spec is irrelevant if the body is a subprogram body, and the
-- spec is other than a subprogram spec or generic subprogram spec.
@@ -725,7 +721,6 @@ package body Lib.Load is
Nkind (Unit (Bunit)) = N_Subprogram_Body
and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
-
end Spec_Is_Irrelevant;
--------------------
@@ -735,9 +730,7 @@ package body Lib.Load is
procedure Version_Update (U : Node_Id; From : Node_Id) is
Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
-
begin
-
if Source_Index (Fnum) /= No_Source_File then
Units.Table (Unum).Version :=
Units.Table (Unum).Version
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.24
diff -u -p -r1.24 make.adb
--- make.adb 21 Nov 2003 10:46:37 -0000 1.24
+++ make.adb 24 Nov 2003 11:49:37 -0000
@@ -24,12 +24,6 @@
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Command_Line; use Ada.Command_Line;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.Case_Util; use GNAT.Case_Util;
-
with ALI; use ALI;
with ALI.Util; use ALI.Util;
with Csets;
@@ -65,6 +59,12 @@ with System.HTable;
with Targparm;
with Tempdir;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Command_Line; use Ada.Command_Line;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.Case_Util; use GNAT.Case_Util;
+
package body Make is
use ASCII;
@@ -480,6 +480,9 @@ package body Make is
-- Marking Routines --
----------------------
+ Marking_Label : Byte := 1;
+ -- Value to mark the source files
+
procedure Mark (Source_File : File_Name_Type);
-- Mark Source_File. Marking is used to signal that Source_File has
-- already been inserted in the Q.
@@ -2233,7 +2236,9 @@ package body Make is
-------------
function Compile
- (S : Name_Id; L : Name_Id; Args : Argument_List) return Process_Id
+ (S : Name_Id;
+ L : Name_Id;
+ Args : Argument_List) return Process_Id
is
Comp_Args : Argument_List (Args'First .. Args'Last + 8);
Comp_Next : Integer := Args'First;
@@ -3692,7 +3697,7 @@ package body Make is
else
-- Output usage information if no files to compile
- Makeusg;
+ Usage;
Exit_Program (E_Fatal);
end if;
end if;
@@ -4228,6 +4233,18 @@ package body Make is
Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop
+ -- Increase the marking label to be sure to check sources
+ -- for all executables.
+
+ Marking_Label := Marking_Label + 1;
+
+ -- Make sure it is not 0, which is the default value for
+ -- a file that has never been marked.
+
+ if Marking_Label = 0 then
+ Marking_Label := 1;
+ end if;
+
-- First, find the executable name and path
Executable := No_File;
@@ -5573,7 +5590,7 @@ package body Make is
end loop Scan_Args;
if Usage_Requested then
- Makeusg;
+ Usage;
end if;
-- Test for trailing -P switch
@@ -5695,6 +5712,10 @@ package body Make is
Make_Failed (Exception_Message (Err));
end;
end if;
+
+ -- Set the marking label to a value that is not zero
+
+ Marking_Label := 1;
end Initialize;
-----------------------------------
@@ -5707,10 +5728,11 @@ package body Make is
Into_Q : Boolean)
is
Put_In_Q : Boolean := Into_Q;
- Unit : Com.Unit_Data;
- Sfile : Name_Id;
+ Unit : Com.Unit_Data;
+ Sfile : Name_Id;
+
Extending : constant Boolean :=
- Projects.Table (The_Project).Extends /= No_Project;
+ Projects.Table (The_Project).Extends /= No_Project;
function Check_Project (P : Project_Id) return Boolean;
-- Returns True if P is The_Project or a project extended by
@@ -6044,7 +6066,7 @@ package body Make is
function Is_Marked (Source_File : File_Name_Type) return Boolean is
begin
- return Get_Name_Table_Byte (Source_File) /= 0;
+ return Get_Name_Table_Byte (Source_File) = Marking_Label;
end Is_Marked;
----------
@@ -6228,7 +6250,7 @@ package body Make is
procedure Mark (Source_File : File_Name_Type) is
begin
- Set_Name_Table_Byte (Source_File, 1);
+ Set_Name_Table_Byte (Source_File, Marking_Label);
end Mark;
--------------------
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.54
diff -u -p -r1.54 Makefile.in
--- Makefile.in 20 Nov 2003 09:53:58 -0000 1.54
+++ Makefile.in 24 Nov 2003 11:49:37 -0000
@@ -461,6 +461,7 @@ ifeq ($(strip $(filter-out alpha% dec vx
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -487,6 +488,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -524,6 +526,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -593,6 +596,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
s-soflin.ads<2ssoflin.ads \
s-stalib.adb<1sstalib.adb \
s-stalib.ads<1sstalib.ads \
+ s-thread.adb<5zthread.adb \
s-thrini.ads<2sthrini.ads \
s-thrini.adb<5zthrini.adb \
s-tiitho.adb<5ztiitho.adb \
@@ -619,6 +623,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -692,7 +697,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
s-soflin.ads<2ssoflin.ads \
s-stalib.adb<1sstalib.adb \
s-stalib.ads<1sstalib.ads \
- s-thrini.adb<5zthrini.adb \
+ s-thread.adb<5zthread.adb \
s-thrini.ads<2sthrini.ads \
s-thrini.adb<5zthrini.adb \
s-tiitho.adb<5ytiitho.adb \
@@ -736,6 +741,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -764,6 +770,7 @@ ifeq ($(strip $(filter-out xscale% coff
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -792,6 +799,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -2055,8 +2063,10 @@ rts-cert: force
../../../$(GCC_FOR_TARGET) -B../../../ $(TARGET_LIBGCC2_CFLAGS) \
$(ALL_CFLAGS) $(GNATLIBCFLAGS_FOR_C) -c ../adainclude/$(f).c \
-I../adainclude $(INCLUDES_FOR_SUBDIR) -I../../../ ;) \
- $(AR) $(AR_FLAGS) libgnat$(arext) \
- $(addsuffix .o,$(CERT_LEVEL_B_C_FILES))
+ ../../../xgcc -B../../../ *.o -o libgnat ; \
+ $(CHMOD) a-wx *.ali ; \
+ $(RM) *.o ; \
+ $(MV) libgnat libgnat.o
rts-none: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.57
diff -u -p -r1.57 Make-lang.in
--- Make-lang.in 20 Nov 2003 10:08:51 -0000 1.57
+++ Make-lang.in 24 Nov 2003 11:49:37 -0000
@@ -290,10 +290,10 @@ regnattools:
# use host-gcc host-gnatmake host-gnatbind host-gnatlink
# put the host RTS dir first in the PATH to hide the default runtime
# files that are among the sources
-RTS_DIR:=$(dir $(subst \,/,$(shell $(CC) -print-libgcc-file-name)))
+RTS_DIR:=$(strip $(subst \,/,$(shell gnatls -v | grep adalib )))
cross-gnattools: force
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS)\
- ADA_INCLUDES="-I$(RTS_DIR)adainclude -I$(RTS_DIR)adalib" \
+ ADA_INCLUDES="-I$(RTS_DIR)../adainclude -I$(RTS_DIR)" \
GNATMAKE="gnatmake" \
GNATBIND="gnatbind" \
GNATLINK="gnatlink" \
Index: opt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.adb,v
retrieving revision 1.6
diff -u -p -r1.6 opt.adb
--- opt.adb 21 Oct 2003 13:42:10 -0000 1.6
+++ opt.adb 24 Nov 2003 11:49:37 -0000
@@ -186,6 +186,7 @@ package body Opt is
----------------
procedure Tree_Write is
+ Version_String : String := Gnat_Version_String;
begin
Tree_Write_Int (ASIS_Version_Number);
Tree_Write_Bool (Brief_Output);
@@ -202,9 +203,9 @@ package body Opt is
Tree_Write_Bool (Assertions_Enabled);
Tree_Write_Bool (Enable_Overflow_Checks);
Tree_Write_Bool (Full_List);
- Tree_Write_Int (Int (Gnat_Version_String'Length));
- Tree_Write_Data (Gnat_Version_String'Address,
- Gnat_Version_String'Length);
+ Tree_Write_Int (Int (Version_String'Length));
+ Tree_Write_Data (Version_String'Address,
+ Version_String'Length);
Tree_Write_Data (Distribution_Stub_Mode'Address,
Distribution_Stub_Mode_Type'Object_Size / Storage_Unit);
Tree_Write_Bool (Immediate_Errors);
Index: par-load.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-load.adb,v
retrieving revision 1.5
diff -u -p -r1.5 par-load.adb
--- par-load.adb 21 Oct 2003 13:42:10 -0000 1.5
+++ par-load.adb 24 Nov 2003 11:49:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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,8 @@ with Sinput.L; use Sinput.L;
with Stylesw; use Stylesw;
with Validsw; use Validsw;
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
separate (Par)
procedure Load is
@@ -188,26 +190,45 @@ begin
or else
Name_Buffer (1) = 'g')
then
- -- In the predefined file case, we know the user did not construct
- -- their own package, but we got the wrong one. This means that the
- -- name supplied by the user crunched to something we recognized,
- -- but then the file did not contain the unit expected. Most likely
- -- this is due to a misspelling, e.g.
-
- -- with Ada.Calender;
-
- -- This crunches to a-calend, which indeed contains the unit
- -- Ada.Calendar, and we can diagnose the misspelling. This is
- -- a simple heuristic, but it catches many common cases of
- -- misspelling of predefined unit names without needing a full
- -- list of them.
-
- Error_Msg_Name_1 := Expected_Unit (Cur_Unum);
- Error_Msg ("% is not a predefined library unit!", Loc);
- Error_Msg_Name_1 := Unit_Name (Cur_Unum);
- Error_Msg ("possible misspelling of %!", Loc);
-
- -- Non-predefined file name case
+ declare
+ Expect_Name : constant Name_Id := Expected_Unit (Cur_Unum);
+ Actual_Name : constant Name_Id := Unit_Name (Cur_Unum);
+
+ begin
+ Error_Msg_Name_1 := Expect_Name;
+ Error_Msg ("% is not a predefined library unit!", Loc);
+
+ -- In the predefined file case, we know the user did not
+ -- construct their own package, but we got the wrong one.
+ -- This means that the name supplied by the user crunched
+ -- to something we recognized, but then the file did not
+ -- contain the unit expected. Most likely this is due to
+ -- a misspelling, e.g.
+
+ -- with Ada.Calender;
+
+ -- This crunches to a-calend, which indeed contains the unit
+ -- Ada.Calendar, and we can diagnose the misspelling. This
+ -- is a simple heuristic, but it catches many common cases
+ -- of misspelling of predefined unit names without needing
+ -- a full list of them.
+
+ -- Before actually issinying the message, we will check that the
+ -- unit name is indeed a plausible misspelling of the one we got.
+
+ if Is_Bad_Spelling_Of
+ (Found => Get_Name_String (Expect_Name),
+ Expect => Get_Name_String (Actual_Name))
+ then
+ Error_Msg_Name_1 := Actual_Name;
+ Error_Msg ("possible misspelling of %!", Loc);
+ end if;
+ end;
+
+ -- Non-predefined file name case. In this case we generate a message
+ -- and then we quit, because we are in big trouble, and if we try
+ -- to continue compilation, we get into some nasty situations
+ -- (for example in some subunit cases).
else
Error_Msg ("file { does not contain expected unit!", Loc);
@@ -217,7 +238,10 @@ begin
Error_Msg ("found unit $!", Loc);
end if;
- raise Unrecoverable_Error;
+ -- In both cases, remove the unit if it is the last unit (which it
+ -- normally (always?) will be) so that it is out of the way later.
+
+ Remove_Unit (Cur_Unum);
end if;
-- If current unit is a body, load its corresponding spec
Index: scn.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scn.adb,v
retrieving revision 1.9
diff -u -p -r1.9 scn.adb
--- scn.adb 21 Nov 2003 10:46:37 -0000 1.9
+++ scn.adb 24 Nov 2003 11:49:37 -0000
@@ -261,7 +261,9 @@ package body Scn is
begin
Scanner.Initialize_Scanner (Unit, Index);
- -- Set default for Comes_From_Source. All nodes built now until we
+ -- Set default for Comes_From_Source (except if we are going to process
+ -- an artificial string internally created within the compiler and
+ -- placed into internal source duffer). All nodes built now until we
-- reenter the analyzer will have Comes_From_Source set to True
if Index /= Internal_Source_File then
@@ -279,6 +281,16 @@ package body Scn is
-- Because of the License stuff above, Scng.Initialize_Scanner cannot
-- call Scan. Scan initial token (note this initializes Prev_Token,
-- Prev_Token_Ptr).
+
+ -- There are two reasons not to do the Scan step in case if we
+ -- initialize the scanner for the internal source buffer:
+
+ -- - The artificial string may not be created by the compiler in this
+ -- buffer when we call Initialize_Scanner
+
+ -- - For these artificial strings a special way of scanning is used, so
+ -- the standard step of the scanner may just break the algorithm of
+ -- processing these strings.
if Index /= Internal_Source_File then
Scan;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.22
diff -u -p -r1.22 sem_ch3.adb
--- sem_ch3.adb 20 Nov 2003 09:54:01 -0000 1.22
+++ sem_ch3.adb 24 Nov 2003 11:49:38 -0000
@@ -548,9 +548,9 @@ package body Sem_Ch3 is
-- Create new modular type. Verify that modulus is in bounds and is
-- a power of two (implementation restriction).
- procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
+ procedure New_Concatenation_Op (Typ : Entity_Id);
-- Create an abbreviated declaration for an operator in order to
- -- materialize minimally operators on derived types.
+ -- materialize concatenation on array types.
procedure Ordinary_Fixed_Point_Type_Declaration
(T : Entity_Id;
@@ -2865,7 +2865,7 @@ package body Sem_Ch3 is
if Number_Dimensions (T) = 1
and then not Is_Packed_Array_Type (T)
then
- New_Binary_Operator (Name_Op_Concat, T);
+ New_Concatenation_Op (T);
end if;
-- In the case of an unconstrained array the parser has already
@@ -3068,7 +3068,7 @@ package body Sem_Ch3 is
and then not Is_Derived_Type (Parent_Type)
and then not Is_Package (Scope (Base_Type (Parent_Type)))
then
- New_Binary_Operator (Name_Op_Concat, Derived_Type);
+ New_Concatenation_Op (Derived_Type);
end if;
end Build_Derived_Array_Type;
@@ -10945,11 +10945,11 @@ package body Sem_Ch3 is
end Modular_Type_Declaration;
- -------------------------
- -- New_Binary_Operator --
- -------------------------
+ --------------------------
+ -- New_Concatenation_Op --
+ --------------------------
- procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
+ procedure New_Concatenation_Op (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Op : Entity_Id;
@@ -10971,26 +10971,26 @@ package body Sem_Ch3 is
return Formal;
end Make_Op_Formal;
- -- Start of processing for New_Binary_Operator
+ -- Start of processing for New_Concatenation_Op
begin
- Op := Make_Defining_Operator_Symbol (Loc, Op_Name);
+ Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
Set_Ekind (Op, E_Operator);
Set_Scope (Op, Current_Scope);
Set_Etype (Op, Typ);
- Set_Homonym (Op, Get_Name_Entity_Id (Op_Name));
+ Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat));
Set_Is_Immediately_Visible (Op);
Set_Is_Intrinsic_Subprogram (Op);
Set_Has_Completion (Op);
Append_Entity (Op, Current_Scope);
- Set_Name_Entity_Id (Op_Name, Op);
+ Set_Name_Entity_Id (Name_Op_Concat, Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op);
- end New_Binary_Operator;
+ end New_Concatenation_Op;
-------------------------------------------
-- Ordinary_Fixed_Point_Type_Declaration --
Index: sem_elab.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elab.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_elab.adb
--- sem_elab.adb 22 Oct 2003 09:28:08 -0000 1.10
+++ sem_elab.adb 24 Nov 2003 11:49:38 -0000
@@ -325,6 +325,16 @@ package body Sem_Elab is
-- we ignore this flag.
begin
+ -- If the call is known to be within a local Suppress Elaboration
+ -- pragma, nothing to check. This can happen in task bodies.
+
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then No_Elaboration_Check (N)
+ then
+ return;
+ end if;
+
-- Go to parent for derived subprogram, or to original subprogram
-- in the case of a renaming (Alias covers both these cases)
@@ -826,10 +836,41 @@ package body Sem_Elab is
(N : Node_Id;
Outer_Scope : Entity_Id := Empty)
is
- Nam : Node_Id;
Ent : Entity_Id;
P : Node_Id;
+ function Get_Called_Ent return Entity_Id;
+ -- Retrieve called entity. If this is a call to a protected subprogram,
+ -- entity is a selected component. The callable entity may be absent,
+ -- in which case there is no check to perform. This happens with
+ -- non-analyzed calls in nested generics.
+
+ --------------------
+ -- Get_Called_Ent --
+ --------------------
+
+ function Get_Called_Ent return Entity_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (N);
+
+ if No (Nam) then
+ return Empty;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ return Entity (Selector_Name (Nam));
+
+ elsif not Is_Entity_Name (Nam) then
+ return Empty;
+
+ else
+ return Entity (Nam);
+ end if;
+ end Get_Called_Ent;
+
+ -- Start of processing for Check_Elab_Call
+
begin
-- For an entry call, check relevant restriction
@@ -1014,6 +1055,26 @@ package body Sem_Elab is
exit;
+ elsif Nkind (P) = N_Task_Body then
+
+ -- The check is deferred until Check_Task_Activation
+ -- but we need to capture local suppress pragmas
+ -- that may inhibit checks on this call.
+
+ Ent := Get_Called_Ent;
+
+ if No (Ent) then
+ return;
+
+ elsif Elaboration_Checks_Suppressed (Current_Scope)
+ or else Elaboration_Checks_Suppressed (Ent)
+ or else Elaboration_Checks_Suppressed (Scope (Ent))
+ then
+ Set_No_Elaboration_Check (N);
+ end if;
+
+ return;
+
-- Static model, call is not in elaboration code, we
-- never need to worry, because in the static model
-- the top level caller always takes care of things.
@@ -1027,25 +1088,7 @@ package body Sem_Elab is
end if;
end if;
- -- Retrieve called entity. If this is a call to a protected subprogram,
- -- the entity is a selected component.
- -- The callable entity may be absent, in which case there is nothing
- -- to do. This happens with non-analyzed calls in nested generics.
-
- Nam := Name (N);
-
- if No (Nam) then
- return;
-
- elsif Nkind (Nam) = N_Selected_Component then
- Ent := Entity (Selector_Name (Nam));
-
- elsif not Is_Entity_Name (Nam) then
- return;
-
- else
- Ent := Entity (Nam);
- end if;
+ Ent := Get_Called_Ent;
if No (Ent) then
return;
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sinfo.adb
--- sinfo.adb 14 Nov 2003 10:24:43 -0000 1.10
+++ sinfo.adb 24 Nov 2003 11:49:38 -0000
@@ -1764,6 +1764,15 @@ package body Sinfo is
return Flag7 (N);
end No_Ctrl_Actions;
+ function No_Elaboration_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ return Flag14 (N);
+ end No_Elaboration_Check;
+
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean is
begin
@@ -4186,6 +4195,15 @@ package body Sinfo is
or else NT (N).Nkind = N_Assignment_Statement);
Set_Flag7 (N, Val);
end Set_No_Ctrl_Actions;
+
+ procedure Set_No_Elaboration_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ Set_Flag14 (N, Val);
+ end Set_No_Elaboration_Check;
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True) is
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.15
diff -u -p -r1.15 sinfo.ads
--- sinfo.ads 20 Nov 2003 09:54:02 -0000 1.15
+++ sinfo.ads 24 Nov 2003 11:49:38 -0000
@@ -1266,6 +1266,13 @@ package Sinfo is
-- where the generated assignments are more initialisations than real
-- assignments.
+ -- No_Elaboration_Check (Flag14-Sem)
+ -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
+ -- that no elaboration check is needed on the call, because it appears
+ -- in the context of a local Suppress pragma. This is used on calls
+ -- within task bodies, where the actual elaboration checks are applied
+ -- after analysis, when the local scope stack is not present.
+
-- No_Entities_Ref_In_Spec (Flag8-Sem)
-- Present in N_With_Clause nodes. Set if the with clause is on the
-- package or subprogram spec where the main unit is the corresponding
@@ -4043,6 +4050,7 @@ package Sinfo is
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- Do_Tag_Check (Flag13-Sem)
+ -- No_Elaboration_Check (Flag14-Sem)
-- Parameter_List_Truncated (Flag17-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
@@ -4073,6 +4081,7 @@ package Sinfo is
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- Do_Tag_Check (Flag13-Sem)
+ -- No_Elaboration_Check (Flag14-Sem)
-- Parameter_List_Truncated (Flag17-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
@@ -7391,6 +7400,9 @@ package Sinfo is
function No_Ctrl_Actions
(N : Node_Id) return Boolean; -- Flag7
+ function No_Elaboration_Check
+ (N : Node_Id) return Boolean; -- Flag14
+
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean; -- Flag8
@@ -8165,6 +8177,9 @@ package Sinfo is
procedure Set_No_Ctrl_Actions
(N : Node_Id; Val : Boolean := True); -- Flag7
+ procedure Set_No_Elaboration_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True); -- Flag8
@@ -8600,6 +8615,7 @@ package Sinfo is
pragma Inline (Next_Rep_Item);
pragma Inline (Next_Use_Clause);
pragma Inline (No_Ctrl_Actions);
+ pragma Inline (No_Elaboration_Check);
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
pragma Inline (No_Truncation);
@@ -8854,6 +8870,7 @@ package Sinfo is
pragma Inline (Set_Next_Named_Actual);
pragma Inline (Set_Next_Use_Clause);
pragma Inline (Set_No_Ctrl_Actions);
+ pragma Inline (Set_No_Elaboration_Check);
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Truncation);
Index: sinput.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinput.adb,v
retrieving revision 1.7
diff -u -p -r1.7 sinput.adb
--- sinput.adb 21 Nov 2003 10:46:37 -0000 1.7
+++ sinput.adb 24 Nov 2003 11:49:38 -0000
@@ -1111,7 +1111,7 @@ package body Sinput is
function Source_First (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
- return Internal_Source_Ptr'First;
+ return Internal_Source'First;
else
return Source_File.Table (S).Source_First;
end if;
@@ -1120,7 +1120,7 @@ package body Sinput is
function Source_Last (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
- return Internal_Source_Ptr'Last;
+ return Internal_Source'Last;
else
return Source_File.Table (S).Source_Last;
end if;
Index: s-thread.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.ads,v
retrieving revision 1.3
diff -u -p -r1.3 s-thread.ads
--- s-thread.ads 10 Nov 2003 17:30:00 -0000 1.3
+++ s-thread.ads 24 Nov 2003 11:49:38 -0000
@@ -38,6 +38,10 @@
-- VxWorks AE653 with the restricted / cert runtime
with Ada.Exceptions;
+-- used for Exception_Occurrence
+
+with System.Soft_Links;
+-- used for TSD
package System.Threads is
@@ -137,27 +141,6 @@ package System.Threads is
private
- ------------------------
- -- Task Specific Data --
- ------------------------
-
- type ATSD is limited record
- Jmpbuf_Address : Address := Null_Address;
- -- Address of jump buffer used to store the address of the
- -- current longjmp/setjmp buffer for exception management.
- -- These buffers are threaded into a stack, and the address
- -- here is the top of the stack. A null address means that
- -- no exception handler is currently active.
-
- Sec_Stack_Addr : Address := Null_Address;
- -- Address of currently allocated secondary stack
-
- Current_Excep : aliased EO;
- -- Exception occurrence that contains the information for the
- -- current exception. Note that any exception in the same task
- -- destroys this information, so the data in this variable must
- -- be copied out before another exception can occur.
-
- end record;
+ type ATSD is new System.Soft_Links.TSD;
end System.Threads;
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-21 11:12 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-21 11:12 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux, x86-windows
Compiled on x86-FreeBSD
--
2003-11-21 Vasiliy Fofanov <fofanov@act-europe.fr>
* 5wsystem.ads: Enable zero cost exception.
2003-11-21 Jerome Guitton <guitton@act-europe.fr>
* 5ztiitho.adb: Remove an unreferenced variable.
2003-11-21 Thomas Quinot <quinot@act-europe.fr>
* adaint.c: For FreeBSD, use mkstemp.
2003-11-21 Arnaud Charlet <charlet@act-europe.fr>
* gnatlbr.adb: Now reference Gnat_Static_Version_String.
2003-11-21 Robert Dewar <dewar@gnat.com>
* bld.adb: Remove useless USE of gnatvsn
* gnatchop.adb: Minor reformatting
Clean up version handling to be more consistent
* gnatxref.adb: Minor reformatting
* gprcmd.adb: Minor reformatting
Fix output of copyright to be more consistent with other tools
2003-11-21 Vincent Celier <celier@gnat.com>
* make.adb (Scan_Make_Args): Do not transmit --RTS= to gnatlink
2003-11-21 Sergey Rybin <rybin@act-europe.fr>
* atree.adb (Initialize): Add initializations for global variables
used in New_Copy_Tree.
* cstand.adb (Create_Standard): Add call to Initialize_Scanner (with
Internal_Source_File as the actual).
Put the set of statements creating Any_Character before the set of
statements creating Any_Array to have Any_Character fully initialized
when it is used in creating Any_Array.
* scn.adb (Initialize_Scanner): Do not set Comes_From_Source ON and do
not call Scan in case if the actual is Internal_Source_File
Add 2003 to copyright note.
* sinput.adb (Source_First, Source_Last, Source_Text): Add code for
processing Internal_Source_File.
* types.ads: Add the constant Internal_Source_File representing the
source buffer for artificial source-code-like strings created within
the compiler (the definition of Source_File_Index is changed).
--
Index: 5wsystem.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wsystem.ads,v
retrieving revision 1.6
diff -u -r1.6 5wsystem.ads
--- 5wsystem.ads 21 Oct 2003 13:41:52 -0000 1.6
+++ 5wsystem.ads 20 Nov 2003 18:18:33 -0000
@@ -138,7 +138,7 @@
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False;
Index: 5ztiitho.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ztiitho.adb,v
retrieving revision 1.2
diff -u -r1.2 5ztiitho.adb
--- 5ztiitho.adb 17 Nov 2003 14:58:14 -0000 1.2
+++ 5ztiitho.adb 20 Nov 2003 18:18:33 -0000
@@ -43,7 +43,6 @@
procedure taskCreateHookAdd (createHookFunction : FUNCPTR);
pragma Import (C, taskCreateHookAdd, "taskCreateHookAdd");
- Result : OSI.STATUS;
begin
taskCreateHookAdd (Register'Access);
end Initialize_Task_Hooks;
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.23
diff -u -r1.23 adaint.c
--- adaint.c 17 Nov 2003 14:58:14 -0000 1.23
+++ adaint.c 20 Nov 2003 18:18:34 -0000
@@ -667,7 +667,7 @@
strcpy (path, "GNAT-XXXXXX");
-#if defined (linux) && !defined (__vxworks)
+#if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
return mkstemp (path);
#elif defined (__Lynx__)
mktemp (path);
@@ -742,7 +742,7 @@
free (pname);
}
-#elif defined (linux)
+#elif defined (linux) || defined (__FreeBSD__)
#define MAX_SAFE_PATH 1000
char *tmpdir = getenv ("TMPDIR");
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.9
diff -u -r1.9 atree.adb
--- atree.adb 20 Nov 2003 09:53:58 -0000 1.9
+++ atree.adb 20 Nov 2003 18:18:34 -0000
@@ -882,6 +882,11 @@
Dummy := New_Node (N_Error, No_Location);
Set_Name1 (Error, Error_Name);
Set_Error_Posted (Error, True);
+
+ -- Set global variables for New_Copy_Tree:
+ NCT_Hash_Tables_Used := False;
+ NCT_Table_Entries := 0;
+ NCT_Hash_Table_Setup := False;
end Initialize;
--------------------------
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.3
diff -u -r1.3 bld.adb
--- bld.adb 20 Nov 2003 09:53:58 -0000 1.3
+++ bld.adb 20 Nov 2003 18:18:35 -0000
@@ -40,7 +40,7 @@
with Erroutc; use Erroutc;
with Err_Vars; use Err_Vars;
-with Gnatvsn; use Gnatvsn;
+with Gnatvsn;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.11
diff -u -r1.11 cstand.adb
--- cstand.adb 10 Nov 2003 17:29:58 -0000 1.11
+++ cstand.adb 20 Nov 2003 18:18:35 -0000
@@ -38,6 +38,7 @@
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Ttypef; use Ttypef;
+with Scn;
with Sem_Mech; use Sem_Mech;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -259,10 +260,10 @@
-- by Initialize_Standard in the semantics module.
procedure Create_Standard is
- Decl_S : List_Id;
+ Decl_S : List_Id := New_List;
-- List of declarations in Standard
- Decl_A : List_Id;
+ Decl_A : List_Id := New_List;
-- List of declarations in ASCII
Decl : Node_Id;
@@ -297,7 +298,9 @@
-- Start of processing for Create_Standard
begin
- Decl_S := New_List;
+ -- Initialize scanner for internal scans of literals
+
+ Scn.Initialize_Scanner (No_Unit, Internal_Source_File);
-- First step is to create defining identifiers for each entity
@@ -414,7 +417,6 @@
declare
LIS : Nat;
-
begin
if Debug_Flag_M then
LIS := 64;
@@ -657,7 +659,6 @@
Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII));
Set_Ekind (Standard_Entity (S_ASCII), E_Package);
- Decl_A := New_List; -- for ASCII declarations
Set_Visible_Declarations (Pspec, Decl_A);
-- Create control character definitions in package ASCII. Note that
@@ -791,6 +792,18 @@
Set_Prim_Alignment (Any_Access);
Make_Name (Any_Access, "an access type");
+ Any_Character := New_Standard_Entity;
+ Set_Ekind (Any_Character, E_Enumeration_Type);
+ Set_Scope (Any_Character, Standard_Standard);
+ Set_Etype (Any_Character, Any_Character);
+ Set_Is_Unsigned_Type (Any_Character);
+ Set_Is_Character_Type (Any_Character);
+ Init_Esize (Any_Character, Standard_Character_Size);
+ Init_RM_Size (Any_Character, 8);
+ Set_Prim_Alignment (Any_Character);
+ Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
+ Make_Name (Any_Character, "a character type");
+
Any_Array := New_Standard_Entity;
Set_Ekind (Any_Array, E_String_Type);
Set_Scope (Any_Array, Standard_Standard);
@@ -809,18 +822,6 @@
Set_Is_Unsigned_Type (Any_Boolean);
Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean));
Make_Name (Any_Boolean, "a boolean type");
-
- Any_Character := New_Standard_Entity;
- Set_Ekind (Any_Character, E_Enumeration_Type);
- Set_Scope (Any_Character, Standard_Standard);
- Set_Etype (Any_Character, Any_Character);
- Set_Is_Unsigned_Type (Any_Character);
- Set_Is_Character_Type (Any_Character);
- Init_Esize (Any_Character, Standard_Character_Size);
- Init_RM_Size (Any_Character, 8);
- Set_Prim_Alignment (Any_Character);
- Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
- Make_Name (Any_Character, "a character type");
Any_Composite := New_Standard_Entity;
Set_Ekind (Any_Composite, E_Array_Type);
Index: gnatchop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatchop.adb,v
retrieving revision 1.9
diff -u -r1.9 gnatchop.adb
--- gnatchop.adb 17 Nov 2003 14:58:15 -0000 1.9
+++ gnatchop.adb 20 Nov 2003 18:18:35 -0000
@@ -37,11 +37,6 @@
procedure Gnatchop is
- Cwrite : constant String :=
- "GNATCHOP " &
- Gnatvsn.Gnat_Version_String &
- " Copyright 1998-2000, Ada Core Technologies Inc.";
-
Terminate_Program : exception;
-- Used to terminate execution immediately
@@ -57,9 +52,13 @@
Gnat_Cmd : String_Access;
-- Command to execute the GNAT compiler
- Gnat_Args : Argument_List_Access := new Argument_List'
- (new String'("-c"), new String'("-x"), new String'("ada"),
- new String'("-gnats"), new String'("-gnatu"));
+ Gnat_Args : Argument_List_Access :=
+ new Argument_List'
+ (new String'("-c"),
+ new String'("-x"),
+ new String'("ada"),
+ new String'("-gnats"),
+ new String'("-gnatu"));
-- Arguments used in Gnat_Cmd call
EOF : constant Character := Character'Val (26);
@@ -1110,6 +1109,7 @@
else
Error_Msg ("-k# requires numeric parameter");
end if;
+
return False;
end if;
end loop;
@@ -1129,23 +1129,31 @@
end;
when 'p' =>
- Preserve_Mode := True;
+ Preserve_Mode := True;
when 'q' =>
- Quiet_Mode := True;
+ Quiet_Mode := True;
when 'r' =>
Source_References := True;
when 'v' =>
- Verbose_Mode := True;
- Put_Line (Standard_Error, Cwrite);
+ Verbose_Mode := True;
+
+ -- Why is following written to standard error. Most other
+ -- tools write to standard output ???
+
+ Put (Standard_Error, "GNATCHOP ");
+ Put (Standard_Error, Gnatvsn.Gnat_Version_String);
+ Put_Line
+ (Standard_Error,
+ " Copyright 1998-2000, Ada Core Technologies Inc.");
when 'w' =>
- Overwrite_Files := True;
+ Overwrite_Files := True;
when 'x' =>
- Exit_On_Error := True;
+ Exit_On_Error := True;
when others =>
null;
Index: gnatlbr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlbr.adb,v
retrieving revision 1.8
diff -u -r1.8 gnatlbr.adb
--- gnatlbr.adb 14 Nov 2003 10:24:43 -0000 1.8
+++ gnatlbr.adb 20 Nov 2003 18:18:35 -0000
@@ -50,7 +50,7 @@
with System;
procedure GnatLbr is
- pragma Ident (Gnat_Version_String);
+ pragma Ident (Gnat_Static_Version_String);
type Lib_Mode is (None, Create, Set, Delete);
Next_Arg : Integer;
Index: gnatxref.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatxref.adb,v
retrieving revision 1.6
diff -u -r1.6 gnatxref.adb
--- gnatxref.adb 21 Oct 2003 13:42:08 -0000 1.6
+++ gnatxref.adb 20 Nov 2003 18:18:35 -0000
@@ -24,10 +24,10 @@
-- --
------------------------------------------------------------------------------
-with Xr_Tabls; use Xr_Tabls;
-with Xref_Lib; use Xref_Lib;
-with Osint; use Osint;
-with Types; use Types;
+with Xr_Tabls; use Xr_Tabls;
+with Xref_Lib; use Xref_Lib;
+with Osint; use Osint;
+with Types; use Types;
with Gnatvsn;
with Opt;
@@ -35,10 +35,9 @@
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
-with GNAT.Strings; use GNAT.Strings;
+with GNAT.Strings; use GNAT.Strings;
procedure Gnatxref is
-
Search_Unused : Boolean := False;
Local_Symbols : Boolean := True;
Prj_File : File_Name_String;
@@ -209,8 +208,6 @@
-----------------
procedure Write_Usage is
- use Ada.Text_IO;
-
begin
Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String
& " Copyright 1998-2003, Ada Core Technologies Inc.");
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.3
diff -u -r1.3 gprcmd.adb
--- gprcmd.adb 20 Nov 2003 09:53:58 -0000 1.3
+++ gprcmd.adb 20 Nov 2003 18:18:35 -0000
@@ -39,23 +39,22 @@
-- stamp copy file time stamp from file1 to file2
-- prefix get the prefix of the GNAT installation
+with Gnatvsn;
+with Osint; use Osint;
+with Namet; use Namet;
+
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Regpat; use GNAT.Regpat;
-with Gnatvsn;
-with Osint; use Osint;
-with Namet; use Namet;
+
procedure Gprcmd is
-- ??? comments are thin throughout this unit
- Version : constant String :=
- "GPRCMD " & Gnatvsn.Gnat_Version_String &
- " Copyright 2002-2003, Free Software Fundation, Inc.";
procedure Cat (File : String);
-- Print the contents of file on standard output.
@@ -350,7 +349,13 @@
begin
if Cmd = "-v" then
- Put_Line (Standard_Error, Version);
+
+ -- Should this be on Standard_Error ???
+
+ Put (Standard_Error, "GPRCMD ");
+ Put (Standard_Error, Gnatvsn.Gnat_Version_String);
+ Put_Line (Standard_Error,
+ " Copyright 2002-2003, Free Software Fundation, Inc.");
Usage;
elsif Cmd = "pwd" then
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.23
diff -u -r1.23 make.adb
--- make.adb 17 Nov 2003 14:58:15 -0000 1.23
+++ make.adb 20 Nov 2003 18:18:36 -0000
@@ -6551,7 +6551,6 @@
then
Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Binder, And_Save => And_Save);
- Add_Switch (Argv, Linker, And_Save => And_Save);
if Argv'Length <= 6 or else Argv (6) /= '=' then
Make_Failed ("missing path for --RTS");
Index: scn.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scn.adb,v
retrieving revision 1.8
diff -u -r1.8 scn.adb
--- scn.adb 21 Oct 2003 13:42:18 -0000 1.8
+++ scn.adb 20 Nov 2003 18:18:36 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -264,7 +264,9 @@
-- Set default for Comes_From_Source. All nodes built now until we
-- reenter the analyzer will have Comes_From_Source set to True
- Set_Comes_From_Source_Default (True);
+ if Index /= Internal_Source_File then
+ Set_Comes_From_Source_Default (True);
+ end if;
-- Check license if GNAT type header possibly present
@@ -278,7 +280,9 @@
-- call Scan. Scan initial token (note this initializes Prev_Token,
-- Prev_Token_Ptr).
- Scan;
+ if Index /= Internal_Source_File then
+ Scan;
+ end if;
-- Clear flags for reserved words used as indentifiers
Index: sinput.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinput.adb,v
retrieving revision 1.6
diff -u -r1.6 sinput.adb
--- sinput.adb 21 Oct 2003 13:42:22 -0000 1.6
+++ sinput.adb 20 Nov 2003 18:18:36 -0000
@@ -1110,17 +1110,31 @@
function Source_First (S : SFI) return Source_Ptr is
begin
- return Source_File.Table (S).Source_First;
+ if S = Internal_Source_File then
+ return Internal_Source_Ptr'First;
+ else
+ return Source_File.Table (S).Source_First;
+ end if;
end Source_First;
function Source_Last (S : SFI) return Source_Ptr is
begin
- return Source_File.Table (S).Source_Last;
+ if S = Internal_Source_File then
+ return Internal_Source_Ptr'Last;
+ else
+ return Source_File.Table (S).Source_Last;
+ end if;
+
end Source_Last;
function Source_Text (S : SFI) return Source_Buffer_Ptr is
begin
- return Source_File.Table (S).Source_Text;
+ if S = Internal_Source_File then
+ return Internal_Source_Ptr;
+ else
+ return Source_File.Table (S).Source_Text;
+ end if;
+
end Source_Text;
function Template (S : SFI) return SFI is
Index: types.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/types.ads,v
retrieving revision 1.10
diff -u -r1.10 types.ads
--- types.ads 21 Oct 2003 13:42:23 -0000 1.10
+++ types.ads 20 Nov 2003 18:18:36 -0000
@@ -569,8 +569,13 @@
No_Unit : constant Unit_Number_Type := -1;
-- Special value used to signal no unit
- type Source_File_Index is new Nat;
+ type Source_File_Index is new Int range -1 .. Int'Last;
-- Type used to index the source file table (see package Sinput)
+
+ Internal_Source_File : constant Source_File_Index :=
+ Source_File_Index'First;
+ -- Value used to indicate the buffer for the source-code-like strings
+ -- internally created withing the compiler (see package Sinput)
No_Source_File : constant Source_File_Index := 0;
-- Value used to indicate no source file present
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-20 10:28 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-20 10:28 UTC (permalink / raw)
To: gcc-patches
Various Ada 0Y docs
Project file improvements
Incorporate FreeBSD configuration
Tested on x86-linux
--
2003-11-19 Arnaud Charlet <charlet@act-europe.fr>
* gnatmem.adb: Clean up verbose output.
* gprcmd.adb: Change copyright to FSF.
2003-11-19 Vincent Celier <celier@gnat.com>
* symbols.adb: (Initialize): New parameters Reference, Symbol_Policy
and Version (ignored).
* symbols.ads: (Policy): New type
(Initialize): New parameter Reference, Symbol_Policy and
Library_Version.
Remove parameter Force.
Minor reformatting.
* snames.ads, snames.adb: New standard names
Library_Reference_Symbol_File and Library_Symbol_Policy
* mlib-prj.adb:
(Build_Library): Call Build_Dinamic_Library with the Symbol_Data of the
project.
* mlib-tgt.adb:
(Build_Dynamic_Library): New parameter Symbol_Data (ignored)
* mlib-tgt.ads: (Build_Dynamic_Library): New parameter Symbol_Data
* prj.adb: (Project_Empty): New component Symbol_Data
* prj.ads: (Policy, Symbol_Record): New types
(Project_Data): New component Symbol_Data
* prj-attr.adb:
New attributes Library_Symbol_File, Library_Symbol_Policy and
Library_Reference_Symbol_File.
* prj-nmsc.adb:
(Ada_Check): When project is a Stand-Alone library project, process
attribute Library_Symbol_File, Library_Symbol_Policy and
Library_Reference_Symbol_File.
* 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb,
5wml-tgt.adb, 5zml-tgt.adb, 5lml-tgt.adb,
5sml-tgt.adb (Build_Dynamic_Library): New parameter
Symbol_Data (ignored).
* 5vml-tgt.adb (VMS_Options): Remove --for-linker=gsmatch=equal,1,0
(Build_Dynamic_Library): New parameter Symbol_Data. New internal
functions Option_File_Name and Version_String. Set new options of
gnatsym related to symbol file, symbol policy and reference symbol
file.
* 5vsymbol.adb:
Extensive modifications to take into account the reference symbol file,
the symbol policy, the library version and to put in the symbol file the
minor and major IDs.
* bld.adb (Process_Declarative_Items): Put second argument of
gprcmd to_absolute between single quotes, to avoid problems with
Windows.
* bld-io.adb: Update Copyright notice.
(Flush): Remove last character of a line, if it is a back slash, to
avoid make problems.
* gnatsym.adb:
Implement new scheme with reference symbol file and symbol policy.
* g-os_lib.ads: (Is_Directory): Clarify comment
2003-11-19 Robert Dewar <dewar@gnat.com>
* atree.adb: Move New_Copy_Tree global variables to head of package
* errout.adb: Minor reformatting
2003-11-19 Javier Miranda <miranda@gnat.com>
* sem_ch4.adb: (Diagnose_Call): Improve error message.
Add reference to Ada0Y (AI-50217)
* sem_ch6.adb, sem_ch8.adb, sem_type.adb,
sem_util.adb: Add reference to AI-50217
* sinfo.ads: (N_With_Clause): Document fields referred to AI-50217
* sprint.adb: Add reference to Ada0Y (AI-50217, AI-287)
* sem_aggr.adb: Complete documentation of AI-287 changes
* par-ch4.adb: Document previous changes.
* lib-load.adb, lib-writ.adb, einfo.ads, par-ch10.adb,
sem_cat.adb, sem_ch3.adb, sem_ch10.adb, sem_ch12.adb: Add references to
Ada0Y (AI-50217)
* exp_aggr.adb: Add references to AI-287 in previous changes
2003-11-19 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb:
(Add_Call_By_Copy_Node): Do not original node of rewritten expression
in the rewriting is the result of an inlined call.
* exp_ch6.adb (Add_Call_By_Copy_Node): If actual for (in-)out
parameter is a type conversion, use original node to construct the
post-call assignment, because expression may have been rewritten, e.g.
if it is a packed array.
* sem_attr.adb:
(Resolve_Attribute, case 'Constrained): Attribute is legal in an inlined
body, just as it is in an instance.
Categorization routines
* sem_ch12.adb (Analyze_Association, Instantiate_Formal_Subprogram,
Instantiate_Object): Set proper sloc reference for message on missing
actual.
2003-11-19 Thomas Quinot <quinot@act-europe.fr>
* Makefile.in: Add FreeBSD libgnat pairs.
* usage.adb: Fix typo in usage message.
2003-11-19 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: On powerpc-wrs-vxworksae: Add s-thread.ad?,
s-thrini.ad? and s-tiitho.adb to the full runtime, to support the
pragma Thread_Body.
Remove i-vthrea.ad? and s-tpae65.ad?, not needed anymore.
* s-thread.adb: This file is now a dummy implementation of
System.Thread.
2003-11-19 Sergey Rybin <rybin@act-europe.fr>
* rtsfind.adb (Initialize): Add initialization for RTE_Is_Available
2003-11-19 Emmanuel Briot <briot@act-europe.fr>
* xref_lib.adb (Parse_Identifier_Info): Add handling of generic
instanciation references in the parent type description.
--
Index: 5aml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5aml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5aml-tgt.adb
--- 5aml-tgt.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 5aml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -108,6 +108,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -117,6 +118,7 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Index: 5bml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5bml-tgt.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5bml-tgt.adb
--- 5bml-tgt.adb 14 Nov 2003 10:24:42 -0000 1.2
+++ 5bml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -120,6 +120,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -129,6 +130,7 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
Index: 5gml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5gml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5gml-tgt.adb
--- 5gml-tgt.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 5gml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -103,6 +103,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -112,6 +113,7 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Index: 5hml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5hml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5hml-tgt.adb
--- 5hml-tgt.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5hml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -102,6 +102,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -111,6 +112,7 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Index: 5lml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5lml-tgt.adb,v
retrieving revision 1.5
diff -u -p -r1.5 5lml-tgt.adb
--- 5lml-tgt.adb 21 Oct 2003 13:41:52 -0000 1.5
+++ 5lml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -106,6 +106,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -115,6 +116,7 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Index: 5sml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5sml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5sml-tgt.adb
--- 5sml-tgt.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5sml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -100,6 +100,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -109,6 +110,7 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Index: 5vml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5vml-tgt.adb
--- 5vml-tgt.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5vml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -59,13 +59,9 @@ package body MLib.Tgt is
-- Options to use when invoking gcc to build the dynamic library
No_Start_Files : aliased String := "-nostartfiles";
- For_Linker_Opt : aliased String := "--for-linker=symvec.opt";
- Gsmatch : aliased String := "--for-linker=gsmatch=equal,1,0";
- VMS_Options : constant Argument_List :=
- (No_Start_Files'Access, For_Linker_Opt'Access, Gsmatch'Access);
-
--- Command : String_Access;
+ VMS_Options : Argument_List :=
+ (No_Start_Files'Access, null);
Gnatsym_Name : constant String := "gnatsym";
@@ -134,6 +130,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -143,10 +140,9 @@ package body MLib.Tgt is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Lib_Address);
- pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
- Opt_File_Name : constant String := "symvec.opt";
+
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@@ -163,6 +159,13 @@ package body MLib.Tgt is
-- file name of an interface of the SAL.
-- For other libraries, always return True.
+ function Option_File_Name return String;
+ -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
+
+ function Version_String return String;
+ -- Returns Lib_Version if not empty, otherwise returns "1".
+ -- Fails gnatmake if Lib_Version is not the image of a positive number.
+
------------------
-- Is_Interface --
------------------
@@ -192,7 +195,57 @@ package body MLib.Tgt is
end if;
end Is_Interface;
+ ----------------------
+ -- Option_File_Name --
+ ----------------------
+
+ function Option_File_Name return String is
+ begin
+ if Symbol_Data.Symbol_File = No_Name then
+ return "symvec.opt";
+
+ else
+ return Get_Name_String (Symbol_Data.Symbol_File);
+ end if;
+ end Option_File_Name;
+
+ --------------------
+ -- Version_String --
+ --------------------
+
+ function Version_String return String is
+ Version : Integer := 0;
+ begin
+ if Lib_Version = "" then
+ return "1";
+
+ else
+ begin
+ Version := Integer'Value (Lib_Version);
+
+ if Version <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ return Lib_Version;
+
+ exception
+ when Constraint_Error =>
+ Fail ("illegal version """, Lib_Version,
+ """ (on VMS version must be a positive number)");
+ return "";
+ end;
+ end if;
+ end Version_String;
+
+ Opt_File_Name : constant String := Option_File_Name;
+ For_Linker_Opt : constant String_Access :=
+ new String'("--for-linker=" & Opt_File_Name);
+ Version : constant String := Version_String;
+
begin
+ VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
+
for J in Inter'Range loop
To_Lower (Inter (J).all);
end loop;
@@ -288,18 +341,60 @@ package body MLib.Tgt is
end;
end if;
- -- Allocate the argument list and put the symbol file name
+ -- Allocate the argument list and put the symbol file name, the
+ -- reference (if any) and the policy (if not autonomous).
- Arguments := new Argument_List (1 .. Ofiles'Length + 2);
+ Arguments := new Argument_List (1 .. Ofiles'Length + 8);
- Last_Argument := 1;
+ Last_Argument := 0;
+
+ -- Verbosity
if Verbose_Mode then
+ Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-v");
+ end if;
+
+ -- Version number (major ID)
+
+ if Lib_Version /= "" then
Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-V");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Version);
end if;
+ -- Symbol file
+
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-s");
+ Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Opt_File_Name);
+
+ -- Reference Symbol File
+
+ if Symbol_Data.Reference /= No_Name then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-r");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) :=
+ new String'(Get_Name_String (Symbol_Data.Reference));
+ end if;
+
+ -- Policy
+
+ case Symbol_Data.Symbol_Policy is
+ when Autonomous =>
+ null;
+
+ when Compliant =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-c");
+
+ when Controlled =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-C");
+ end case;
-- Add each relevant object file
Index: 5vsymbol.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vsymbol.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5vsymbol.adb
--- 5vsymbol.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5vsymbol.adb 20 Nov 2003 09:48:28 -0000
@@ -36,10 +36,32 @@ package body Symbols is
Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
Equal_Data : constant String := "=DATA)";
Equal_Procedure : constant String := "=PROCEDURE)";
+ Gsmatch : constant String := "gsmatch=equal,";
Symbol_File_Name : String_Access := null;
-- Name of the symbol file
+ Sym_Policy : Policy := Autonomous;
+ -- The symbol policy. Set by Initialize
+
+ Major_ID : Integer := 1;
+ -- The Major ID. May be modified by Initialize if Library_Version is
+ -- specified or if it is read from the reference symbol file.
+
+ Soft_Major_ID : Boolean := True;
+ -- False if library version is specified in procedure Initialize.
+ -- When True, Major_ID may be modified if found in the reference symbol
+ -- file.
+
+ Minor_ID : Natural := 0;
+ -- The Minor ID. May be modified if read from the reference symbol file
+
+ Soft_Minor_ID : Boolean := True;
+ -- False if symbol policy is Autonomous, if library version is specified
+ -- in procedure Initialize and is not the same as the major ID read from
+ -- the reference symbol file. When True, Minor_ID may be increased in
+ -- Compliant symbol policy.
+
subtype Byte is Character;
-- Object files are stream of bytes, but some of these bytes, those for
-- the names of the symbols, are ASCII characters.
@@ -67,6 +89,9 @@ package body Symbols is
Number_Of_Characters : Natural := 0;
-- The number of characters of each section
+ -- The following variables are used by procedure Process when reading an
+ -- object file.
+
Code : Number := 0;
Length : Natural := 0;
@@ -87,6 +112,10 @@ package body Symbols is
procedure Get (N : out Natural);
-- Read two bytes from the object file, LSByte first, as a Natural
+
+ function Image (N : Integer) return String;
+ -- Returns the image of N, without the initial space
+
-----------
-- Equal --
-----------
@@ -121,15 +150,32 @@ package body Symbols is
N := Natural (Result);
end Get;
+ -----------
+ -- Image --
+ -----------
+
+ function Image (N : Integer) return String is
+ Result : constant String := N'Img;
+ begin
+ if Result (Result'First) = ' ' then
+ return Result (Result'First + 1 .. Result'Last);
+
+ else
+ return Result;
+ end if;
+ end Image;
+
----------------
-- Initialize --
----------------
procedure Initialize
- (Symbol_File : String;
- Force : Boolean;
- Quiet : Boolean;
- Success : out Boolean)
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean)
is
File : Ada.Text_IO.File_Type;
Line : String (1 .. 1_000);
@@ -140,6 +186,40 @@ package body Symbols is
Symbol_File_Name := new String'(Symbol_File);
+ -- Record the policy
+
+ Sym_Policy := Symbol_Policy;
+
+ -- Record the version (Major ID)
+
+ if Version = "" then
+ Major_ID := 1;
+ Soft_Major_ID := True;
+
+ else
+ begin
+ Major_ID := Integer'Value (Version);
+ Soft_Major_ID := False;
+
+ if Major_ID <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ exception
+ when Constraint_Error =>
+ if not Quiet then
+ Put_Line ("Version """ & Version & """ is illegal.");
+ Put_Line ("On VMS, version must be a positive number");
+ end if;
+
+ Success := False;
+ return;
+ end;
+ end if;
+
+ Minor_ID := 0;
+ Soft_Minor_ID := Sym_Policy /= Autonomous;
+
-- Empty the symbol tables
Symbol_Table.Set_Last (Original_Symbols, 0);
@@ -149,11 +229,11 @@ package body Symbols is
Success := True;
- -- If Force is not set, attempt to read the symbol file
+ -- If policy is not autonomous, attempt to read the reference file
- if not Force then
+ if Sym_Policy /= Autonomous then
begin
- Open (File, In_File, Symbol_File);
+ Open (File, In_File, Reference);
exception
when Ada.Text_IO.Name_Error =>
@@ -161,7 +241,7 @@ package body Symbols is
when X : others =>
if not Quiet then
- Put_Line ("could not open """ & Symbol_File & """");
+ Put_Line ("could not open """ & Reference & """");
Put_Line (Exception_Message (X));
end if;
@@ -169,20 +249,31 @@ package body Symbols is
return;
end;
+ -- Read line by line
+
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
+ -- Ignore empty lines
+
if Last = 0 then
null;
+ -- Ignore lines starting with "case_sensitive="
+
elsif Last > Case_Sensitive'Length
and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
then
null;
+ -- Line starting with "SYMBOL_VECTOR=("
+
elsif Last > Symbol_Vector'Length
and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
then
+
+ -- SYMBOL_VECTOR=(<symbol>=DATA)
+
if Last > Symbol_Vector'Length + Equal_Data'Length and then
Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
then
@@ -195,6 +286,8 @@ package body Symbols is
Kind => Data,
Present => True);
+ -- SYMBOL_VECTOR=(<symbol>=PROCEDURE)
+
elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
and then
Line (Last - Equal_Procedure'Length + 1 .. Last) =
@@ -209,9 +302,11 @@ package body Symbols is
Kind => Proc,
Present => True);
+ -- Anything else is incorrectly formatted
+
else
if not Quiet then
- Put_Line ("symbol file """ & Symbol_File &
+ Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted:");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
@@ -221,10 +316,95 @@ package body Symbols is
return;
end if;
+ -- Lines with "gsmatch=equal,<Major_ID>,<Minor_Id>
+
+ elsif Last > Gsmatch'Length
+ and then Line (1 .. Gsmatch'Length) = Gsmatch
+ then
+ declare
+ Start : Positive := Gsmatch'Length + 1;
+ Finish : Positive := Start;
+ OK : Boolean := True;
+ ID : Integer;
+
+ begin
+ loop
+ if Line (Finish) not in '0' .. '9'
+ or else Finish >= Last - 1
+ then
+ OK := False;
+ exit;
+ end if;
+
+ exit when Line (Finish + 1) = ',';
+
+ Finish := Finish + 1;
+ end loop;
+
+ if OK then
+ ID := Integer'Value (Line (Start .. Finish));
+ OK := ID /= 0;
+
+ -- If Soft_Major_ID is True, it means that
+ -- Library_Version was not specified.
+
+ if Soft_Major_ID then
+ Major_ID := ID;
+
+ -- If the Major ID in the reference file is different
+ -- from the Library_Version, then the Minor ID will be 0
+ -- because there is no point in taking the Minor ID in
+ -- the reference file, or incrementing it. So, we set
+ -- Soft_Minor_ID to False, so that we don't modify
+ -- the Minor_ID later.
+
+ elsif Major_ID /= ID then
+ Soft_Minor_ID := False;
+ end if;
+
+ Start := Finish + 2;
+ Finish := Start;
+
+ loop
+ if Line (Finish) not in '0' .. '9' then
+ OK := False;
+ exit;
+ end if;
+
+ exit when Finish = Last;
+
+ Finish := Finish + 1;
+ end loop;
+
+ -- Only set Minor_ID if Soft_Minor_ID is True (see above)
+
+ if OK and then Soft_Minor_ID then
+ Minor_ID := Integer'Value (Line (Start .. Finish));
+ end if;
+ end if;
+
+ -- If OK is not True, that means the line is not correctly
+ -- formatted.
+
+ if not OK then
+ if not Quiet then
+ Put_Line ("symbol file """ & Reference &
+ """ is incorrectly formatted");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+ end;
+
+ -- Anything else is incorrectly formatted
+
else
if not Quiet then
Put_Line ("unexpected line in symbol file """ &
- Symbol_File & """");
+ Reference & """");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
@@ -247,7 +427,8 @@ package body Symbols is
Success : out Boolean)
is
begin
- -- Open the object file. Return with Success = False if this fails.
+ -- Open the object file with Byte_IO. Return with Success = False if
+ -- this fails.
begin
Open (File, In_File, Object_File);
@@ -410,8 +591,9 @@ package body Symbols is
else
- -- First find if the symbols in the symbol file are also in the
- -- object files.
+ -- First find if the symbols in the reference symbol file are also
+ -- in the object files. Note that this is not done if the policy is
+ -- Autonomous, because no reference symbol file has been read.
-- Expect the first symbol in the symbol file to also be the first
-- in Complete_Symbols.
@@ -450,13 +632,27 @@ package body Symbols is
-- If the symbol is not found, mark it as such in the table
if not Found then
- if not Quiet then
+ if (not Quiet) or else Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is no longer present in the object files");
end if;
+ if Sym_Policy = Controlled then
+ Success := False;
+ return;
+
+ elsif Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+
Original_Symbols.Table (Index_1).Present := False;
Free (Original_Symbols.Table (Index_1).Name);
+
+ if Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
end if;
end loop;
@@ -466,6 +662,18 @@ package body Symbols is
S_Data := Complete_Symbols.Table (Index);
if S_Data.Present then
+
+ if Sym_Policy = Controlled then
+ Put_Line ("symbol """ & S_Data.Name.all &
+ """ is not in the reference symbol file");
+ Success := False;
+ return;
+
+ elsif Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) :=
S_Data;
@@ -500,6 +708,13 @@ package body Symbols is
Put (File, Case_Sensitive);
Put_Line (File, "NO");
+
+ -- Put the version IDs
+
+ Put (File, Gsmatch);
+ Put (File, Image (Major_ID));
+ Put (File, ',');
+ Put_Line (File, Image (Minor_ID));
-- And we are done
Index: 5wml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5wml-tgt.adb
--- 5wml-tgt.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5wml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -91,6 +91,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -99,6 +100,7 @@ package body MLib.Tgt is
is
pragma Unreferenced (Ofiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Auto_Init);
Index: 5zml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zml-tgt.adb,v
retrieving revision 1.1
diff -u -p -r1.1 5zml-tgt.adb
--- 5zml-tgt.adb 21 Oct 2003 13:41:52 -0000 1.1
+++ 5zml-tgt.adb 20 Nov 2003 09:48:28 -0000
@@ -93,6 +93,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -106,6 +107,7 @@ package body MLib.Tgt is
pragma Unreferenced (Interfaces);
pragma Unreferenced (Lib_Filename);
pragma Unreferenced (Lib_Dir);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.8
diff -u -p -r1.8 atree.adb
--- atree.adb 29 Oct 2003 10:26:12 -0000 1.8
+++ atree.adb 20 Nov 2003 09:48:28 -0000
@@ -347,6 +347,35 @@ package body Atree is
Table_Increment => Alloc.Orig_Nodes_Increment,
Table_Name => "Orig_Nodes");
+ ----------------------------------------
+ -- Global_Variables for New_Copy_Tree --
+ ----------------------------------------
+
+ -- These global variables are used by New_Copy_Tree. See description
+ -- of the body of this subprogram for details. Global variables can be
+ -- safely used by New_Copy_Tree, since there is no case of a recursive
+ -- call from the processing inside New_Copy_Tree.
+
+ NCT_Hash_Threshhold : constant := 20;
+ -- If there are more than this number of pairs of entries in the
+ -- map, then Hash_Tables_Used will be set, and the hash tables will
+ -- be initialized and used for the searches.
+
+ NCT_Hash_Tables_Used : Boolean := False;
+ -- Set to True if hash tables are in use
+
+ NCT_Table_Entries : Nat;
+ -- Count entries in table to see if threshhold is reached
+
+ NCT_Hash_Table_Setup : Boolean := False;
+ -- Set to True if hash table contains data. We set this True if we
+ -- setup the hash table with data, and leave it set permanently
+ -- from then on, this is a signal that second and subsequent users
+ -- of the hash table must clear the old entries before reuse.
+
+ subtype NCT_Header_Num is Int range 0 .. 511;
+ -- Defines range of headers in hash tables (512 headers)
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -958,29 +987,6 @@ package body Atree is
-- there are fewer entries, then the map is searched sequentially
-- (because setting up a hash table for only a few entries takes
-- more time than it saves.
-
- -- Global variables are safe for this purpose, since there is no case
- -- of a recursive call from the processing inside New_Copy_Tree.
-
- NCT_Hash_Threshhold : constant := 20;
- -- If there are more than this number of pairs of entries in the
- -- map, then Hash_Tables_Used will be set, and the hash tables will
- -- be initialized and used for the searches.
-
- NCT_Hash_Tables_Used : Boolean := False;
- -- Set to True if hash tables are in use
-
- NCT_Table_Entries : Nat;
- -- Count entries in table to see if threshhold is reached
-
- NCT_Hash_Table_Setup : Boolean := False;
- -- Set to True if hash table contains data. We set this True if we
- -- setup the hash table with data, and leave it set permanently
- -- from then on, this is a signal that second and subsequent users
- -- of the hash table must clear the old entries before reuse.
-
- subtype NCT_Header_Num is Int range 0 .. 511;
- -- Defines range of headers in hash tables (512 headers)
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
-- Hash function used for hash operations
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.2
diff -u -p -r1.2 bld.adb
--- bld.adb 10 Nov 2003 17:29:58 -0000 1.2
+++ bld.adb 20 Nov 2003 09:48:28 -0000
@@ -40,7 +40,7 @@ with GNAT.OS_Lib; use GNAT
with Erroutc; use Erroutc;
with Err_Vars; use Err_Vars;
-with Gnatvsn;
+with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
@@ -1559,9 +1559,9 @@ package body Bld is
Put ("src.list_file:=" &
"$(strip $(shell gprcmd to_absolute $(");
Put (Project_Name);
- Put (".base_dir) $(");
+ Put (".base_dir) '$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")))");
+ Put_Line (")'))");
if In_Case then
if Source_List_File_Declaration = False then
@@ -1595,9 +1595,9 @@ package body Bld is
Put (".obj_dir:=" &
"$(strip $(shell gprcmd to_absolute $(");
Put (Project_Name);
- Put (".base_dir) $(");
+ Put (".base_dir) '$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")))");
+ Put_Line (")'))");
elsif Item_Name = Snames.Name_Exec_Dir then
@@ -1611,9 +1611,9 @@ package body Bld is
Put ("EXEC_DIR:=" &
"$(strip $(shell gprcmd to_absolute $(");
Put (Project_Name);
- Put (".base_dir) $(");
+ Put (".base_dir) '$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")))");
+ Put_Line (")'))");
elsif Item_Name = Snames.Name_Main then
Index: bld-io.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld-io.adb,v
retrieving revision 1.1
diff -u -p -r1.1 bld-io.adb
--- bld-io.adb 21 Oct 2003 13:41:58 -0000 1.1
+++ bld-io.adb 20 Nov 2003 09:48:28 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2003 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- --
@@ -132,6 +132,7 @@ package body Bld.IO is
-----------
procedure Flush is
+ Last : Natural;
begin
if Lines (Current).Length /= 0 then
Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ &
@@ -141,7 +142,18 @@ package body Bld.IO is
for J in 1 .. Current - 1 loop
if not Lines (J).Suppressed then
- Text_IO.Put_Line (File, Lines (J).Value (1 .. Lines (J).Length));
+ Last := Lines (J).Length;
+
+ -- The last character of a line cannot be a back slash ('\'),
+ -- otherwise make has a problem. The only real place were it
+ -- should happen is for directory names on Windows, and then
+ -- this terminal back slash is not needed.
+
+ if Last > 0 and then Lines (J).Value (Last) = '\' then
+ Last := Last - 1;
+ end if;
+
+ Text_IO.Put_Line (File, Lines (J).Value (1 .. Last));
end if;
end loop;
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.16
diff -u -p -r1.16 einfo.ads
--- einfo.ads 17 Nov 2003 14:58:14 -0000 1.16
+++ einfo.ads 20 Nov 2003 09:48:29 -0000
@@ -1162,6 +1162,9 @@ package Einfo is
-- types, i.e. record types (Java classes) that hold pointers to each
-- other. If such a type is an access type, it has no explicit freeze
-- node, so that the back-end does not attempt to elaborate it.
+-- Currently this flag is also used to implement Ada0Y (AI-50217).
+-- It will be renamed to From_Limited_With after removal of the current
+-- GNAT with_type clause???
-- Full_View (Node11)
-- Present in all type and subtype entities and in deferred constants.
@@ -2385,7 +2388,7 @@ package Einfo is
-- Present in non-generic package entities that are not instances.
-- The elements of this list are the shadow entities created for the
-- types and local packages that are declared in a package that appears
--- in a limited_with clause.
+-- in a limited_with clause (Ada0Y: AI-50217)
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
@@ -2554,9 +2557,9 @@ package Einfo is
-- is other than a power of 2.
-- Non_Limited_View (Node17)
--- Present in incomplete types that are the shadow entities
--- created when analyzing a limited_with_clause. Points to the
--- definining entity in the original declaration.
+-- Present in incomplete types that are the shadow entities created
+-- when analyzing a limited_with_clause (Ada0Y: AI-50217). Points to
+-- the defining entity in the original declaration.
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
Index: errout.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/errout.adb,v
retrieving revision 1.11
diff -u -p -r1.11 errout.adb
--- errout.adb 17 Nov 2003 14:58:14 -0000 1.11
+++ errout.adb 20 Nov 2003 09:48:29 -0000
@@ -1409,11 +1409,11 @@ package body Errout is
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
end if;
- -- Set all (???) the error nodes to Empty:
+ -- Set the error nodes to Empty to avoid uninitialized variable
+ -- references for saves/restores/moves.
Error_Msg_Node_1 := Empty;
Error_Msg_Node_2 := Empty;
-
end Initialize;
-----------------
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.9
diff -u -p -r1.9 exp_aggr.adb
--- exp_aggr.adb 17 Nov 2003 14:58:14 -0000 1.9
+++ exp_aggr.adb 20 Nov 2003 09:48:29 -0000
@@ -71,8 +71,8 @@ package body Exp_Aggr is
-- sorted order.
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.
+ -- N is an aggregate (record or array). Checks the presence of default
+ -- initialization (<>) in any component (Ada0Y: AI-287)
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
@@ -1540,8 +1540,8 @@ package body Exp_Aggr is
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
- -- Give support to default initialization of limited types and
- -- components
+ -- Ada0Y (AI-287): Give support to default initialization of limited
+ -- types and components
if (Nkind (Target) = N_Identifier
and then Is_Limited_Type (Etype (Target)))
@@ -1678,8 +1678,8 @@ package body Exp_Aggr is
Check_Ancestor_Discriminants (Entity (A));
end if;
- -- If the ancestor part is a limited type, a recursive call
- -- expands the ancestor.
+ -- Ada0Y (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;
@@ -4144,6 +4144,9 @@ package body Exp_Aggr is
or else Has_Controlled_Component (Base_Type (Typ))
then
Convert_To_Assignments (N, Typ);
+
+ -- Ada0Y (AI-287): In case of default initialized components we convert
+ -- the aggregate into assignments.
elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ);
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch6.adb
--- exp_ch6.adb 10 Nov 2003 17:29:58 -0000 1.11
+++ exp_ch6.adb 20 Nov 2003 09:48:29 -0000
@@ -541,7 +541,28 @@ package body Exp_Ch6 is
if Nkind (Actual) = N_Type_Conversion then
V_Typ := Etype (Expression (Actual));
- Var := Make_Var (Expression (Actual));
+
+ -- If the formal is an (in-)out parameter, capture the name
+ -- of the variable in order to build the post-call assignment.
+ -- The variable itself may have been expanded, for example if
+ -- it is a complex bit-packed array, so we need to recover the
+ -- original to ensure that we have the proper target for the
+ -- assignment. Examine the slocs of the two nodes to determine
+ -- whether the rewriting is an expansion, or a substitution done
+ -- on an inlined body, in which case it must be respected.
+
+ declare
+ Orig : constant Node_Id := Original_Node (Expression (Actual));
+ begin
+ if Orig /= Expression (Actual)
+ and then Sloc (Orig) = Sloc (Expression (Actual))
+ then
+ Var := Make_Var (Orig);
+ else
+ Var := Make_Var (Expression (Actual));
+ end if;
+ end;
+
Crep := not Same_Representation
(Etype (Formal), Etype (Expression (Actual)));
else
Index: gnatmem.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatmem.adb,v
retrieving revision 1.9
diff -u -p -r1.9 gnatmem.adb
--- gnatmem.adb 21 Oct 2003 13:42:08 -0000 1.9
+++ gnatmem.adb 20 Nov 2003 09:48:29 -0000
@@ -228,7 +228,7 @@ procedure Gnatmem is
procedure Usage is
begin
New_Line;
- Put ("GNATMEM Pro ");
+ Put ("GNATMEM ");
Put (Gnat_Version_String);
Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc.");
New_Line;
Index: gnatsym.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatsym.adb,v
retrieving revision 1.1
diff -u -p -r1.1 gnatsym.adb
--- gnatsym.adb 21 Oct 2003 13:42:08 -0000 1.1
+++ gnatsym.adb 20 Nov 2003 09:48:29 -0000
@@ -37,7 +37,9 @@
-- only on OpenVMS.
-- gnatsym takes as parameters:
--- - the name of the symbol file to create or update
+-- - the name of the symbol file to create
+-- - (optional) the policy to create the symbol file
+-- - (optional) the name of the reference symbol file
-- - the names of one or more object files where the symbols are found
with GNAT.Command_Line; use GNAT.Command_Line;
@@ -52,13 +54,16 @@ with Table;
procedure Gnatsym is
+ Empty_String : aliased String := "";
+ Empty : constant String_Access := Empty_String'Unchecked_Access;
+ -- To initialize variables Reference and Version_String
+
Copyright_Displayed : Boolean := False;
-- A flag to prevent multiple display of the Copyright notice
Success : Boolean := True;
- Force : Boolean := False;
- -- True when -f switcxh is used
+ Symbol_Policy : Policy := Autonomous;
Verbose : Boolean := False;
-- True when -v switch is used
@@ -66,9 +71,15 @@ procedure Gnatsym is
Quiet : Boolean := False;
-- True when -q switch is used
- Symbol_File_Name : String_Access;
+ Symbol_File_Name : String_Access := null;
-- The name of the symbol file
+ Reference_Symbol_File_Name : String_Access := Empty;
+ -- The name of the reference symbol file
+
+ Version_String : String_Access := Empty;
+ -- The version of the library. Used on VMS.
+
package Object_Files is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
@@ -113,19 +124,32 @@ procedure Gnatsym is
procedure Parse_Cmd_Line is
begin
loop
- case GNAT.Command_Line.Getopt ("f q v") is
+ case GNAT.Command_Line.Getopt ("c C q r: s: v V:") is
when ASCII.NUL =>
exit;
- when 'f' =>
- Force := True;
+ when 'c' =>
+ Symbol_Policy := Compliant;
+
+ when 'C' =>
+ Symbol_Policy := Controlled;
when 'q' =>
Quiet := True;
+ when 'r' =>
+ Reference_Symbol_File_Name :=
+ new String'(GNAT.Command_Line.Parameter);
+
+ when 's' =>
+ Symbol_File_Name := new String'(GNAT.Command_Line.Parameter);
+
when 'v' =>
Verbose := True;
+ when 'V' =>
+ Version_String := new String'(GNAT.Command_Line.Parameter);
+
when others =>
Fail ("invalid switch: ", Full_Switch);
end case;
@@ -141,13 +165,8 @@ procedure Gnatsym is
begin
exit when S'Length = 0;
- if Symbol_File_Name = null then
- Symbol_File_Name := S;
-
- else
- Object_Files.Increment_Last;
- Object_Files.Table (Object_Files.Last) := S;
- end if;
+ Object_Files.Increment_Last;
+ Object_Files.Table (Object_Files.Last) := S;
end;
end loop;
exception
@@ -162,11 +181,17 @@ procedure Gnatsym is
procedure Usage is
begin
- Write_Line ("gnatsym [options] sym_file object_file {object_file}");
+ Write_Line ("gnatsym [options] object_file {object_file}");
Write_Eol;
- Write_Line (" -f Force generation of symbol file");
- Write_Line (" -q Quiet mode");
- Write_Line (" -v Verbose mode");
+ Write_Line (" -c Compliant policy");
+ Write_Line (" -C Controlled policy");
+ Write_Line (" -q Quiet mode");
+ Write_Line (" -r<ref> Reference symbol file name");
+ Write_Line (" -s<sym> Symbol file name");
+ Write_Line (" -v Verbose mode");
+ Write_Line (" -V<ver> Version");
+ Write_Eol;
+ Write_Line ("Specifying a symbol file with -s<sym> is compulsory");
Write_Eol;
end Usage;
@@ -188,7 +213,7 @@ begin
-- If there is no symbol file or no object files on the command line,
-- display the usage and exit with an error status.
- if Object_Files.Last = 0 then
+ if Symbol_File_Name = null or else Object_Files.Last = 0 then
Usage;
OS_Exit (1);
@@ -199,9 +224,16 @@ begin
Write_Line ("""");
end if;
- -- Initialize the symbol file
+ -- Initialize the symbol file and, if specified, read the reference
+ -- file.
- Symbols.Initialize (Symbol_File_Name.all, Force, Quiet, Success);
+ Symbols.Initialize
+ (Symbol_File => Symbol_File_Name.all,
+ Reference => Reference_Symbol_File_Name.all,
+ Symbol_Policy => Symbol_Policy,
+ Quiet => Quiet,
+ Version => Version_String.all,
+ Success => Success);
-- Process the object files in order. Stop as soon as there is
-- something wrong.
@@ -231,6 +263,8 @@ begin
Finalize (Quiet, Success);
end if;
+
+ -- Fail if there was anything wrong
if not Success then
Fail ("unable to build symbol file");
Index: g-os_lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-os_lib.ads,v
retrieving revision 1.7
diff -u -p -r1.7 g-os_lib.ads
--- g-os_lib.ads 21 Oct 2003 13:42:04 -0000 1.7
+++ g-os_lib.ads 20 Nov 2003 09:48:29 -0000
@@ -416,15 +416,21 @@ pragma Elaborate_Body (OS_Lib);
function Is_Absolute_Path (Name : String) return Boolean;
-- Returns True if Name is an absolute path name, i.e. it designates
- -- a directory absolutely, rather than relative to another directory.
+ -- a file or a directory absolutely, rather than relative to another
+ -- directory.
function Is_Regular_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
- -- regular file. Returns True if so, False otherwise.
+ -- regular file. Returns True if so, False otherwise. Name may be an
+ -- absolute path name or a relative path name, including a simple file
+ -- name. If it is a relative path name, it is relative to the current
+ -- working directory.
function Is_Directory (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of a directory.
- -- Returns True if so, False otherwise.
+ -- Returns True if so, False otherwise. Name may be an absolute path
+ -- name or a relative path name, including a simple file name. If it is
+ -- a relative path name, it is relative to the current working directory.
function Is_Readable_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.2
diff -u -p -r1.2 gprcmd.adb
--- gprcmd.adb 10 Nov 2003 17:29:59 -0000 1.2
+++ gprcmd.adb 20 Nov 2003 09:48:29 -0000
@@ -55,7 +55,7 @@ procedure Gprcmd is
Version : constant String :=
"GPRCMD " & Gnatvsn.Gnat_Version_String &
- " Copyright 2002-2003, Ada Core Technologies Inc.";
+ " Copyright 2002-2003, Free Software Fundation, Inc.";
procedure Cat (File : String);
-- Print the contents of file on standard output.
Index: lib-load.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-load.adb,v
retrieving revision 1.7
diff -u -p -r1.7 lib-load.adb
--- lib-load.adb 10 Nov 2003 17:29:59 -0000 1.7
+++ lib-load.adb 20 Nov 2003 09:48:29 -0000
@@ -519,8 +519,8 @@ package body Lib.Load is
-- legitimately occurs (e.g. two package bodies that contain
-- inlined subprogram referenced by the other).
- -- We also ignore limited_with clauses, because their purpose is
- -- precisely to create legal circular structures.
+ -- Ada0Y (AI-50217): We also ignore limited_with clauses, because
+ -- their purpose is precisely to create legal circular structures.
if Loading (Unum)
and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.9
diff -u -p -r1.9 lib-writ.adb
--- lib-writ.adb 14 Nov 2003 10:24:43 -0000 1.9
+++ lib-writ.adb 20 Nov 2003 09:48:29 -0000
@@ -214,7 +214,8 @@ package body Lib.Writ is
Item := First (Context_Items (Cunit));
while Present (Item) loop
- -- limited_with_clauses do not create dependencies.
+ -- Ada0Y (AI-50217): limited with_clauses do not create
+ -- dependencies
if Nkind (Item) = N_With_Clause
and then not (Limited_Present (Item))
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.4
diff -u -p -r1.4 mlib-prj.adb
--- mlib-prj.adb 21 Oct 2003 13:42:09 -0000 1.4
+++ mlib-prj.adb 20 Nov 2003 09:48:29 -0000
@@ -1313,6 +1313,7 @@ package body MLib.Prj is
Interfaces => Arguments (1 .. Argument_Number),
Lib_Filename => Lib_Filename.all,
Lib_Dir => Lib_Dirpath.all,
+ Symbol_Data => Data.Symbol_Data,
Driver_Name => Driver_Name,
Lib_Address => DLL_Address.all,
Lib_Version => Lib_Version.all,
Index: mlib-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-tgt.adb,v
retrieving revision 1.5
diff -u -p -r1.5 mlib-tgt.adb
--- mlib-tgt.adb 21 Oct 2003 13:42:09 -0000 1.5
+++ mlib-tgt.adb 20 Nov 2003 09:48:30 -0000
@@ -79,6 +79,7 @@ package body MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -92,6 +93,7 @@ package body MLib.Tgt is
pragma Unreferenced (Interfaces);
pragma Unreferenced (Lib_Filename);
pragma Unreferenced (Lib_Dir);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
Index: mlib-tgt.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-tgt.ads,v
retrieving revision 1.4
diff -u -p -r1.4 mlib-tgt.ads
--- mlib-tgt.ads 21 Oct 2003 13:42:10 -0000 1.4
+++ mlib-tgt.ads 20 Nov 2003 09:48:30 -0000
@@ -113,6 +113,7 @@ package MLib.Tgt is
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
@@ -125,23 +126,33 @@ package MLib.Tgt is
-- Afiles is the list of ALI files for the Ada object files.
-- Options is a list of options to be passed to the tool (gcc or other)
-- that effectively builds the dynamic library.
+ --
-- Interfaces is the list of ALI files for the interfaces of a SAL.
-- It is empty if the library is not a SAL.
+ --
-- Lib_Filename is the name of the library, without any prefix or
-- extension. For example, on Unix, if Lib_Filename is "toto", the name of
-- the library file will be "libtoto.so".
+ --
-- Lib_Dir is the directory path where the library will be located.
+ --
-- Lib_Address is the base address of the library for a non relocatable
-- library, given as an hexadecimal string.
- -- For OSes that support symbolic links, Lib_Version, if non null, is
- -- the actual file name of the library. For example on Unix,
- -- if Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
- -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which will
- -- be the actual library file.
+ --
+ -- For OSes that support symbolic links, Lib_Version, if non null,
+ -- is the actual file name of the library. For example on Unix, if
+ -- Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
+ -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which
+ -- will be the actual library file.
+ --
-- Relocatable indicates if the library should be relocatable or not,
-- for those OSes that actually support non relocatable dynamic libraries.
-- Relocatable indicates that automatic elaboration/finalization must be
-- indicated to the linker, if possible.
+ --
+ -- Symbol_Data is used for some patforms, including VMS, to generate
+ -- the symbols to be exported by the library.
+ --
-- Note: Depending on the OS, some of the parameters may not be taken
-- into account. For example, on Linux, Foreign, Afiles Lib_Address and
-- Relocatable are ignored.
Index: par-ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch10.adb,v
retrieving revision 1.6
diff -u -p -r1.6 par-ch10.adb
--- par-ch10.adb 17 Nov 2003 14:58:15 -0000 1.6
+++ par-ch10.adb 20 Nov 2003 09:48:30 -0000
@@ -782,7 +782,7 @@ package body Ch10 is
-- Processing for WITH clause
- -- First check for LIMITED WITH
+ -- Ada0Y (AI-50217): First check for LIMITED WITH
if Token = Tok_Limited then
Has_Limited := True;
Index: par-ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch4.adb,v
retrieving revision 1.8
diff -u -p -r1.8 par-ch4.adb
--- par-ch4.adb 17 Nov 2003 14:58:16 -0000 1.8
+++ par-ch4.adb 20 Nov 2003 09:48:30 -0000
@@ -1127,6 +1127,9 @@ package body Ch4 is
-- Error recovery: can raise Error_Resync
+ -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
+ -- to Ada0Y limited aggregates (AI-287)
+
function P_Aggregate_Or_Paren_Expr return Node_Id is
Aggregate_Node : Node_Id;
Expr_List : List_Id;
@@ -1372,6 +1375,10 @@ package body Ch4 is
-- been handled directly.
-- Error recovery: can raise Error_Resync
+
+ -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
+ -- rules have been extended to give support to Ada0Y limited
+ -- aggregates (AI-287)
function P_Record_Or_Array_Component_Association return Node_Id is
Assoc_Node : Node_Id;
Index: prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.adb,v
retrieving revision 1.12
diff -u -p -r1.12 prj.adb
--- prj.adb 17 Nov 2003 14:58:16 -0000 1.12
+++ prj.adb 20 Nov 2003 09:48:30 -0000
@@ -96,6 +96,7 @@ package body Prj is
Standalone_Library => False,
Lib_Interface_ALIs => Nil_String,
Lib_Auto_Init => False,
+ Symbol_Data => No_Symbols,
Sources_Present => True,
Sources => Nil_String,
Source_Dirs => Nil_String,
Index: prj.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.ads,v
retrieving revision 1.14
diff -u -p -r1.14 prj.ads
--- prj.ads 17 Nov 2003 14:58:16 -0000 1.14
+++ prj.ads 20 Nov 2003 09:48:30 -0000
@@ -75,6 +75,21 @@ package Prj is
type Lib_Kind is (Static, Dynamic, Relocatable);
+ type Policy is (Autonomous, Compliant, Controlled);
+ -- See explaination about this type in package Symbol
+
+ type Symbol_Record is record
+ Symbol_File : Name_Id := No_Name;
+ Reference : Name_Id := No_Name;
+ Symbol_Policy : Policy := Autonomous;
+ end record;
+ -- Type to keep the symbol data to be used when building a shared library
+
+ No_Symbols : Symbol_Record :=
+ (Symbol_File => No_Name,
+ Reference => No_Name,
+ Symbol_Policy => Autonomous);
+
function Empty_String return Name_Id;
type Project_Id is new Nat;
@@ -417,6 +432,9 @@ package Prj is
Lib_Auto_Init : Boolean := False;
-- For non static Standalone Library Project Files, indicate if
-- the library initialisation should be automatic.
+
+ Symbol_Data : Symbol_Record := No_Symbols;
+ -- Symbol file name, reference symbol file name, symbol policy
Sources_Present : Boolean := True;
-- A flag that indicates if there are sources in this project file.
Index: prj-attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-attr.adb,v
retrieving revision 1.10
diff -u -p -r1.10 prj-attr.adb
--- prj-attr.adb 21 Oct 2003 13:42:12 -0000 1.10
+++ prj-attr.adb 20 Nov 2003 09:48:30 -0000
@@ -69,6 +69,9 @@ package body Prj.Attr is
"LVlibrary_options#" &
"SVlibrary_src_dir#" &
"SVlibrary_gcc#" &
+ "SVlibrary_symbol_file#" &
+ "SVlibrary_symbol_policy#" &
+ "SVlibrary_reference_symbol_file#" &
"LVmain#" &
"LVlanguages#" &
"SVmain_language#" &
Index: prj-nmsc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-nmsc.adb,v
retrieving revision 1.14
diff -u -p -r1.14 prj-nmsc.adb
--- prj-nmsc.adb 17 Nov 2003 14:58:16 -0000 1.14
+++ prj-nmsc.adb 20 Nov 2003 09:48:30 -0000
@@ -1350,16 +1350,32 @@ package body Prj.Nmsc is
(Snames.Name_Library_Src_Dir,
Data.Decl.Attributes);
- Auto_Init_Supported
- : constant Boolean :=
- MLib.Tgt.
- Standalone_Library_Auto_Init_Is_Supported;
+ Lib_Symbol_File : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Symbol_File,
+ Data.Decl.Attributes);
+
+ Lib_Symbol_Policy : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Symbol_Policy,
+ Data.Decl.Attributes);
+
+ Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Reference_Symbol_File,
+ Data.Decl.Attributes);
+
+ Auto_Init_Supported : constant Boolean :=
+ MLib.Tgt.
+ Standalone_Library_Auto_Init_Is_Supported;
+
+ OK : Boolean := True;
begin
pragma Assert (Lib_Interfaces.Kind = List);
- -- It is a library project file if attribute Library_Interface
- -- is defined.
+ -- It is a stand-alone library project file if attribute
+ -- Library_Interface is defined.
if not Lib_Interfaces.Default then
declare
@@ -1566,102 +1582,257 @@ package body Prj.Nmsc is
Lib_Auto_Init.Location);
end if;
end if;
+ end;
- if Lib_Src_Dir.Value /= Empty_String then
- declare
- Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
+ -- If attribute Library_Src_Dir is defined and not the
+ -- empty string, check if the directory exist and is not
+ -- the object directory or one of the source directories.
+ -- This is the directory where copies of the interface
+ -- sources will be copied. Note that this directory may be
+ -- the library directory.
+
+ if Lib_Src_Dir.Value /= Empty_String then
+ declare
+ Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
- begin
- Locate_Directory
- (Dir_Id, Data.Display_Directory,
- Data.Library_Src_Dir,
- Data.Display_Library_Src_Dir);
-
- -- Comment needed here ???
-
- if Data.Library_Src_Dir = No_Name then
-
- -- Get the absolute name of the library directory
- -- that does not exist, to report an error.
-
- declare
- Dir_Name : constant String :=
- Get_Name_String (Dir_Id);
- begin
- if Is_Absolute_Path (Dir_Name) then
- Err_Vars.Error_Msg_Name_1 := Dir_Id;
+ begin
+ Locate_Directory
+ (Dir_Id, Data.Display_Directory,
+ Data.Library_Src_Dir,
+ Data.Display_Library_Src_Dir);
- else
- Get_Name_String (Data.Directory);
+ -- If directory does not exist, report an error
- if Name_Buffer (Name_Len) /=
- Directory_Separator
- then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) :=
- Directory_Separator;
- end if;
+ if Data.Library_Src_Dir = No_Name then
- Name_Buffer
- (Name_Len + 1 ..
- Name_Len + Dir_Name'Length) :=
- Dir_Name;
- Name_Len := Name_Len + Dir_Name'Length;
- Err_Vars.Error_Msg_Name_1 := Name_Find;
- end if;
+ -- Get the absolute name of the library directory
+ -- that does not exist, to report an error.
- -- Report the error
+ declare
+ Dir_Name : constant String :=
+ Get_Name_String (Dir_Id);
- Error_Msg
- (Project,
- "Directory { does not exist",
- Lib_Src_Dir.Location);
- end;
+ begin
+ if Is_Absolute_Path (Dir_Name) then
+ Err_Vars.Error_Msg_Name_1 := Dir_Id;
- -- And comment needed here ???
+ else
+ Get_Name_String (Data.Directory);
+
+ if Name_Buffer (Name_Len) /=
+ Directory_Separator
+ then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) :=
+ Directory_Separator;
+ end if;
+
+ Name_Buffer
+ (Name_Len + 1 ..
+ Name_Len + Dir_Name'Length) :=
+ Dir_Name;
+ Name_Len := Name_Len + Dir_Name'Length;
+ Err_Vars.Error_Msg_Name_1 := Name_Find;
+ end if;
+
+ -- Report the error
- elsif Data.Library_Src_Dir = Data.Object_Directory then
Error_Msg
(Project,
- "directory to copy interfaces cannot be " &
- "the object directory",
+ "Directory { does not exist",
Lib_Src_Dir.Location);
- Data.Library_Src_Dir := No_Name;
+ end;
- -- And comment needed here ???
+ -- Report an error if it is the same as the object
+ -- directory.
- else
- declare
- Src_Dirs : String_List_Id := Data.Source_Dirs;
- Src_Dir : String_Element;
- begin
- while Src_Dirs /= Nil_String loop
- Src_Dir := String_Elements.Table (Src_Dirs);
- Src_Dirs := Src_Dir.Next;
-
- if Data.Library_Src_Dir = Src_Dir.Value then
- Error_Msg
- (Project,
- "directory to copy interfaces cannot " &
- "be one of the source directories",
- Lib_Src_Dir.Location);
- Data.Library_Src_Dir := No_Name;
- exit;
- end if;
- end loop;
- end;
+ elsif Data.Library_Src_Dir = Data.Object_Directory then
+ Error_Msg
+ (Project,
+ "directory to copy interfaces cannot be " &
+ "the object directory",
+ Lib_Src_Dir.Location);
+ Data.Library_Src_Dir := No_Name;
- if Data.Library_Src_Dir /= No_Name
- and then Current_Verbosity = High
+ -- Check if it is the same as one of the source
+ -- directories.
+
+ else
+ declare
+ Src_Dirs : String_List_Id := Data.Source_Dirs;
+ Src_Dir : String_Element;
+
+ begin
+ while Src_Dirs /= Nil_String loop
+ Src_Dir := String_Elements.Table (Src_Dirs);
+ Src_Dirs := Src_Dir.Next;
+
+ -- Report an error if it is one of the
+ -- source directories.
+
+ if Data.Library_Src_Dir = Src_Dir.Value then
+ Error_Msg
+ (Project,
+ "directory to copy interfaces cannot " &
+ "be one of the source directories",
+ Lib_Src_Dir.Location);
+ Data.Library_Src_Dir := No_Name;
+ exit;
+ end if;
+ end loop;
+ end;
+
+ if Data.Library_Src_Dir /= No_Name
+ and then Current_Verbosity = High
+ then
+ Write_Str ("Directory to copy interfaces =""");
+ Write_Str (Get_Name_String (Data.Library_Dir));
+ Write_Line ("""");
+ end if;
+ end if;
+ end;
+ end if;
+
+ if not Lib_Symbol_File.Default then
+ Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
+
+ Get_Name_String (Lib_Symbol_File.Value);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "symbol file name cannot be an empty string",
+ Lib_Symbol_File.Location);
+
+ else
+ OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
+
+ if OK then
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = '/'
+ or else Name_Buffer (J) = Directory_Separator
then
- Write_Str ("Directory to copy interfaces =""");
- Write_Str (Get_Name_String (Data.Library_Dir));
- Write_Line ("""");
+ OK := False;
+ exit;
end if;
- end if;
- end;
+ end loop;
+ end if;
+
+ if not OK then
+ Error_Msg_Name_1 := Lib_Symbol_File.Value;
+ Error_Msg
+ (Project,
+ "symbol file name { is illegal. " &
+ "Name canot include directory info.",
+ Lib_Symbol_File.Location);
+ end if;
end if;
- end;
+ end if;
+
+ if not Lib_Symbol_Policy.Default then
+ declare
+ Value : constant String :=
+ To_Lower
+ (Get_Name_String (Lib_Symbol_Policy.Value));
+
+ begin
+ if Value = "autonomous" or else Value = "default" then
+ Data.Symbol_Data.Symbol_Policy := Autonomous;
+
+ elsif Value = "compliant" then
+ Data.Symbol_Data.Symbol_Policy := Compliant;
+
+ elsif Value = "controlled" then
+ Data.Symbol_Data.Symbol_Policy := Controlled;
+
+ else
+ Error_Msg
+ (Project,
+ "illegal value for Library_Symbol_Policy",
+ Lib_Symbol_Policy.Location);
+ end if;
+ end;
+ end if;
+
+ if Lib_Ref_Symbol_File.Default then
+ if Data.Symbol_Data.Symbol_Policy /= Autonomous then
+ Error_Msg
+ (Project,
+ "a reference symbol file need to be defined",
+ Lib_Symbol_Policy.Location);
+ end if;
+
+ else
+ Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value;
+
+ Get_Name_String (Lib_Symbol_File.Value);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "reference symbol file name cannot be an empty string",
+ Lib_Symbol_File.Location);
+
+ else
+ OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
+
+ if OK then
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = '/'
+ or else Name_Buffer (J) = Directory_Separator
+ then
+ OK := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if not OK then
+ Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
+ Error_Msg
+ (Project,
+ "reference symbol file { name is illegal. " &
+ "Name canot include directory info.",
+ Lib_Ref_Symbol_File.Location);
+ end if;
+
+ if not Is_Regular_File
+ (Get_Name_String (Data.Object_Directory) &
+ Directory_Separator &
+ Get_Name_String (Lib_Ref_Symbol_File.Value))
+ then
+ Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
+ Error_Msg
+ (Project,
+ "library reference symbol file { does not exist",
+ Lib_Ref_Symbol_File.Location);
+ end if;
+
+ if Data.Symbol_Data.Symbol_File /= No_Name then
+ declare
+ Symbol : String :=
+ Get_Name_String
+ (Data.Symbol_Data.Symbol_File);
+
+ Reference : String :=
+ Get_Name_String
+ (Data.Symbol_Data.Reference);
+
+ begin
+ Canonical_Case_File_Name (Symbol);
+ Canonical_Case_File_Name (Reference);
+
+ if Symbol = Reference then
+ Error_Msg
+ (Project,
+ "reference symbol file and symbol file " &
+ "cannot be the same file",
+ Lib_Ref_Symbol_File.Location);
+ end if;
+ end;
+ end if;
+ end if;
+ end if;
end if;
end Standalone_Library;
end if;
Index: rtsfind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/rtsfind.adb,v
retrieving revision 1.8
diff -u -p -r1.8 rtsfind.adb
--- rtsfind.adb 21 Oct 2003 13:42:13 -0000 1.8
+++ rtsfind.adb 20 Nov 2003 09:48:30 -0000
@@ -258,6 +258,8 @@ package body Rtsfind is
for J in RE_Id loop
RE_Table (J) := Empty;
end loop;
+
+ RTE_Is_Available := False;
end Initialize;
------------
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_aggr.adb
--- sem_aggr.adb 17 Nov 2003 14:58:16 -0000 1.10
+++ sem_aggr.adb 20 Nov 2003 09:48:30 -0000
@@ -866,6 +866,8 @@ package body Sem_Aggr is
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
+ -- Ada0Y (AI-287): Limited aggregates allowed
+
elsif Is_Limited_Type (Typ)
and not Extensions_Allowed
then
@@ -1915,12 +1917,17 @@ package body Sem_Aggr is
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
- elsif Is_Limited_Type (Typ)
- and not Extensions_Allowed
- then
- Error_Msg_N ("aggregate type cannot be limited", N);
- Explain_Limited_Type (Typ, N);
- return;
+ elsif Is_Limited_Type (Typ) then
+
+ -- Ada0Y (AI-287): Limited aggregates are allowed
+
+ if Extensions_Allowed then
+ null;
+ else
+ Error_Msg_N ("aggregate type cannot be limited", N);
+ Explain_Limited_Type (Typ, N);
+ return;
+ end if;
elsif Is_Class_Wide_Type (Typ) then
Error_Msg_N ("aggregate cannot be of a class-wide type", N);
@@ -2023,12 +2030,12 @@ package body Sem_Aggr is
Mbox_Present : Boolean := False;
Others_Mbox : Boolean := False;
- -- Variables used in case of default initialization to provide a
- -- functionality similar to Others_Etype. Mbox_Present indicates
- -- that the component takes its default initialization; Others_Mbox
- -- indicates that at least one component takes its default initiali-
- -- zation. Similar to Others_Etype, they are also updated as a side
- -- effect of function Get_Value.
+ -- Ada0Y (AI-287): Variables used in case of default initialization to
+ -- provide a functionality similar to Others_Etype. Mbox_Present
+ -- indicates that the component takes its default initialization;
+ -- Others_Mbox indicates that at least one component takes its default
+ -- initialization. Similar to Others_Etype, they are also updated as a
+ -- side effect of function Get_Value.
procedure Add_Association
(Component : Entity_Id;
@@ -2212,6 +2219,7 @@ package body Sem_Aggr is
and then Comes_From_Source (Compon)
and then not In_Instance_Body
then
+ -- Ada0Y (AI-287): Limited aggregates are allowed
if Extensions_Allowed
and then Present (Expression (Assoc))
@@ -2251,6 +2259,10 @@ package body Sem_Aggr is
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
+ -- Ada0Y (AI-287): In case of default initialization of
+ -- components, we duplicate the corresponding default
+ -- expression (from the record type declaration).
+
if Box_Present (Assoc) then
Others_Mbox := True;
Mbox_Present := True;
@@ -2845,9 +2857,10 @@ package body Sem_Aggr is
if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
- -- In case of default initialization of a limited component we
- -- pass the limited component to the expander. The expander will
- -- generate calls to the corresponding initialization subprograms.
+ -- Ada0Y (AI-287): In case of default initialization of a limited
+ -- component we pass the limited component to the expander. The
+ -- expander will generate calls to the corresponding initiali-
+ -- zation subprograms.
Add_Association
(Component => Component,
@@ -2884,6 +2897,9 @@ package body Sem_Aggr is
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
+
+ -- Ada0Y (AI-287): others choice may have expression or mbox
+
if No (Others_Etype)
and then not Others_Mbox
then
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_attr.adb
--- sem_attr.adb 4 Nov 2003 12:51:46 -0000 1.14
+++ sem_attr.adb 20 Nov 2003 09:48:30 -0000
@@ -2184,9 +2184,12 @@ package body Sem_Attr is
if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
-- If we are within an instance, the attribute must be legal
- -- because it was valid in the generic unit.
+ -- because it was valid in the generic unit. Ditto if this is
+ -- an inlining of a function declared in an instance.
- if In_Instance then
+ if In_Instance
+ or else In_Inlined_Body
+ then
return;
-- For sure OK if we have a real private type itself, but must
Index: sem_cat.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_cat.adb,v
retrieving revision 1.5
diff -u -p -r1.5 sem_cat.adb
--- sem_cat.adb 21 Oct 2003 13:42:18 -0000 1.5
+++ sem_cat.adb 20 Nov 2003 09:48:30 -0000
@@ -761,7 +761,7 @@ package body Sem_Cat is
return;
end if;
- -- Process explicit with_clauses that are not limited.
+ -- Ada0Y (AI-50217): Process explicit with_clauses that are not limited
declare
Item : Node_Id;
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.12
diff -u -p -r1.12 sem_ch10.adb
--- sem_ch10.adb 10 Nov 2003 17:29:59 -0000 1.12
+++ sem_ch10.adb 20 Nov 2003 09:48:30 -0000
@@ -77,6 +77,7 @@ package body Sem_Ch10 is
-- in a limited_with clause. If the package was not previously analyzed
-- then it also performs a basic decoration of the real entities; this
-- is required to do not pass non-decorated entities to the back-end.
+ -- Implements Ada0Y (AI-50217).
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
@@ -95,11 +96,12 @@ package body Sem_Ch10 is
-- and not in an inner frame.
procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id);
- -- if a child unit appears in a limited_with clause, there are implicit
+ -- If a child unit appears in a limited_with clause, there are implicit
-- limited_with clauses on all parents that are not already visible
-- through a regular with clause. This procedure creates the implicit
-- limited with_clauses for the parents and loads the corresponding units.
-- The shadow entities are created when the inserted clause is analyzed.
+ -- Implements Ada0Y (AI-50217).
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
-- When a child unit appears in a context clause, the implicit withs on
@@ -127,11 +129,11 @@ package body Sem_Ch10 is
procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses
- -- for current unit.
+ -- for current unit. Implements Ada0Y (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
- -- structures for the current compilation.
+ -- structures for the current compilation. Implements Ada0Y (AI-50217).
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
@@ -174,7 +176,7 @@ package body Sem_Ch10 is
procedure Remove_Limited_With_Clause (N : Node_Id);
-- Remove from visibility the shadow entities introduced for a package
- -- mentioned in a limited_with clause.
+ -- mentioned in a limited_with clause. Implements Ada0Y (AI-50217).
procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
@@ -611,6 +613,9 @@ package body Sem_Ch10 is
begin
Item := First (Context_Items (N));
while Present (Item) loop
+
+ -- Ada0Y (AI-50217): Do not consider limited-withed units
+
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
@@ -788,8 +793,8 @@ package body Sem_Ch10 is
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
-- b) The second pass add implicit limited_with clauses for
- -- the parents of child units.
- -- c) The third pass analyzes limited_with clauses.
+ -- the parents of child units (Ada0Y: AI-50217)
+ -- c) The third pass analyzes limited_with clauses (Ada0Y: AI-50217)
Item := First (Context_Items (N));
while Present (Item) loop
@@ -1590,8 +1595,8 @@ package body Sem_Ch10 is
begin
if Limited_Present (N) then
-
- -- Build visibility structures but do not analyze unit
+ -- Ada0Y (AI-50217): Build visibility structures but do not
+ -- analyze unit
Build_Limited_Views (N);
return;
@@ -4006,8 +4011,9 @@ package body Sem_Ch10 is
Unit_Name : Entity_Id;
begin
- -- We remove the context clauses in two phases: limited-views first
- -- and regular-views later (to maintain the stack model).
+ -- Ada0Y (AI-50217): We remove the context clauses in two phases:
+ -- limited-views first and regular-views later (to maintain the
+ -- stack model).
-- First Phase: Remove limited_with context clauses
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.27
diff -u -p -r1.27 sem_ch12.adb
--- sem_ch12.adb 17 Nov 2003 14:58:16 -0000 1.27
+++ sem_ch12.adb 20 Nov 2003 09:48:31 -0000
@@ -987,6 +987,7 @@ package body Sem_Ch12 is
Defining_Identifier (Analyzed_Formal));
if No (Match) then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
@@ -1075,6 +1076,7 @@ package body Sem_Ch12 is
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
@@ -1111,6 +1113,8 @@ package body Sem_Ch12 is
end loop;
if Num_Actuals > Num_Matched then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
+
if Present (Selector_Name (Actual)) then
Error_Msg_NE
("unmatched actual&",
@@ -2348,6 +2352,8 @@ 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
+
if From_With_Type (Gen_Unit) then
Error_Msg_N
("cannot instantiate a limited withed package", Gen_Id);
@@ -6620,6 +6626,7 @@ package body Sem_Ch12 is
end if;
else
+ Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
Error_Msg_NE
("missing actual&", Instantiation_Node, Formal_Sub);
Error_Msg_NE
@@ -6746,6 +6753,9 @@ package body Sem_Ch12 is
Subt_Decl : Node_Id := Empty;
begin
+ -- Sloc for error message on missing actual.
+ Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
+
if Get_Instance_Of (Formal_Id) /= Formal_Id then
Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
end if;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.21
diff -u -p -r1.21 sem_ch3.adb
--- sem_ch3.adb 14 Nov 2003 10:24:43 -0000 1.21
+++ sem_ch3.adb 20 Nov 2003 09:48:31 -0000
@@ -690,6 +690,10 @@ package body Sem_Ch3 is
-- if the designated type is.
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
+
+ -- Ada0Y (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));
-- The context is either a subprogram declaration or an access
@@ -857,9 +861,9 @@ 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.
- -- 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.
+ -- Ada0Y (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.
if From_With_Type (Desig) then
Set_From_With_Type (T);
@@ -2448,9 +2452,11 @@ package body Sem_Ch3 is
begin
Prev := Find_Type_Name (N);
- -- The full view, if present, now points to the current type. If the
- -- type was previously decorated when imported through a LIMITED WITH
- -- clause, it appears as incomplete but has no full view.
+ -- The full view, if present, now points to the current type
+
+ -- Ada0Y (AI-50217): If the type was previously decorated when imported
+ -- through a LIMITED WITH clause, it appears as incomplete but has no
+ -- full view.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
@@ -6234,8 +6240,8 @@ package body Sem_Ch3 is
or else Is_Limited_Composite (T))
and then not In_Instance
then
- -- Relax the strictness of the front-end in case of limited
- -- aggregates and extension aggregates.
+ -- Ada0Y (AI-287): Relax the strictness of the front-end in case of
+ -- limited aggregates and extension aggregates.
if Extensions_Allowed
and then (Nkind (Exp) = N_Aggregate
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.9
diff -u -p -r1.9 sem_ch4.adb
--- sem_ch4.adb 17 Nov 2003 14:58:16 -0000 1.9
+++ sem_ch4.adb 20 Nov 2003 09:48:31 -0000
@@ -342,6 +342,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).
+
if Extensions_Allowed
and then Nkind (Expression (E)) = N_Aggregate
then
@@ -3442,6 +3446,9 @@ 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
+ -- an entity from the limited view.
+
if not Analyzed (Etype (Actual))
and then From_With_Type (Etype (Actual))
then
Index: sem_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch6.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_ch6.adb
--- sem_ch6.adb 17 Nov 2003 14:58:17 -0000 1.10
+++ sem_ch6.adb 20 Nov 2003 09:48:31 -0000
@@ -4840,9 +4840,9 @@ package body Sem_Ch6 is
and then Ekind (Root_Type (Formal_Type)) =
E_Incomplete_Type)
then
-
- -- Incomplete tagged types that are made visible through
- -- a limited with_clause are valid formal types.
+ -- Ada0Y (AI-50217): Incomplete tagged types that are made
+ -- visible through a limited with_clause are valid formal
+ -- types.
if From_With_Type (Formal_Type)
and then Is_Tagged_Type (Formal_Type)
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_ch8.adb
--- sem_ch8.adb 14 Nov 2003 10:24:43 -0000 1.13
+++ sem_ch8.adb 20 Nov 2003 09:48:32 -0000
@@ -792,6 +792,8 @@ 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
+
elsif Ekind (Old_P) = E_Package
and then From_With_Type (Old_P)
then
@@ -3389,6 +3391,8 @@ package body Sem_Ch8 is
Set_Chars (Selector, Chars (Id));
end if;
+ -- Ada0Y (AI-50217): Check usage of entities in limited withed units
+
if Ekind (P_Name) = E_Package
and then From_With_Type (P_Name)
then
@@ -5293,6 +5297,8 @@ package body Sem_Ch8 is
end if;
Set_In_Use (P);
+
+ -- Ada0Y (AI-50217): Check restriction.
if From_With_Type (P) then
Error_Msg_N ("limited withed package cannot appear in use clause", N);
Index: sem_type.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_type.adb,v
retrieving revision 1.9
diff -u -p -r1.9 sem_type.adb
--- sem_type.adb 29 Oct 2003 10:26:15 -0000 1.9
+++ sem_type.adb 20 Nov 2003 09:48:32 -0000
@@ -824,6 +824,9 @@ package body Sem_Type is
then
return True;
+ -- Ada0Y (AI-50217): Additional branches to make the shadow entity
+ -- compatible with its real entity.
+
elsif From_With_Type (T1) then
-- If the expected type is the non-limited view of a type, the
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_util.adb
--- sem_util.adb 22 Oct 2003 09:28:08 -0000 1.14
+++ sem_util.adb 20 Nov 2003 09:48:32 -0000
@@ -818,8 +818,8 @@ package body Sem_Util is
begin
if Ekind (T) = E_Incomplete_Type then
- -- If the type is available through a limited_with_clause,
- -- verify that its full view has been analyzed.
+ -- Ada0Y (AI-50217): If the type is available through a limited
+ -- with_clause, verify that its full view has been analyzed.
if From_With_Type (T)
and then Present (Non_Limited_View (T))
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.14
diff -u -p -r1.14 sinfo.ads
--- sinfo.ads 14 Nov 2003 10:24:43 -0000 1.14
+++ sinfo.ads 20 Nov 2003 09:48:32 -0000
@@ -3015,7 +3015,8 @@ package Sinfo is
-- separable by the parser. The choices list may represent either a
-- 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).
+ -- node (which appears as a singleton list). Box_Present gives support
+ -- to Ada0Y (AI-287).
------------------------------------
-- 4.3.1 Commponent Choice List --
@@ -5089,6 +5090,9 @@ package Sinfo is
-- Limited_View_Installed (Flag18-Sem)
-- Unreferenced_In_Spec (Flag7-Sem)
-- No_Entities_Ref_In_Spec (Flag8-Sem)
+
+ -- Note: Limited_Present and Limited_View_Installed give support to
+ -- Ada0Y (AI-50217).
----------------------
-- With_Type clause --
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.13
diff -u -p -r1.13 snames.adb
--- snames.adb 4 Nov 2003 12:56:59 -0000 1.13
+++ snames.adb 20 Nov 2003 09:48:32 -0000
@@ -618,8 +618,10 @@ package body Snames is
"library_kind#" &
"library_name#" &
"library_options#" &
+ "library_reference_symbol_file#" &
"library_src_dir#" &
"library_symbol_file#" &
+ "library_symbol_policy#" &
"library_version#" &
"linker#" &
"local_configuration_pragmas#" &
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.14
diff -u -p -r1.14 snames.ads
--- snames.ads 4 Nov 2003 12:56:59 -0000 1.14
+++ snames.ads 20 Nov 2003 09:48:32 -0000
@@ -902,33 +902,35 @@ package Snames is
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_Src_Dir : constant Name_Id := N + 561;
- Name_Library_Symbol_File : constant Name_Id := N + 562;
- Name_Library_Version : constant Name_Id := N + 563;
- Name_Linker : constant Name_Id := N + 564;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 565;
- Name_Locally_Removed_Files : constant Name_Id := N + 566;
- Name_Naming : constant Name_Id := N + 567;
- Name_Object_Dir : constant Name_Id := N + 568;
- Name_Pretty_Printer : constant Name_Id := N + 569;
- Name_Project : constant Name_Id := N + 570;
- Name_Separate_Suffix : constant Name_Id := N + 571;
- Name_Source_Dirs : constant Name_Id := N + 572;
- Name_Source_Files : constant Name_Id := N + 573;
- Name_Source_List_File : constant Name_Id := N + 574;
- Name_Spec : constant Name_Id := N + 575;
- Name_Spec_Suffix : constant Name_Id := N + 576;
- Name_Specification : constant Name_Id := N + 577;
- Name_Specification_Exceptions : constant Name_Id := N + 578;
- Name_Specification_Suffix : constant Name_Id := N + 579;
- Name_Switches : constant Name_Id := N + 580;
+ 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;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 581;
+ Name_Unaligned_Valid : constant Name_Id := N + 583;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 581;
+ Last_Predefined_Name : constant Name_Id := N + 583;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sprint.adb
--- sprint.adb 17 Nov 2003 14:58:17 -0000 1.11
+++ sprint.adb 20 Nov 2003 09:48:32 -0000
@@ -929,6 +929,8 @@ package body Sprint is
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
+ -- Ada0Y (AI-287): Print the mbox if present
+
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
else
@@ -2495,6 +2497,9 @@ package body Sprint is
else
if First_Name (Node) or else not Dump_Original_Only then
+
+ -- Ada0Y (AI-50217): Print limited with_clauses
+
if Limited_Present (Node) then
Write_Indent_Str ("limited with ");
else
@@ -2513,7 +2518,6 @@ package body Sprint is
end if;
when N_With_Type_Clause =>
-
Write_Indent_Str ("with type ");
Sprint_Node_Sloc (Name (Node));
Index: s-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.adb,v
retrieving revision 1.5
diff -u -p -r1.5 s-thread.adb
--- s-thread.adb 17 Nov 2003 14:58:17 -0000 1.5
+++ s-thread.adb 20 Nov 2003 09:48:32 -0000
@@ -31,14 +31,7 @@
-- --
------------------------------------------------------------------------------
--- This is the VxWorks version of this package
-
-pragma Restrictions (No_Tasking);
--- The VxWorks version of this package is intended only for programs
--- which do not use Ada tasking. This restriction ensures that this
--- will be checked by the binder.
-
-with System.Secondary_Stack;
+-- This is a dummy version of this package.
with Unchecked_Conversion;
@@ -46,29 +39,13 @@ with System.Threads.Initialization;
package body System.Threads is
- package SSS renames System.Secondary_Stack;
-
- Current_ATSD : aliased System.Address := System.Null_Address;
- pragma Export (C, Current_ATSD, "__gnat_current_atsd");
-
- function From_Address is
- new Unchecked_Conversion (Address, ATSD_Access);
-
- procedure Init_Float;
- pragma Import (C, Init_Float, "__gnat_init_float");
-
- procedure Install_Handler;
- pragma Import (C, Install_Handler, "__gnat_install_handler");
-
-----------------------
-- Get_Current_Excep --
-----------------------
function Get_Current_Excep return EOA is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- return CTSD.Current_Excep'Access;
+ return null;
end Get_Current_Excep;
------------------------
@@ -76,10 +53,8 @@ package body System.Threads is
------------------------
function Get_Jmpbuf_Address return Address is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- return CTSD.Jmpbuf_Address;
+ return Null_Address;
end Get_Jmpbuf_Address;
------------------------
@@ -87,10 +62,8 @@ package body System.Threads is
------------------------
function Get_Sec_Stack_Addr return Address is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- return CTSD.Sec_Stack_Addr;
+ return Null_Address;
end Get_Sec_Stack_Addr;
------------------------
@@ -98,10 +71,9 @@ package body System.Threads is
------------------------
procedure Set_Jmpbuf_Address (Addr : Address) is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
+ pragma Unreferenced (Addr);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- CTSD.Jmpbuf_Address := Addr;
+ null;
end Set_Jmpbuf_Address;
------------------------
@@ -109,10 +81,9 @@ package body System.Threads is
------------------------
procedure Set_Sec_Stack_Addr (Addr : Address) is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
+ pragma Unreferenced (Addr);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- CTSD.Sec_Stack_Addr := Addr;
+ null;
end Set_Sec_Stack_Addr;
-----------------------
@@ -124,18 +95,11 @@ package body System.Threads is
Sec_Stack_Size : Natural;
Process_ATSD_Address : System.Address)
is
- -- Current_ATSD must already be a taskVar of taskIdSelf.
- -- No assertion because taskVarGet is not available on VxWorks/CERT
-
- TSD : ATSD_Access := From_Address (Process_ATSD_Address);
-
+ pragma Unreferenced (Sec_Stack_Address);
+ pragma Unreferenced (Sec_Stack_Size);
+ pragma Unreferenced (Process_ATSD_Address);
begin
- TSD.Sec_Stack_Addr := Sec_Stack_Address;
- SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
- Current_ATSD := Process_ATSD_Address;
-
- Install_Handler;
- Init_Float;
+ null;
end Thread_Body_Enter;
----------------------------------
@@ -147,8 +111,6 @@ package body System.Threads is
is
pragma Unreferenced (EO);
begin
- -- No action for this target
-
null;
end Thread_Body_Exceptional_Exit;
@@ -158,11 +120,7 @@ package body System.Threads is
procedure Thread_Body_Leave is
begin
- -- No action for this target
-
null;
end Thread_Body_Leave;
-begin
- System.Threads.Initialization.Init_RTS;
end System.Threads;
Index: symbols.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/symbols.adb,v
retrieving revision 1.1
diff -u -p -r1.1 symbols.adb
--- symbols.adb 21 Oct 2003 13:42:22 -0000 1.1
+++ symbols.adb 20 Nov 2003 09:48:32 -0000
@@ -36,14 +36,18 @@ package body Symbols is
----------------
procedure Initialize
- (Symbol_File : String;
- Force : Boolean;
- Quiet : Boolean;
- Success : out Boolean)
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean)
is
pragma Unreferenced (Symbol_File);
- pragma Unreferenced (Force);
+ pragma Unreferenced (Reference);
+ pragma Unreferenced (Symbol_Policy);
pragma Unreferenced (Quiet);
+ pragma Unreferenced (Version);
begin
Put_Line
("creation of symbol files are not supported on this platform");
Index: symbols.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/symbols.ads,v
retrieving revision 1.1
diff -u -p -r1.1 symbols.ads
--- symbols.ads 21 Oct 2003 13:42:22 -0000 1.1
+++ symbols.ads 20 Nov 2003 09:48:32 -0000
@@ -33,6 +33,20 @@ with GNAT.OS_Lib; use GNAT.OS_Li
package Symbols is
+ type Policy is
+ -- Symbol policy:
+
+ (Autonomous,
+ -- Create a symbol file without considering any reference
+
+ Compliant,
+ -- Either create a symbol file with the same major and minor IDs if
+ -- all symbols are already found in the reference file or with an
+ -- incremented minor ID, if not.
+
+ Controlled);
+ -- Fail if symbols are not the same as those in the reference file
+
type Symbol_Kind is (Data, Proc);
-- To distinguish between the different kinds of symbols
@@ -52,16 +66,18 @@ package Symbols is
-- The symbol tables
Original_Symbols : Symbol_Table.Instance;
- -- The symbols, if any, found in the original symbol table
+ -- The symbols, if any, found in the reference symbol table
Complete_Symbols : Symbol_Table.Instance;
-- The symbols, if any, found in the objects files
procedure Initialize
- (Symbol_File : String;
- Force : Boolean;
- Quiet : Boolean;
- Success : out Boolean);
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean);
-- Initialize a symbol file. This procedure must be called before
-- Processing any object file. Depending on the platforms and the
-- circumstances, additional messages may be issued if Quiet is False.
Index: usage.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/usage.adb,v
retrieving revision 1.11
diff -u -p -r1.11 usage.adb
--- usage.adb 10 Nov 2003 17:30:00 -0000 1.11
+++ usage.adb 20 Nov 2003 09:48:32 -0000
@@ -235,7 +235,7 @@ begin
-- Line for -gnatN switch
Write_Switch_Char ("N");
- Write_Line ("Full (frontend) inlining of subprograqms");
+ Write_Line ("Full (frontend) inlining of subprograms");
-- Line for -gnato switch
Index: xref_lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/xref_lib.adb,v
retrieving revision 1.6
diff -u -p -r1.6 xref_lib.adb
--- xref_lib.adb 21 Oct 2003 13:42:23 -0000 1.6
+++ xref_lib.adb 20 Nov 2003 09:48:32 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 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- --
@@ -359,10 +359,7 @@ package body Xref_Lib is
-- Default_Project_File --
--------------------------
- function Default_Project_File
- (Dir_Name : String)
- return String
- is
+ function Default_Project_File (Dir_Name : String) return String is
My_Dir : Dir_Type;
Dir_Ent : File_Name_String;
Last : Natural;
@@ -396,8 +393,7 @@ package body Xref_Lib is
function File_Name
(File : ALI_File;
- Num : Positive)
- return File_Reference
+ Num : Positive) return File_Reference
is
begin
return File.Dep.Table (Num);
@@ -876,6 +872,9 @@ package body Xref_Lib is
-- unit number is optional. It is specified only if the parent type
-- is not defined in the current unit.
+ -- We also have the format for generic instantiations, as in
+ -- 7a5*Uid(3|5I8[4|2]) 2|4r74
+
-- We could also have something like
-- 16I9*I<integer>
-- that indicates that I derives from the predefined type integer.
@@ -918,6 +917,25 @@ package body Xref_Lib is
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, P_Column);
+ -- Skip the information for generics instantiations
+
+ if Ali (Ptr) = '[' then
+ declare
+ Num_Brackets : Natural := 1;
+ begin
+ while Num_Brackets /= 0 loop
+ Ptr := Ptr + 1;
+ if Ali (Ptr) = '[' then
+ Num_Brackets := Num_Brackets + 1;
+ elsif Ali (Ptr) = ']' then
+ Num_Brackets := Num_Brackets - 1;
+ end if;
+ end loop;
+
+ Ptr := Ptr + 1;
+ end;
+ end if;
+
-- Skip '>', or ')' or '>'
Ptr := Ptr + 1;
@@ -928,8 +946,7 @@ package body Xref_Lib is
if Der_Info or else Type_Tree then
declare
Symbol : constant String :=
- Get_Symbol_Name (P_Eun, P_Line, P_Column);
-
+ Get_Symbol_Name (P_Eun, P_Line, P_Column);
begin
if Symbol /= "???" then
Add_Parent
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.53
diff -u -r1.53 Makefile.in
--- Makefile.in 14 Nov 2003 13:56:34 -0000 1.53
+++ Makefile.in 20 Nov 2003 09:53:21 -0000
@@ -626,6 +626,10 @@
s-parame.ads<5yparame.ads \
s-taprop.adb<5ztaprop.adb \
s-taspri.ads<5ztaspri.ads \
+ s-thread.adb<5zthread.adb \
+ s-thrini.ads<2sthrini.ads \
+ s-thrini.adb<5zthrini.adb \
+ s-tiitho.adb<5ytiitho.adb \
s-tpopsp.adb<5ztpopsp.adb \
s-vxwork.ads<5pvxwork.ads \
g-soccon.ads<3zsoccon.ads \
@@ -640,8 +644,8 @@
EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads
EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=i-vthrea.o s-tpae65.o s-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o s-thrini.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
HIE_RAVEN_TARGET_PAIRS=\
$(HIE_NONE_TARGET_PAIRS) \
a-reatim.ads<1areatim.ads \
@@ -688,6 +692,7 @@
s-soflin.ads<2ssoflin.ads \
s-stalib.adb<1sstalib.adb \
s-stalib.ads<1sstalib.ads \
+ s-thrini.adb<5zthrini.adb \
s-thrini.ads<2sthrini.ads \
s-thrini.adb<5zthrini.adb \
s-tiitho.adb<5ytiitho.adb \
@@ -964,6 +969,25 @@
THREADSLIB = -lgthreads -lmalloc
endif
+endif
+
+ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<45intnam.ads \
+ g-soccon.ads<35soccon.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<55osinte.adb \
+ s-osinte.ads<55osinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ system.ads<56system.ads
+
+ THREADSLIB=
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-18 10:29 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-18 10:29 UTC (permalink / raw)
To: gcc-patches
Further IA64/x86_64 fixes
Part of FreeBSD port.
Tested on x86-linux and compiled on x86-freebsd
2003-11-18 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* ada-tree.def: (ALLOCATE_EXPR): Class is "2", not "s".
* decl.c (gnat_to_gnu_entity, case E_Floating_Point_Subtype): Set
TYPE_PRECISION directly from esize.
2003-11-18 Thomas Quinot <quinot@act-europe.fr>
* cstreams.c:
Use realpath(3) on FreeBSD. Fix typo in comment while we are at it.
* init.c: Initialization routines for FreeBSD
* link.c: Link info for FreeBSD
* sysdep.c: Add the case of FreeBSD
--
Index: ada-tree.def
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.def,v
retrieving revision 1.7
diff -u -p -r1.7 ada-tree.def
--- ada-tree.def 29 Oct 2003 10:26:12 -0000 1.7
+++ ada-tree.def 18 Nov 2003 09:59:29 -0000
@@ -37,7 +37,7 @@ DEFTREECODE (TRANSFORM_EXPR, "transform_
by operand 0 at the alignment given by operand 1 and return the
address of the resulting memory. */
-DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", 's', 2)
+DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", '2', 2)
/* A type that is an unconstrained array itself. This node is never passed
to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE
Index: cstreams.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstreams.c,v
retrieving revision 1.10
diff -u -p -r1.10 cstreams.c
--- cstreams.c 31 Oct 2003 01:08:40 -0000 1.10
+++ cstreams.c 18 Nov 2003 09:59:29 -0000
@@ -175,9 +175,9 @@ __gnat_full_name (char *nam, char *buffe
#elif defined (MSDOS)
_fixpath (nam, buffer);
-#elif defined (sgi)
+#elif defined (sgi) || defined (__FreeBSD__)
- /* Use realpath function which resolves links and references to .. and ..
+ /* Use realpath function which resolves links and references to . and ..
on those Unix systems that support it. Note that GNU/Linux provides it but
cannot handle more than 5 symbolic links in a full name, so we use the
getcwd approach instead. */
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.22
diff -u -p -r1.22 decl.c
--- decl.c 17 Nov 2003 14:58:14 -0000 1.22
+++ decl.c 18 Nov 2003 09:59:30 -0000
@@ -1357,8 +1357,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
}
{
- enum machine_mode mode;
-
if (definition == 0
&& Present (Ancestor_Subtype (gnat_entity))
&& ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
@@ -1367,15 +1365,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
gnu_expr, definition);
- for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT);
- (GET_MODE_WIDER_MODE (mode) != VOIDmode
- && GET_MODE_BITSIZE (GET_MODE_WIDER_MODE (mode)) <= esize);
- mode = GET_MODE_WIDER_MODE (mode))
- ;
-
gnu_type = make_node (REAL_TYPE);
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
- TYPE_PRECISION (gnu_type) = GET_MODE_BITSIZE (mode);
+ TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
TYPE_MIN_VALUE (gnu_type)
= convert (TREE_TYPE (gnu_type),
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.20
diff -u -p -r1.20 init.c
--- init.c 4 Nov 2003 12:51:46 -0000 1.20
+++ init.c 18 Nov 2003 09:59:30 -0000
@@ -1456,6 +1456,88 @@ __gnat_initialize(void)
{
}
+/*************************************************/
+/* __gnat_initialize (FreeBSD version) */
+/*************************************************/
+
+#elif defined (__FreeBSD__)
+
+#include <signal.h>
+#include <unistd.h>
+
+static void
+__gnat_error_handler (sig, code, sc)
+ int sig;
+ int code;
+ struct sigcontext *sc;
+{
+ struct Exception_Data *exception;
+ char *msg;
+
+ switch (sig)
+ {
+ case SIGFPE:
+ exception = &constraint_error;
+ msg = "SIGFPE";
+ break;
+
+ case SIGILL:
+ exception = &constraint_error;
+ msg = "SIGILL";
+ break;
+
+ case SIGSEGV:
+ exception = &storage_error;
+ msg = "stack overflow or erroneous memory access";
+ break;
+
+ case SIGBUS:
+ exception = &constraint_error;
+ msg = "SIGBUS";
+ break;
+
+ default:
+ exception = &program_error;
+ msg = "unhandled signal";
+ }
+
+ Raise_From_Signal_Handler (exception, msg);
+}
+
+void
+__gnat_install_handler ()
+{
+ struct sigaction act;
+
+ /* Set up 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! */
+
+ act.sa_handler = __gnat_error_handler;
+ act.sa_flags = SA_NODEFER | SA_RESTART;
+ (void) sigemptyset (&act.sa_mask);
+
+ (void) sigaction (SIGILL, &act, NULL);
+ (void) sigaction (SIGFPE, &act, NULL);
+ (void) sigaction (SIGSEGV, &act, NULL);
+ (void) sigaction (SIGBUS, &act, NULL);
+}
+
+void __gnat_init_float ();
+
+void
+__gnat_initialize ()
+{
+ __gnat_install_handler ();
+
+ /* XXX - Initialize floating-point coprocessor. This call is
+ needed because FreeBSD defaults to 64-bit precision instead
+ of 80-bit precision? We require the full precision for
+ proper operation, given that we have set Max_Digits etc
+ with this in mind */
+ __gnat_init_float ();
+}
+
/***************************************/
/* __gnat_initialize (VXWorks Version) */
/***************************************/
@@ -1749,7 +1831,7 @@ __gnat_install_handler (void)
WIN32 and could be used under OS/2 */
#if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \
- || defined (__Lynx__) || defined(__NetBSD__)
+ || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__)
#define HAVE_GNAT_INIT_FLOAT
Index: link.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/link.c,v
retrieving revision 1.5
diff -u -p -r1.5 link.c
--- link.c 21 Oct 2003 13:42:09 -0000 1.5
+++ link.c 18 Nov 2003 09:59:30 -0000
@@ -154,6 +154,15 @@ unsigned char objlist_file_supported = 0
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
+#elif defined (__FreeBSD__)
+char *object_file_option = "";
+char *run_path_option = "";
+char shared_libgnat_default = SHARED;
+int link_max = 2147483647;
+unsigned char objlist_file_supported = 0;
+unsigned char using_gnu_linker = 0;
+char *object_library_extension = ".a";
+
#elif defined (linux)
const char *object_file_option = "";
const char *run_path_option = "-Wl,-rpath,";
Index: sysdep.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sysdep.c,v
retrieving revision 1.15
diff -u -p -r1.15 sysdep.c
--- sysdep.c 12 Nov 2003 21:29:28 -0000 1.15
+++ sysdep.c 18 Nov 2003 09:59:30 -0000
@@ -291,7 +291,7 @@ __gnat_ttyname (int filedes)
|| (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \
|| defined (__MACHTEN__) || defined (hpux) || defined (_AIX) \
|| (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \
- || defined (__CYGWIN__)
+ || defined (__CYGWIN__) || defined (__FreeBSD__)
#ifdef __MINGW32__
#if OLD_MINGW
@@ -348,7 +348,7 @@ getc_immediate_common (FILE *stream,
|| (defined (__osf__) && ! defined (__alpha_vxworks)) \
|| defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (hpux) \
|| defined (_AIX) || (defined (__svr4__) && defined (i386)) \
- || defined (__Lynx__)
+ || defined (__Lynx__) || defined (__FreeBSD__)
char c;
int nread;
int good_one = 0;
@@ -367,7 +367,7 @@ getc_immediate_common (FILE *stream,
#if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
|| defined (__osf__) || defined (__MACHTEN__) || defined (hpux) \
|| defined (_AIX) || (defined (__svr4__) && defined (i386)) \
- || defined (__Lynx__)
+ || defined (__Lynx__) || defined (__FreeBSD__)
eof_ch = termios_rec.c_cc[VEOF];
/* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-17 15:16 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-17 15:16 UTC (permalink / raw)
To: gcc-patches
Tested on x86-linux
--
2003-11-17 Jerome Guitton <guitton@act-europe.fr>
* 5zthrini.adb: Remove the call to Init_RTS at elaboration, as it is
already called in System.Threads.
* 5ztiitho.adb (Initialize_Task_Hooks): Remove the registration of the
environment task, as it has been moved to System.Threads.Initialization.
2003-11-17 Arnaud Charlet <charlet@act-europe.fr>
* adaint.c (__gnatlib_install_locks): Only reference
__gnat_install_locks on VMS, since other platforms can avoid using
--enable-threads=gnat
2003-11-17 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* ada-tree.h: (TYPE_IS_PACKED_ARRAY_TYPE_P): New macro.
* decl.c (gnat_to_gnu_entity, case E_Array_Subtype): Set
TYPE_PACKED_ARRAY_TYPE_P.
(validate_size): Do not verify size if TYPE_IS_PACKED_ARRAY_TYPE_P.
Part of PR ada/12806
* utils.c (float_type_for_precision): Renamed from float_type_for_size.
Use GET_MODE_PRECISION instead of GET_MODE_BITSIZE.
2003-11-17 Vincent Celier <celier@gnat.com>
* gnatchop.adb (Error_Msg): New Boolean parameter Warning, defaulted
to False.
Do not set exit status to Failure when Warning is True.
(Gnatchop): Make errors "no compilation units found" and
"no source files written" warnings only.
* make.adb (Gnatmake): When using a project file, set
Look_In_Primary_Dir to False.
(Configuration_Pragmas_Switch): Check for Global_Configuration_Pragmas
and Local_Configuration_Pragmas in the project where they are declared
not an extending project which might have inherited them.
* osint.adb (Locate_File): If Name is already an absolute path, do not
look for a directory.
* par-ch10.adb (P_Compilation_Unit): If source contains no token, and
-gnats (Check_Syntax) is used, issue only a warning, not an error.
* prj.adb (Register_Default_Naming_Scheme): Add new component Project
in objects of type Variable_Value.
* prj.ads: (Variable_Value): New component Project
* prj-nmsc.adb (Ada_Check.Warn_If_Not_Sources): No warning if source
is in a project extended by Project.
* prj-proc.adb (Add_Attributes): New parameter Project. Set component
Project of Variable_Values to this new parameter value.
(Expression): Set component Project of Variable_Values.
(Process_Declarative_Items): Call Add_Attributes with parameter Project.
Set the component Project in array elements.
2003-11-17 Sergey Rybin <rybin@act-europe.fr>
* errout.adb: (Initialize): Add initialization for error nodes.
* sem_ch12.adb (Initialize): Add missing initializations for
Exchanged_Views and Hidden_Entities.
2003-11-17 Ed Schonberg <schonberg@gnat.com>
* sem_ch12.adb (Copy_Generic_Node): Preserve entity when copying an
already instantiated tree for use in subsequent inlining.
(Analyze_Associations, Instantiate_Formal_Subprogram,
Instantiate_Object): improve error message for mismatch in
instantiations.
* sem_ch6.adb (Build_Body_To_Inline): Major cleanup to handle
instantiations of subprograms declared in instances.
2003-11-17 Javier Miranda <miranda@gnat.com>
* sem_ch4.adb (Analyze_Allocator): Previous modification must be
executed only under the Extensions_Allowed flag.
2003-11-17 Robert Dewar <dewar@gnat.com>
* a-exexda.adb (Address_Image): Fix documentation to indicate leading
zeroes suppressed.
(Address_Image): Fix bug of returning 0x instead of 0x0
Minor reformatting (function specs).
* einfo.ads: Minor fix for documentation of Is_Bit_Packed_Array
(missed case of 33-63)
* freeze.adb, sem_ch13.adb: Properly check size of packed bit array
* s-thread.adb: Add comments for pragma Restriction
* exp_aggr.adb, g-debuti.adb, par-ch4.adb, sem_aggr.adb,
sem_ch6.adb, sprint.adb, xref_lib.adb: Minor reformatting
2003-11-17 Ed Falis <falis@gnat.com>
* s-thread.adb: Added No_Tasking restriction for this implementation.
2003-11-17 Emmanuel Briot <briot@act-europe.fr>
* xref_lib.adb (Parse_Identifier_Info): Add handling of generic
instanciation references in the parent type description.
2003-11-17 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 5zthrini.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zthrini.adb,v
retrieving revision 1.3
diff -u -r1.3 5zthrini.adb
--- 5zthrini.adb 14 Nov 2003 10:24:42 -0000 1.3
+++ 5zthrini.adb 17 Nov 2003 14:14:05 -0000
@@ -115,7 +115,6 @@
begin
Initialize_Task_Hooks;
- Init_RTS;
-- Register the environment task
declare
Index: 5ztiitho.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ztiitho.adb,v
retrieving revision 1.1
diff -u -r1.1 5ztiitho.adb
--- 5ztiitho.adb 21 Oct 2003 13:41:53 -0000 1.1
+++ 5ztiitho.adb 17 Nov 2003 14:14:05 -0000
@@ -46,7 +46,4 @@
Result : OSI.STATUS;
begin
taskCreateHookAdd (Register'Access);
- -- Register the environment task
- Result := Register (OSI.taskIdSelf);
- pragma Assert (Result /= -1);
end Initialize_Task_Hooks;
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.22
diff -u -r1.22 adaint.c
--- adaint.c 10 Nov 2003 17:29:58 -0000 1.22
+++ adaint.c 17 Nov 2003 14:14:05 -0000
@@ -2465,13 +2465,15 @@
extern void __gnat_install_locks (void (*) (void), void (*) (void));
/* This function offers a hook for libgnarl to set the
- locking subprograms for libgcc_eh. */
+ locking subprograms for libgcc_eh.
+ This is only needed on OpenVMS, since other platforms use standard
+ --enable-threads=posix option, or similar. */
void
__gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
void (*unlock) (void) ATTRIBUTE_UNUSED)
{
-#ifdef IN_RTS
+#if defined (IN_RTS) && defined (VMS)
__gnat_install_locks (lock, unlock);
/* There is a bootstrap path issue if adaint is build with this
symbol unresolved for the stage1 compiler. Since the compiler
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.10
diff -u -r1.10 ada-tree.h
--- ada-tree.h 4 Nov 2003 12:51:45 -0000 1.10
+++ ada-tree.h 17 Nov 2003 14:14:05 -0000
@@ -72,9 +72,13 @@
#define TYPE_FAT_POINTER_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE))
-/* For integral types, nonzero if this is a packed array type. Such
- types should not be extended to a larger size. */
+/* For integral types and array types, nonzero if this is a packed array type.
+ Such types should not be extended to a larger size. */
#define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE)
+
+#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \
+ ((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \
+ && TYPE_PACKED_ARRAY_TYPE_P (NODE))
/* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that
is not equal to two to the power of its mode's size. */
Index: a-exexda.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-exexda.adb,v
retrieving revision 1.1
diff -u -r1.1 a-exexda.adb
--- a-exexda.adb 21 Oct 2003 13:41:53 -0000 1.1
+++ a-exexda.adb 17 Nov 2003 14:14:05 -0000
@@ -41,9 +41,8 @@
-----------------------
function Address_Image (A : System.Address) return String;
- -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
- -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
- -- in lower case.
+ -- Returns at string of the form 0xhhhhhhhhh for an address, with
+ -- leading zeros suppressed. Hex characters a-f are in lower case.
procedure Append_Info_Nat
(N : Natural;
@@ -66,22 +65,19 @@
-- we then use three intermediate functions :
function Basic_Exception_Information
- (X : Exception_Occurrence)
- return String;
+ (X : Exception_Occurrence) return String;
-- Returns the basic exception information string associated with a
-- given exception occurrence. This is the common part shared by both
-- Exception_Information and Tailored_Exception_Infomation.
function Basic_Exception_Traceback
- (X : Exception_Occurrence)
- return String;
+ (X : Exception_Occurrence) return String;
-- Returns an image of the complete call chain associated with an
-- exception occurence in its most basic form, that is as a raw sequence
-- of hexadecimal binary addresses.
function Tailored_Exception_Traceback
- (X : Exception_Occurrence)
- return String;
+ (X : Exception_Occurrence) return String;
-- Returns an image of the complete call chain associated with an
-- exception occurrence, either in its basic form if no decorator is
-- in place, or as formatted by the decorator otherwise.
@@ -121,10 +117,11 @@
begin
P := S'Last;
N := To_Integer (A);
- while N /= 0 loop
+ loop
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
+ exit when N = 0;
end loop;
S (P - 1) := '0';
@@ -184,8 +181,7 @@
---------------------------------
function Basic_Exception_Information
- (X : Exception_Occurrence)
- return String
+ (X : Exception_Occurrence) return String
is
Name : constant String := Exception_Name (X);
Msg : constant String := Exception_Message (X);
@@ -251,8 +247,7 @@
-------------------------------
function Basic_Exception_Traceback
- (X : Exception_Occurrence)
- return String
+ (X : Exception_Occurrence) return String
is
Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
-- Maximum length of the information string we are building, with :
@@ -460,8 +455,7 @@
----------------------------------
function Tailored_Exception_Traceback
- (X : Exception_Occurrence)
- return String
+ (X : Exception_Occurrence) return String
is
-- We indeed reference the decorator *wrapper* from here and not the
-- decorator itself. The purpose of the local variable Wrapper is to
@@ -491,8 +485,7 @@
------------------------------------
function Tailored_Exception_Information
- (X : Exception_Occurrence)
- return String
+ (X : Exception_Occurrence) return String
is
-- The tailored exception information is simply the basic information
-- associated with the tailored call chain backtrace.
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.21
diff -u -r1.21 decl.c
--- decl.c 4 Nov 2003 12:51:45 -0000 1.21
+++ decl.c 17 Nov 2003 14:14:05 -0000
@@ -1992,6 +1992,8 @@
debug_no_type_hash = 0;
TYPE_CONVENTION_FORTRAN_P (gnu_type)
= (Convention (gnat_entity) == Convention_Fortran);
+ TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
+ = Is_Packed_Array_Type (gnat_entity);
/* If our size depends on a placeholder and the maximum size doesn't
overflow, use it. */
@@ -5752,11 +5754,6 @@
else
gnat_error_node = gnat_object;
- /* Don't give errors on packed array types; we'll be giving the error on
- the type itself soon enough. */
- if (Is_Packed_Array_Type (gnat_object))
- gnat_error_node = Empty;
-
/* Return 0 if no size was specified, either because Esize was not Present or
the specified size was zero. */
if (No (uint_size) || uint_size == No_Uint)
@@ -5791,11 +5788,11 @@
return 0;
}
- /* If this is an integral type, the front-end has verified the size, so we
- need not do it here (which would entail checking against the bounds).
- However, if this is an aliased object, it may not be smaller than the
- type of the object. */
- if (INTEGRAL_TYPE_P (gnu_type) && ! TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
+ /* If this is an integral type or a packed array type, the front-end has
+ verified the size, so we need not do it here (which would entail
+ checking against the bounds). However, if this is an aliased object, it
+ may not be smaller than the type of the object. */
+ if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
&& ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.15
diff -u -r1.15 einfo.ads
--- einfo.ads 10 Nov 2003 17:29:58 -0000 1.15
+++ einfo.ads 17 Nov 2003 14:14:06 -0000
@@ -1660,9 +1660,9 @@
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
-- Present in all entities. This flag is set for a packed array
-- type that is bit packed (i.e. the component size is known by the
--- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is
--- always set if Is_Bit_Packed_Array is set, but it is possible for
--- Is_Packed to be set without Is_Bit_Packed_Array or the case of an
+-- front end and is in the range 1-7, 9-15, 17-31, or 33-63). Is_Packed
+-- is always set if Is_Bit_Packed_Array is set, but it is possible for
+-- Is_Packed to be set without Is_Bit_Packed_Array for the case of an
-- array having one or more index types that are enumeration types
-- with non-standard enumeration representations.
Index: errout.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/errout.adb,v
retrieving revision 1.10
diff -u -r1.10 errout.adb
--- errout.adb 21 Oct 2003 13:41:58 -0000 1.10
+++ errout.adb 17 Nov 2003 14:14:06 -0000
@@ -1408,6 +1408,12 @@
Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
end if;
+
+ -- Set all (???) the error nodes to Empty:
+
+ Error_Msg_Node_1 := Empty;
+ Error_Msg_Node_2 := Empty;
+
end Initialize;
-----------------
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.8
diff -u -r1.8 exp_aggr.adb
--- exp_aggr.adb 14 Nov 2003 10:24:43 -0000 1.8
+++ exp_aggr.adb 17 Nov 2003 14:14:06 -0000
@@ -106,8 +106,7 @@
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
- Is_Limited_Ancestor_Expansion : Boolean := False)
- return List_Id;
+ Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
-- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
-- of the aggregate. Target is an expression containing the
-- location on which the component by component assignments will
@@ -175,8 +174,7 @@
Into : Node_Id;
Scalar_Comp : Boolean;
Indices : List_Id := No_List;
- Flist : Node_Id := Empty)
- return List_Id;
+ Flist : Node_Id := Empty) return List_Id;
-- This recursive routine returns a list of statements containing the
-- loops and assignments that are needed for the expansion of the array
-- aggregate N.
@@ -207,8 +205,7 @@
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty)
- return List_Id;
+ Obj : Entity_Id := Empty) return List_Id;
-- N is a nested (record or array) aggregate that has been marked
-- with 'Delay_Expansion'. Typ is the expected type of the
-- aggregate and Target is a (duplicable) expression that will
@@ -225,8 +222,7 @@
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
- Expression : Node_Id)
- return Node_Id;
+ Expression : Node_Id) return Node_Id;
-- This is like Make_Assignment_Statement, except that Assignment_OK
-- is set in the left operand. All assignments built by this unit
-- use this routine. This is needed to deal with assignments to
@@ -405,8 +401,7 @@
Into : Node_Id;
Scalar_Comp : Boolean;
Indices : List_Id := No_List;
- Flist : Node_Id := Empty)
- return List_Id
+ Flist : Node_Id := Empty) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Index_Base : constant Entity_Id := Base_Type (Etype (Index));
@@ -1281,8 +1276,7 @@
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
- Is_Limited_Ancestor_Expansion : Boolean := False)
- return List_Id
+ Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
L : constant List_Id := New_List;
@@ -1333,8 +1327,7 @@
Typ : Entity_Id;
F : Node_Id;
Attach : Node_Id;
- Init_Pr : Boolean)
- return List_Id;
+ Init_Pr : Boolean) return List_Id;
-- returns the list of statements necessary to initialize the internal
-- controller of the (possible) ancestor typ into target and attach
-- it to finalization list F. Init_Pr conditions the call to the
@@ -1530,8 +1523,7 @@
Typ : Entity_Id;
F : Node_Id;
Attach : Node_Id;
- Init_Pr : Boolean)
- return List_Id
+ Init_Pr : Boolean) return List_Id
is
L : constant List_Id := New_List;
Ref : Node_Id;
@@ -2432,10 +2424,9 @@
Typ : constant Entity_Id := Etype (N);
function Flatten
- (N : Node_Id;
- Ix : Node_Id;
- Ixb : Node_Id)
- return Boolean;
+ (N : Node_Id;
+ Ix : Node_Id;
+ Ixb : Node_Id) return Boolean;
-- Convert the aggregate into a purely positional form if possible.
function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
@@ -2446,10 +2437,9 @@
-------------
function Flatten
- (N : Node_Id;
- Ix : Node_Id;
- Ixb : Node_Id)
- return Boolean
+ (N : Node_Id;
+ Ix : Node_Id;
+ Ixb : Node_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
@@ -4483,8 +4473,9 @@
----------------------------
function Has_Default_Init_Comps (N : Node_Id) return Boolean is
- Comps : constant List_Id := Component_Associations (N);
- C : Node_Id;
+ Comps : constant List_Id := Component_Associations (N);
+ C : Node_Id;
+
begin
pragma Assert (Nkind (N) = N_Aggregate
or else Nkind (N) = N_Extension_Aggregate);
@@ -4533,8 +4524,7 @@
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty)
- return List_Id
+ Obj : Entity_Id := Empty) return List_Id
is
begin
if Is_Record_Type (Etype (N)) then
@@ -4558,8 +4548,7 @@
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
- Expression : Node_Id)
- return Node_Id
+ Expression : Node_Id) return Node_Id
is
begin
Set_Assignment_OK (Name);
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.9
diff -u -r1.9 freeze.adb
--- freeze.adb 30 Oct 2003 11:50:12 -0000 1.9
+++ freeze.adb 17 Nov 2003 14:14:06 -0000
@@ -1817,16 +1817,19 @@
-- fields with component clauses, where we must check the size.
-- This is not done till the freeze point, since for fixed-point
-- types, we do not know the size until the type is frozen.
+ -- Similar processing applies to bit packed arrays.
if Is_First_Subtype (Rec) then
Comp := First_Component (Rec);
while Present (Comp) loop
if Present (Component_Clause (Comp))
- and then Is_Fixed_Point_Type (Etype (Comp))
+ and then (Is_Fixed_Point_Type (Etype (Comp))
+ or else
+ Is_Bit_Packed_Array (Etype (Comp)))
then
Check_Size
- (Component_Clause (Comp),
+ (Component_Name (Component_Clause (Comp)),
Etype (Comp),
Esize (Comp),
Junk);
@@ -2380,6 +2383,29 @@
if Unknown_Alignment (E) then
Set_Alignment (E, Alignment (Base_Type (E)));
end if;
+ end if;
+
+ -- For bit-packed arrays, check the size
+
+ if Is_Bit_Packed_Array (E)
+ and then Known_Esize (E)
+ then
+ declare
+ Discard : Boolean;
+ SizC : constant Node_Id := Size_Clause (E);
+
+ begin
+ -- It is not clear if it is possible to have no size
+ -- clause at this stage, but this is not worth worrying
+ -- about. Post the error on the entity name in the size
+ -- clause if present, else on the type entity itself.
+
+ if Present (SizC) then
+ Check_Size (Name (SizC), E, Esize (E), Discard);
+ else
+ Check_Size (E, E, Esize (E), Discard);
+ end if;
+ end;
end if;
-- Check one common case of a size given where the array
Index: g-debuti.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-debuti.adb,v
retrieving revision 1.4
diff -u -r1.4 g-debuti.adb
--- g-debuti.adb 21 Oct 2003 13:42:00 -0000 1.4
+++ g-debuti.adb 17 Nov 2003 14:14:06 -0000
@@ -39,9 +39,11 @@
H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
-- Table of hex digits
- --------------------------
- -- Image (address case) --
- --------------------------
+ -----------
+ -- Image --
+ -----------
+
+ -- Address case
function Image (A : Address) return Image_String is
S : Image_String;
@@ -71,9 +73,11 @@
return S;
end Image;
- -------------------------
- -- Image (string case) --
- -------------------------
+ -----------
+ -- Image --
+ -----------
+
+ -- String case
function Image (S : String) return String is
W : String (1 .. 2 * S'Length + 2);
Index: gnatchop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatchop.adb,v
retrieving revision 1.8
diff -u -r1.8 gnatchop.adb
--- gnatchop.adb 21 Oct 2003 13:42:06 -0000 1.8
+++ gnatchop.adb 17 Nov 2003 14:14:06 -0000
@@ -207,7 +207,7 @@
-- Local subprograms --
-----------------------
- procedure Error_Msg (Message : String);
+ procedure Error_Msg (Message : String; Warning : Boolean := False);
-- Produce an error message on standard error output
procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time);
@@ -337,10 +337,13 @@
-- Error_Msg --
---------------
- procedure Error_Msg (Message : String) is
+ procedure Error_Msg (Message : String; Warning : Boolean := False) is
begin
Put_Line (Standard_Error, Message);
- Set_Exit_Status (Failure);
+
+ if not Warning then
+ Set_Exit_Status (Failure);
+ end if;
if Exit_On_Error then
raise Terminate_Program;
@@ -1687,7 +1690,7 @@
if Unit.Last = 0 then
if not Write_gnat_adc then
- Error_Msg ("no compilation units found");
+ Error_Msg ("no compilation units found", Warning => True);
end if;
goto No_Files_Written;
@@ -1739,7 +1742,7 @@
-- been written.
if not Write_gnat_adc then
- Error_Msg ("no source files written");
+ Error_Msg ("no source files written", Warning => True);
end if;
return;
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.22
diff -u -r1.22 make.adb
--- make.adb 10 Nov 2003 17:29:59 -0000 1.22
+++ make.adb 17 Nov 2003 14:14:07 -0000
@@ -3001,7 +3001,8 @@
if Global_Attribute_Present then
declare
Path : constant String :=
- Absolute_Path (Global_Attribute.Value, Main_Project);
+ Absolute_Path
+ (Global_Attribute.Value, Global_Attribute.Project);
begin
if not Is_Regular_File (Path) then
Make_Failed
@@ -3033,7 +3034,8 @@
if Local_Attribute_Present then
declare
Path : constant String :=
- Absolute_Path (Local_Attribute.Value, For_Project);
+ Absolute_Path
+ (Local_Attribute.Value, Local_Attribute.Project);
begin
if not Is_Regular_File (Path) then
Make_Failed
@@ -3725,6 +3727,16 @@
And_Save => False);
end if;
+ else
+ -- If we use a project file, we have already checked that a main
+ -- specified on the command line with directory information has the
+ -- path name corresponding to a correct source in the project tree.
+ -- So, we don't need the directory information to be taken into
+ -- account by Find_File, and in fact it may lead to take the wrong
+ -- sources for other compilation units, when there are extending
+ -- projects.
+
+ Opt.Look_In_Primary_Dir := False;
end if;
-- If the user wants a program without a main subprogram, add the
Index: osint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.adb,v
retrieving revision 1.14
diff -u -r1.14 osint.adb
--- osint.adb 14 Nov 2003 10:24:43 -0000 1.14
+++ osint.adb 17 Nov 2003 14:14:07 -0000
@@ -50,6 +50,11 @@
-- Standard prefix, computed dynamically the first time Relocate_Path
-- is called, and cached for subsequent calls.
+ Empty : aliased String := "";
+ No_Dir : constant String_Ptr := Empty'Access;
+ -- Used in Locate_File as a fake directory when Name is already an
+ -- absolute path.
+
-------------------------------------
-- Use of Name_Find and Name_Enter --
-------------------------------------
@@ -1430,7 +1435,12 @@
Dir_Name : String_Ptr;
begin
- if T = Library then
+ -- If Name is already an absolute path, do not look for a directory
+
+ if Is_Absolute_Path (Name) then
+ Dir_Name := No_Dir;
+
+ elsif T = Library then
Dir_Name := Lib_Search_Directories.Table (Dir);
else pragma Assert (T /= Config);
Index: par-ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch10.adb,v
retrieving revision 1.5
diff -u -r1.5 par-ch10.adb
--- par-ch10.adb 21 Oct 2003 13:42:10 -0000 1.5
+++ par-ch10.adb 17 Nov 2003 14:14:07 -0000
@@ -300,9 +300,14 @@
Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
else
- Error_Msg_SC ("compilation unit expected");
- Cunit_Error_Flag := True;
- Resync_Cunit;
+ if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
+ Error_Msg_SC ("?file contains no compilation units");
+
+ else
+ Error_Msg_SC ("compilation unit expected");
+ Cunit_Error_Flag := True;
+ Resync_Cunit;
+ end if;
-- If we are at an end of file, then just quit, the above error
-- message was complaint enough.
Index: par-ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch4.adb,v
retrieving revision 1.7
diff -u -r1.7 par-ch4.adb
--- par-ch4.adb 14 Nov 2003 10:24:43 -0000 1.7
+++ par-ch4.adb 17 Nov 2003 14:14:07 -0000
@@ -1402,6 +1402,7 @@
else
Set_Expression (Assoc_Node, P_Expression);
end if;
+
return Assoc_Node;
end P_Record_Or_Array_Component_Association;
Index: prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.adb,v
retrieving revision 1.11
diff -u -r1.11 prj.adb
--- prj.adb 10 Nov 2003 17:29:59 -0000 1.11
+++ prj.adb 17 Nov 2003 14:14:07 -0000
@@ -306,7 +306,8 @@
Element :=
(Index => Lang,
Index_Case_Sensitive => False,
- Value => (Kind => Single,
+ Value => (Project => No_Project,
+ Kind => Single,
Location => No_Location,
Default => False,
Value => Default_Spec_Suffix),
@@ -341,7 +342,8 @@
Element :=
(Index => Lang,
Index_Case_Sensitive => False,
- Value => (Kind => Single,
+ Value => (Project => No_Project,
+ Kind => Single,
Location => No_Location,
Default => False,
Value => Default_Body_Suffix),
Index: prj.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.ads,v
retrieving revision 1.13
diff -u -r1.13 prj.ads
--- prj.ads 10 Nov 2003 17:29:59 -0000 1.13
+++ prj.ads 17 Nov 2003 14:14:07 -0000
@@ -77,6 +77,10 @@
function Empty_String return Name_Id;
+ type Project_Id is new Nat;
+ No_Project : constant Project_Id := 0;
+ -- Id of a Project File
+
type String_List_Id is new Nat;
Nil_String : constant String_List_Id := 0;
type String_Element is record
@@ -107,6 +111,7 @@
-- while processing the project tree (unknown package name).
type Variable_Value (Kind : Variable_Kind := Undefined) is record
+ Project : Project_Id := No_Project;
Location : Source_Ptr := No_Location;
Default : Boolean := False;
case Kind is
@@ -122,7 +127,8 @@
-- Default is True if the current value is the default one for the variable
Nil_Variable_Value : constant Variable_Value :=
- (Kind => Undefined,
+ (Project => No_Project,
+ Kind => Undefined,
Location => No_Location,
Default => False);
-- Value of a non existing variable or array element
@@ -302,10 +308,6 @@
return Boolean;
-- Returns True if Left and Right are the same naming scheme
-- not considering Specs and Bodies.
-
- type Project_Id is new Nat;
- No_Project : constant Project_Id := 0;
- -- Id of a Project File
type Project_List is new Nat;
Empty_Project_List : constant Project_List := 0;
Index: prj-nmsc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-nmsc.adb,v
retrieving revision 1.13
diff -u -r1.13 prj-nmsc.adb
--- prj-nmsc.adb 10 Nov 2003 17:29:59 -0000 1.13
+++ prj-nmsc.adb 17 Nov 2003 14:14:07 -0000
@@ -991,8 +991,8 @@
The_Unit_Data := Units.Table (The_Unit_Id);
if Specs then
- if The_Unit_Data.File_Names (Specification).Project /=
- Project
+ if not Check_Project
+ (The_Unit_Data.File_Names (Specification).Project)
then
Error_Msg
(Project,
@@ -1001,8 +1001,8 @@
end if;
else
- if The_Unit_Data.File_Names (Com.Body_Part).Project /=
- Project
+ if not Check_Project
+ (The_Unit_Data.File_Names (Com.Body_Part).Project)
then
Error_Msg
(Project,
Index: prj-proc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-proc.adb,v
retrieving revision 1.10
diff -u -r1.10 prj-proc.adb
--- prj-proc.adb 10 Nov 2003 17:29:59 -0000 1.10
+++ prj-proc.adb 17 Nov 2003 14:14:07 -0000
@@ -56,8 +56,9 @@
-- arguments are not null string.
procedure Add_Attributes
- (Decl : in out Declarations;
- First : Attribute_Node_Id);
+ (Project : Project_Id;
+ Decl : in out Declarations;
+ First : Attribute_Node_Id);
-- Add all attributes, starting with First, with their default
-- values to the package or project with declarations Decl.
@@ -66,21 +67,18 @@
From_Project_Node : Project_Node_Id;
Pkg : Package_Id;
First_Term : Project_Node_Id;
- Kind : Variable_Kind)
- return Variable_Value;
+ Kind : Variable_Kind) return Variable_Value;
-- From N_Expression project node From_Project_Node, compute the value
-- of an expression and return it as a Variable_Value.
function Imported_Or_Extended_Project_From
(Project : Project_Id;
- With_Name : Name_Id)
- return Project_Id;
+ With_Name : Name_Id) return Project_Id;
-- Find an imported or extended project of Project whose name is With_Name
function Package_From
(Project : Project_Id;
- With_Name : Name_Id)
- return Package_Id;
+ With_Name : Name_Id) return Package_Id;
-- Find the package of Project whose name is With_Name
procedure Process_Declarative_Items
@@ -143,8 +141,9 @@
--------------------
procedure Add_Attributes
- (Decl : in out Declarations;
- First : Attribute_Node_Id)
+ (Project : Project_Id;
+ Decl : in out Declarations;
+ First : Attribute_Node_Id)
is
The_Attribute : Attribute_Node_Id := First;
Attribute_Data : Attribute_Record;
@@ -171,7 +170,8 @@
when Single =>
New_Attribute :=
- (Kind => Single,
+ (Project => Project,
+ Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String);
@@ -180,7 +180,8 @@
when List =>
New_Attribute :=
- (Kind => List,
+ (Project => Project,
+ Kind => List,
Location => No_Location,
Default => True,
Values => Nil_String);
@@ -225,8 +226,7 @@
From_Project_Node : Project_Node_Id;
Pkg : Package_Id;
First_Term : Project_Node_Id;
- Kind : Variable_Kind)
- return Variable_Value
+ Kind : Variable_Kind) return Variable_Value
is
The_Term : Project_Node_Id := First_Term;
-- The term in the expression list
@@ -241,6 +241,7 @@
-- Reference to the last string elements in Result, when Kind is List.
begin
+ Result.Project := Project;
Result.Location := Location_Of (First_Term);
-- Process each term of the expression, starting with First_Term
@@ -536,14 +537,16 @@
Expression_Kind_Of (The_Current_Term) = List
then
The_Variable :=
- (Kind => List,
+ (Project => Project,
+ Kind => List,
Location => No_Location,
Default => True,
Values => Nil_String);
else
The_Variable :=
- (Kind => Single,
+ (Project => Project,
+ Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String);
@@ -739,8 +742,7 @@
function Imported_Or_Extended_Project_From
(Project : Project_Id;
- With_Name : Name_Id)
- return Project_Id
+ With_Name : Name_Id) return Project_Id
is
Data : constant Project_Data := Projects.Table (Project);
List : Project_List := Data.Imported_Projects;
@@ -779,8 +781,7 @@
function Package_From
(Project : Project_Id;
- With_Name : Name_Id)
- return Package_Id
+ With_Name : Name_Id) return Package_Id
is
Data : constant Project_Data := Projects.Table (Project);
Result : Package_Id := Data.Decl.Packages;
@@ -1035,7 +1036,8 @@
-- Set the default values of the attributes
Add_Attributes
- (Packages.Table (New_Pkg).Decl,
+ (Project,
+ Packages.Table (New_Pkg).Decl,
Package_Attributes.Table
(Package_Id_Of (Current_Item)).First_Attribute);
@@ -1260,6 +1262,8 @@
Array_Elements.Table (New_Element) :=
Array_Elements.Table (Orig_Element);
+ Array_Elements.Table (New_Element).Value.Project :=
+ Project;
-- Adjust the Next link
@@ -1856,7 +1860,7 @@
Processed_Data.Extended_By := Extended_By;
Processed_Data.Naming := Standard_Naming_Data;
- Add_Attributes (Processed_Data.Decl, Attribute_First);
+ Add_Attributes (Project, Processed_Data.Decl, Attribute_First);
With_Clause := First_With_Clause_Of (From_Project_Node);
while With_Clause /= Empty_Node loop
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.9
diff -u -r1.9 sem_aggr.adb
--- sem_aggr.adb 14 Nov 2003 10:24:43 -0000 1.9
+++ sem_aggr.adb 17 Nov 2003 14:14:08 -0000
@@ -2202,6 +2202,10 @@
-- C : Lim := (..., others => <>);
-- end record;
+ ----------------------------
+ -- Check_Non_Limited_Type --
+ ----------------------------
+
procedure Check_Non_Limited_Type is
begin
if Is_Limited_Type (Etype (Compon))
@@ -2223,6 +2227,8 @@
end if;
end Check_Non_Limited_Type;
+ -- Start of processing for Get_Value
+
begin
Mbox_Present := False;
@@ -2254,8 +2260,8 @@
else
return Expression (Parent (Compon));
end if;
- else
+ else
Check_Non_Limited_Type;
if Present (Others_Etype) and then
@@ -2295,8 +2301,8 @@
else
Expr := Expression (Parent (Compon));
end if;
- else
+ else
Check_Non_Limited_Type;
if Present (Next (Selector_Name)) then
@@ -2926,13 +2932,11 @@
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
-
if not Box_Present (Parent (Selectr)) then
Error_Msg_N
("components in choice list must have same type",
Selectr);
end if;
-
end if;
Next (Selectr);
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.26
diff -u -r1.26 sem_ch12.adb
--- sem_ch12.adb 10 Nov 2003 17:29:59 -0000 1.26
+++ sem_ch12.adb 17 Nov 2003 14:14:08 -0000
@@ -757,9 +757,11 @@
F_Copy : List_Id)
return List_Id
is
- Actual_Types : constant Elist_Id := New_Elmt_List;
- Assoc : constant List_Id := New_List;
- Defaults : constant Elist_Id := New_Elmt_List;
+ Actual_Types : constant Elist_Id := New_Elmt_List;
+ Assoc : constant List_Id := New_List;
+ Defaults : constant Elist_Id := New_Elmt_List;
+ Gen_Unit : constant Entity_Id := Defining_Entity
+ (Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
@@ -985,8 +987,11 @@
Defining_Identifier (Analyzed_Formal));
if No (Match) then
- Error_Msg_NE ("missing actual for instantiation of &",
- Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE
+ ("missing actual&",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
else
@@ -1071,9 +1076,10 @@
if No (Match) then
Error_Msg_NE
- ("missing actual for instantiation of&",
- Instantiation_Node,
- Defining_Identifier (Formal));
+ ("missing actual&",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
@@ -1105,8 +1111,17 @@
end loop;
if Num_Actuals > Num_Matched then
- Error_Msg_N
- ("unmatched actuals in instantiation", Instantiation_Node);
+ if Present (Selector_Name (Actual)) then
+ Error_Msg_NE
+ ("unmatched actual&",
+ Actual, Selector_Name (Actual));
+ Error_Msg_NE ("\in instantiation of& declared#",
+ Actual, Gen_Unit);
+ else
+ Error_Msg_NE
+ ("unmatched actual in instantiation of& declared#",
+ Actual, Gen_Unit);
+ end if;
end if;
elsif Present (Actuals) then
@@ -4641,19 +4656,37 @@
else
-- If the associated node is still defined, the entity in
-- it is global, and must be copied to the instance.
+ -- If this copy is being made for a body to inline, it is
+ -- applied to an instantiated tree, and the entity is already
+ -- present and must be also preserved.
- if Present (Get_Associated_Node (N)) then
- if Nkind (Get_Associated_Node (N)) = Nkind (N) then
- Set_Entity (New_N, Entity (Get_Associated_Node (N)));
- Check_Private_View (N);
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
+ begin
+ if Present (Assoc) then
+ if Nkind (Assoc) = Nkind (N) then
+ Set_Entity (New_N, Entity (Assoc));
+ Check_Private_View (N);
+
+ elsif Nkind (Assoc) = N_Function_Call then
+ Set_Entity (New_N, Entity (Name (Assoc)));
+
+ elsif (Nkind (Assoc) = N_Defining_Identifier
+ or else Nkind (Assoc) = N_Defining_Character_Literal
+ or else Nkind (Assoc) = N_Defining_Operator_Symbol)
+ and then Expander_Active
+ then
+ -- Inlining case: we are copying a tree that contains
+ -- global entities, which are preserved in the copy
+ -- to be used for subsequent inlining.
- elsif Nkind (Get_Associated_Node (N)) = N_Function_Call then
- Set_Entity (New_N, Entity (Name (Get_Associated_Node (N))));
+ null;
- else
- Set_Entity (New_N, Empty);
+ else
+ Set_Entity (New_N, Empty);
+ end if;
end if;
- end if;
+ end;
end if;
-- For expanded name, we must copy the Prefix and Selector_Name
@@ -5618,6 +5651,8 @@
Generic_Flags.Init;
Generic_Renamings_HTable.Reset;
Circularity_Detected := False;
+ Exchanged_Views := No_Elist;
+ Hidden_Entities := No_Elist;
end Initialize;
----------------------------
@@ -6586,8 +6621,10 @@
else
Error_Msg_NE
- ("missing actual for instantiation of &",
- Instantiation_Node, Formal_Sub);
+ ("missing actual&", Instantiation_Node, Formal_Sub);
+ Error_Msg_NE
+ ("\in instantiation of & declared#",
+ Instantiation_Node, Scope (Analyzed_S));
Abandon_Instantiation (Instantiation_Node);
end if;
@@ -6729,8 +6766,12 @@
if No (Actual) then
Error_Msg_NE
- ("missing actual for instantiation of &",
+ ("missing actual&",
Instantiation_Node, Formal_Id);
+ Error_Msg_NE
+ ("\in instantiation of & declared#",
+ Instantiation_Node,
+ Scope (Defining_Identifier (Analyzed_Formal)));
Abandon_Instantiation (Instantiation_Node);
end if;
@@ -6893,8 +6934,11 @@
else
Error_Msg_NE
- ("missing actual for instantiation of &",
- Instantiation_Node, Formal_Id);
+ ("missing actual&",
+ Instantiation_Node, Formal_Id);
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node,
+ Scope (Defining_Identifier (Analyzed_Formal)));
if Is_Scalar_Type
(Etype (Defining_Identifier (Analyzed_Formal)))
Index: sem_ch13.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.adb,v
retrieving revision 1.10
diff -u -r1.10 sem_ch13.adb
--- sem_ch13.adb 10 Nov 2003 17:29:59 -0000 1.10
+++ sem_ch13.adb 17 Nov 2003 14:14:08 -0000
@@ -1881,7 +1881,7 @@
Biased : Boolean;
Max_Bit_So_Far : Uint;
- -- Records the maximum bit position so far. If all field positoins
+ -- Records the maximum bit position so far. If all field positions
-- are monotonically increasing, then we can skip the circuit for
-- checking for overlap, since no overlap is possible.
@@ -2153,10 +2153,9 @@
CC, Rectype);
end if;
- -- This information is also set in the
- -- corresponding component of the base type,
- -- found by accessing the Original_Record_Component
- -- link if it is present.
+ -- This information is also set in the corresponding
+ -- component of the base type, found by accessing the
+ -- Original_Record_Component link if it is present.
Ocomp := Original_Record_Component (Comp);
@@ -2848,21 +2847,68 @@
begin
Biased := False;
- -- Immediate return if size is same as standard size or if composite
- -- item, or generic type, or type with previous errors.
+ -- Dismiss cases for generic types or types with previous errors
if No (UT)
or else UT = Any_Type
or else Is_Generic_Type (UT)
or else Is_Generic_Type (Root_Type (UT))
- or else Is_Composite_Type (UT)
- or else (Known_Esize (UT) and then Siz = Esize (UT))
then
return;
+ -- Check case of bit packed array
+
+ elsif Is_Array_Type (UT)
+ and then Known_Static_Component_Size (UT)
+ and then Is_Bit_Packed_Array (UT)
+ then
+ declare
+ Asiz : Uint;
+ Indx : Node_Id;
+ Ityp : Entity_Id;
+
+ begin
+ Asiz := Component_Size (UT);
+ Indx := First_Index (UT);
+ loop
+ Ityp := Etype (Indx);
+
+ -- If non-static bound, then we are not in the business of
+ -- trying to check the length, and indeed an error will be
+ -- issued elsewhere, since sizes of non-static array types
+ -- cannot be set implicitly or explicitly.
+
+ if not Is_Static_Subtype (Ityp) then
+ return;
+ end if;
+
+ -- Otherwise accumulate next dimension
+
+ Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
+ Expr_Value (Type_Low_Bound (Ityp)) +
+ Uint_1);
+
+ Next_Index (Indx);
+ exit when No (Indx);
+ end loop;
+
+ if Asiz <= Siz then
+ return;
+ else
+ Error_Msg_Uint_1 := Asiz;
+ Error_Msg_NE
+ ("size for& too small, minimum allowed is ^", N, T);
+ end if;
+ end;
+
+ -- All other composite types are ignored
+
+ elsif Is_Composite_Type (UT) then
+ return;
+
-- For fixed-point types, don't check minimum if type is not frozen,
- -- since type is not known till then
- -- at freeze time.
+ -- since we don't know all the characteristics of the type that can
+ -- affect the size (e.g. a specified small) till freeze time.
elsif Is_Fixed_Point_Type (UT)
and then not Is_Frozen (UT)
@@ -2872,6 +2918,14 @@
-- Cases for which a minimum check is required
else
+ -- Ignore if specified size is correct for the type
+
+ if Known_Esize (UT) and then Siz = Esize (UT) then
+ return;
+ end if;
+
+ -- Otherwise get minimum size
+
M := UI_From_Int (Minimum_Size (UT));
if Siz < M then
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.8
diff -u -r1.8 sem_ch4.adb
--- sem_ch4.adb 14 Nov 2003 10:24:43 -0000 1.8
+++ sem_ch4.adb 17 Nov 2003 14:14:08 -0000
@@ -338,13 +338,18 @@
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
- if Nkind (Expression (E)) /= N_Aggregate
- and then Is_Limited_Type (Type_Id)
+ if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
then
- Error_Msg_N ("initialization not allowed for limited types", N);
- Explain_Limited_Type (Type_Id, N);
+ if Extensions_Allowed
+ and then Nkind (Expression (E)) = N_Aggregate
+ then
+ null;
+ else
+ Error_Msg_N ("initialization not allowed for limited types", N);
+ Explain_Limited_Type (Type_Id, N);
+ end if;
end if;
Analyze_And_Resolve (Expression (E), Type_Id);
Index: sem_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch6.adb,v
retrieving revision 1.9
diff -u -r1.9 sem_ch6.adb
--- sem_ch6.adb 21 Oct 2003 13:42:20 -0000 1.9
+++ sem_ch6.adb 17 Nov 2003 14:14:09 -0000
@@ -82,11 +82,7 @@
-- Analyze a generic subprogram body. N is the body to be analyzed,
-- and Gen_Id is the defining entity Id for the corresponding spec.
- function Build_Body_To_Inline
- (N : Node_Id;
- Subp : Entity_Id;
- Orig_Body : Node_Id)
- return Boolean;
+ procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
-- If a subprogram has pragma Inline and inlining is active, use generic
-- machinery to build an unexpanded body for the subprogram. This body is
-- subsequenty used for inline expansions at call sites. If subprogram can
@@ -132,8 +128,7 @@
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
- New_E : Entity_Id)
- return Boolean;
+ New_E : Entity_Id) return Boolean;
-- Enforce the rule given in 12.3(18): a private operation in an instance
-- overrides an inherited operation only if the corresponding operation
-- was overriding in the generic. This can happen for primitive operations
@@ -156,8 +151,7 @@
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
- Get_Inst : Boolean := False)
- return Boolean;
+ Get_Inst : Boolean := False) return Boolean;
-- Check that two formal parameter types conform, checking both
-- for equality of base types, and where required statically
-- matching subtypes, depending on the setting of Ctype.
@@ -1142,9 +1136,7 @@
(Front_End_Inlining
or else Configurable_Run_Time_Mode)))
then
- if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
- null;
- end if;
+ Build_Body_To_Inline (N, Spec_Id);
end if;
-- Now we can go on to analyze the body
@@ -1492,12 +1484,7 @@
-- Build_Body_To_Inline --
--------------------------
- function Build_Body_To_Inline
- (N : Node_Id;
- Subp : Entity_Id;
- Orig_Body : Node_Id)
- return Boolean
- is
+ procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Original_Body : Node_Id;
Body_To_Analyze : Node_Id;
@@ -1732,7 +1719,7 @@
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Body_To_Inline (Decl))
then
- return True; -- Done already.
+ return; -- Done already.
-- Functions that return unconstrained composite types will require
-- secondary stack handling, and cannot currently be inlined.
@@ -1744,64 +1731,13 @@
then
Cannot_Inline
("cannot inline & (unconstrained return type)?", N, Subp);
- return False;
- end if;
-
- -- We need to capture references to the formals in order to substitute
- -- the actuals at the point of inlining, i.e. instantiation. To treat
- -- the formals as globals to the body to inline, we nest it within
- -- a dummy parameterless subprogram, declared within the real one.
-
- Original_Body := Orig_Body;
-
- -- Within an instance, the current tree is already the result of
- -- a generic copy, and not what we need for subsequent inlining.
- -- We create the required body by doing an instantiating copy, to
- -- obtain the proper partially analyzed tree.
-
- if In_Instance then
- if No (Generic_Parent (Specification (N))) then
- return False;
-
- elsif Is_Child_Unit (Scope (Current_Scope)) then
- return False;
-
- elsif Scope (Current_Scope) = Cunit_Entity (Main_Unit) then
-
- -- compiling an instantiation. There is no point in generating
- -- bodies to inline, because they will not be used.
-
- return False;
-
- else
- Body_To_Analyze :=
- Copy_Generic_Node
- (Generic_Parent (Specification (N)), Empty,
- Instantiating => True);
- end if;
-
- -- Case of not in an instance
-
- else
- Body_To_Analyze :=
- Copy_Generic_Node (Original_Body, Empty,
- Instantiating => False);
- end if;
-
- Set_Parameter_Specifications (Specification (Original_Body), No_List);
- Set_Defining_Unit_Name (Specification (Original_Body),
- Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
- Set_Corresponding_Spec (Original_Body, Empty);
-
- if Ekind (Subp) = E_Function then
- Set_Subtype_Mark (Specification (Original_Body),
- New_Occurrence_Of (Etype (Subp), Sloc (N)));
+ return;
end if;
- if Present (Declarations (Orig_Body))
- and then Has_Excluded_Declaration (Declarations (Orig_Body))
+ if Present (Declarations (N))
+ and then Has_Excluded_Declaration (Declarations (N))
then
- return False;
+ return;
end if;
if Present (Handled_Statement_Sequence (N)) then
@@ -1810,12 +1746,12 @@
("cannot inline& (exception handler)?",
First (Exception_Handlers (Handled_Statement_Sequence (N))),
Subp);
- return False;
+ return;
elsif
Has_Excluded_Statement
(Statements (Handled_Statement_Sequence (N)))
then
- return False;
+ return;
end if;
end if;
@@ -1827,16 +1763,36 @@
and then not Is_Always_Inlined (Subp)
then
Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
- return False;
+ return;
end if;
if Has_Pending_Instantiation then
Cannot_Inline
("cannot inline& (forward instance within enclosing body)?",
N, Subp);
- return False;
+ return;
+ end if;
+
+ -- Within an instance, the body to inline must be treated as a nested
+ -- generic, so that the proper global references are preserved.
+
+ if In_Instance then
+ Save_Env (Scope (Current_Scope), Scope (Current_Scope));
+ Original_Body := Copy_Generic_Node (N, Empty, True);
+ else
+ Original_Body := Copy_Separate_Tree (N);
end if;
+ -- We need to capture references to the formals in order to substitute
+ -- the actuals at the point of inlining, i.e. instantiation. To treat
+ -- the formals as globals to the body to inline, we nest it within
+ -- a dummy parameterless subprogram, declared within the real one.
+
+ Set_Parameter_Specifications (Specification (Original_Body), No_List);
+ Set_Defining_Unit_Name (Specification (Original_Body),
+ Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
+ Set_Corresponding_Spec (Original_Body, Empty);
+
Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
-- Set return type of function, which is also global and does not need
@@ -1866,7 +1822,10 @@
Set_Body_To_Inline (Decl, Original_Body);
Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
Set_Is_Inlined (Subp);
- return True;
+
+ if In_Instance then
+ Restore_Env;
+ end if;
end Build_Body_To_Inline;
-------------------
@@ -2972,8 +2931,7 @@
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
- Get_Inst : Boolean := False)
- return Boolean
+ Get_Inst : Boolean := False) return Boolean
is
Type_1 : Entity_Id := T1;
Type_2 : Entity_Id := T2;
@@ -3475,8 +3433,7 @@
function Fully_Conformant_Expressions
(Given_E1 : Node_Id;
- Given_E2 : Node_Id)
- return Boolean
+ Given_E2 : Node_Id) return Boolean
is
E1 : constant Node_Id := Original_Node (Given_E1);
E2 : constant Node_Id := Original_Node (Given_E2);
@@ -3849,8 +3806,7 @@
function Fully_Conformant_Discrete_Subtypes
(Given_S1 : Node_Id;
- Given_S2 : Node_Id)
- return Boolean
+ Given_S2 : Node_Id) return Boolean
is
S1 : constant Node_Id := Original_Node (Given_S1);
S2 : constant Node_Id := Original_Node (Given_S2);
@@ -3942,8 +3898,7 @@
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
- New_E : Entity_Id)
- return Boolean
+ New_E : Entity_Id) return Boolean
is
Formal : Entity_Id;
F_Typ : Entity_Id;
@@ -3956,8 +3911,7 @@
function Types_Correspond
(P_Type : Entity_Id;
- N_Type : Entity_Id)
- return Boolean;
+ N_Type : Entity_Id) return Boolean;
-- Returns true if and only if the types (or designated types
-- in the case of anonymous access types) are the same or N_Type
-- is derived directly or indirectly from P_Type.
@@ -4005,8 +3959,7 @@
function Types_Correspond
(P_Type : Entity_Id;
- N_Type : Entity_Id)
- return Boolean
+ N_Type : Entity_Id) return Boolean
is
Prev_Type : Entity_Id := Base_Type (P_Type);
New_Type : Entity_Id := Base_Type (N_Type);
@@ -5245,7 +5198,6 @@
function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
Result : Boolean;
-
begin
Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
return Result;
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.10
diff -u -r1.10 sprint.adb
--- sprint.adb 14 Nov 2003 10:24:43 -0000 1.10
+++ sprint.adb 17 Nov 2003 14:14:09 -0000
@@ -928,6 +928,7 @@
Set_Debug_Sloc;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
+
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
else
Index: s-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.adb,v
retrieving revision 1.4
diff -u -r1.4 s-thread.adb
--- s-thread.adb 14 Nov 2003 10:24:43 -0000 1.4
+++ s-thread.adb 17 Nov 2003 14:14:09 -0000
@@ -33,6 +33,11 @@
-- This is the VxWorks version of this package
+pragma Restrictions (No_Tasking);
+-- The VxWorks version of this package is intended only for programs
+-- which do not use Ada tasking. This restriction ensures that this
+-- will be checked by the binder.
+
with System.Secondary_Stack;
with Unchecked_Conversion;
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.37
diff -u -r1.37 utils.c
--- utils.c 4 Nov 2003 12:51:46 -0000 1.37
+++ utils.c 17 Nov 2003 14:14:09 -0000
@@ -148,7 +148,7 @@
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static int value_zerop (tree);
-static tree float_type_for_size (int, enum machine_mode);
+static tree float_type_for_precision (int, enum machine_mode);
static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
static tree make_descriptor_field (const char *,tree, tree, tree);
@@ -1992,7 +1992,7 @@
/* Likewise for floating-point types. */
static tree
-float_type_for_size (int precision, enum machine_mode mode)
+float_type_for_precision (int precision, enum machine_mode mode)
{
tree t;
char type_name[20];
@@ -2023,7 +2023,7 @@
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
{
if (GET_MODE_CLASS (mode) == MODE_FLOAT)
- return float_type_for_size (GET_MODE_BITSIZE (mode), mode);
+ return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
}
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-14 10:40 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-14 10:40 UTC (permalink / raw)
To: gcc-patches
Various clean ups.
Implementation of -gnatS compiler switch to replace gnatpsta
Implementation of new Ada construct (limited aggregates)
run time clean ups and improvements.
error handling improvements and fixes.
Tested on x86-linux
--
2003-11-13 Vincent Celier <celier@gnat.com>
* 5bml-tgt.adb (Build_Dynamic_Library): Use
Osint.Include_Dir_Default_Prefix instead of
Sdefault.Include_Dir_Default_Name.
* gnatlbr.adb: Update Copyright notice
(Gnatlbr): : Use Osint.Include_Dir_Default_Prefix instead of
Sdefault.Include_Dir_Default_Name and Osint.Object_Dir_Default_Prefix
instead of Sdefault.Object_Dir_Default_Name
* gnatlink.adb:
(Process_Binder_File): Never suppress the option following -Xlinker
* mdll-utl.adb:
(Gcc): Use Osint.Object_Dir_Default_Prefix instead of
Sdefault.Object_Dir_Default_Name.
* osint.ads, osint.adb:
(Include_Dir_Default_Prefix, Object_Dir_Default_Prefix): New functions
Minor reformatting.
* vms_conv.ads: Minor reformating
Remove GNAT STANDARD and GNAT PSTA
* vms_conv.adb:
Allow GNAT MAKE to have several files on the command line.
(Init_Object_Dirs): Use Osint.Object_Dir_Default_Prefix instead of
Sdefault.Object_Dir_Default_Name.
Minor Reformating
Remove data for GNAT STANDARD
* vms_data.ads:
Add new compiler qualifier /PRINT_STANDARD (-gnatS)
Remove data for GNAT STANDARD
Remove options and documentation for -gnatwb/-gnatwB: these warning
options no longer exist.
2003-11-13 Ed Falis <falis@gnat.com>
* 5zthrini.adb: (Init_RTS): Made visible
* 5zthrini.adb:
(Register): Removed unnecessary call to taskVarGet that checked whether
an ATSD was already set as a task var for the argument thread.
* s-thread.adb:
Updated comment to reflect that this is a VxWorks version
Added context clause for System.Threads.Initialization
Added call to System.Threads.Initialization.Init_RTS
2003-11-13 Jerome Guitton <guitton@act-europe.fr>
* 5zthrini.adb:
(Init_RTS): New procedure, for the initialization of the run-time lib.
* s-thread.adb:
Remove dependancy on System.Init, so that this file can be used in the
AE653 sequential run-time lib.
2003-11-13 Robert Dewar <dewar@gnat.com>
* bindgen.adb: Minor reformatting
2003-11-13 Ed Schonberg <schonberg@gnat.com>
* checks.adb:
(Apply_Discriminant_Check): Do no apply check if target type is derived
from source type with no applicable constraint.
* lib-writ.adb:
(Ensure_System_Dependency): Do not apply the style checks that may have
been specified for the main unit.
* sem_ch8.adb:
(Find_Selected_Component): Further improvement in error message, with
RM reference.
* sem_res.adb:
(Resolve): Handle properly the case of an illegal overloaded protected
procedure.
2003-11-13 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb:
(Has_Default_Init_Comps): New function to check the presence of
default initialization in an aggregate.
(Build_Record_Aggr_Code): Recursively expand the ancestor in case of
extension aggregate of a limited record. In addition, a new formal
was added to do not initialize the record controller (if any) during
this recursive expansion of ancestors.
(Init_Controller): Add support for limited record components.
(Expand_Record_Aggregate): In case of default initialized components
convert the aggregate into a set of assignments.
* par-ch4.adb (P_Aggregate_Or_Paren_Expr): Update the comment
describing the new syntax.
Nothing else needed to be done because this subprogram delegates part of
its work to P_Precord_Or_Array_Component_Association.
(P_Record_Or_Array_Component_Association): Give support to the new
syntax for default initialization of components.
* sem_aggr.adb:
(Resolve_Aggregate): Relax the strictness of the frontend in case of
limited aggregates.
(Resolve_Record_Aggregate): Give support to default initialized
components.
(Get_Value): In case of default initialized components, duplicate
the corresponding default expression (from the record type
declaration). In case of default initialization in the *others*
choice, do not check that all components have the same type.
(Resolve_Extension_Aggregate): Give support to limited extension
aggregates.
* sem_ch3.adb:
(Check_Initialization): Relax the strictness of the front-end in case
of aggregate and extension aggregates. This test is now done in
Get_Value in a per-component manner.
* sem_ch4.adb (Analyze_Allocator): Don't post an error if the
expression corresponds to a limited aggregate. This test is now done
in Get_Value.
* sinfo.ads, sinfo.adb (N_Component_Association): Addition of
Box_Present flag.
* sprint.adb (Sprint_Node_Actual): Modified to print an mbox if
present in an N_Component_Association node
2003-11-13 Thomas Quinot <quinot@act-europe.fr>
* sem_ch9.adb (Analyze_Accept_Statement): A procedure hides a
type-conformant entry only if they are homographs.
2003-11-13 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 5bml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5bml-tgt.adb,v
retrieving revision 1.1
diff -u -r1.1 5bml-tgt.adb
--- 5bml-tgt.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 5bml-tgt.adb 13 Nov 2003 22:38:20 -0000
@@ -35,10 +35,10 @@
with MLib.Fil;
with MLib.Utl;
with Namet; use Namet;
+with Osint; use Osint;
with Opt;
with Output; use Output;
with Prj.Com;
-with Sdefault;
package body MLib.Tgt is
@@ -175,9 +175,9 @@
Last : Natural;
begin
- Open (File, In_File,
- Sdefault.Include_Dir_Default_Name.all &
- "/s-osinte.ads");
+ Open
+ (File, In_File,
+ Include_Dir_Default_Prefix & "/s-osinte.ads");
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
Index: 5zthrini.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zthrini.adb,v
retrieving revision 1.2
diff -u -r1.2 5zthrini.adb
--- 5zthrini.adb 10 Nov 2003 17:29:58 -0000 1.2
+++ 5zthrini.adb 13 Nov 2003 22:38:20 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -36,8 +36,8 @@
with System.Secondary_Stack;
with System.Storage_Elements;
+with System.Soft_Links;
with Interfaces.C;
-with Unchecked_Conversion;
package body System.Threads.Initialization is
@@ -45,6 +45,8 @@
package SSS renames System.Secondary_Stack;
+ package SSL renames System.Soft_Links;
+
procedure Initialize_Task_Hooks;
-- Register the appropriate hooks (Register and Reset_TSD) to the
-- underlying OS, so that they will be called when a task is created
@@ -61,6 +63,19 @@
-- Separate, as these hooks are different for AE653 and VxWorks 5.5.
--------------
+ -- Init_RTS --
+ --------------
+
+ procedure Init_RTS is
+ begin
+ SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
+ SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
+ SSL.Get_Current_Excep := Get_Current_Excep'Access;
+ SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
+ SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ end Init_RTS;
+
+ --------------
-- Register --
--------------
@@ -76,9 +91,7 @@
-- (depending on configRecord.c, allocation could be disabled).
-- Otherwise, everything could have been done in Thread_Body_Enter.
- if OSI.taskIdVerify (T) = OSI.ERROR
- or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
- then
+ if OSI.taskIdVerify (T) = OSI.ERROR then
return OSI.ERROR;
end if;
@@ -102,6 +115,7 @@
begin
Initialize_Task_Hooks;
+ Init_RTS;
-- Register the environment task
declare
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.15
diff -u -r1.15 bindgen.adb
--- bindgen.adb 10 Nov 2003 17:29:58 -0000 1.15
+++ bindgen.adb 13 Nov 2003 22:38:21 -0000
@@ -1895,6 +1895,7 @@
procedure Gen_Output_File (Filename : String) is
Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
+
begin
-- Acquire settings for Interrupt_State pragmas
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.12
diff -u -r1.12 checks.adb
--- checks.adb 21 Oct 2003 13:41:58 -0000 1.12
+++ checks.adb 13 Nov 2003 22:38:21 -0000
@@ -1183,6 +1183,26 @@
if No (DconS) then
return;
end if;
+
+ -- A further optimization: if T_Typ is derived from S_Typ
+ -- without imposing a constraint, no check is needed.
+
+ if Nkind (Original_Node (Parent (T_Typ))) =
+ N_Full_Type_Declaration
+ then
+ declare
+ Type_Def : Node_Id :=
+ Type_Definition
+ (Original_Node (Parent (T_Typ)));
+ begin
+ if Nkind (Type_Def) = N_Derived_Type_Definition
+ and then Is_Entity_Name (Subtype_Indication (Type_Def))
+ and then Entity (Subtype_Indication (Type_Def)) = S_Typ
+ then
+ return;
+ end if;
+ end;
+ end if;
end if;
DconT := First_Elmt (Discriminant_Constraint (T_Typ));
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.7
diff -u -r1.7 exp_aggr.adb
--- exp_aggr.adb 21 Oct 2003 13:41:59 -0000 1.7
+++ exp_aggr.adb 13 Nov 2003 22:38:21 -0000
@@ -70,6 +70,10 @@
-- statement of variant part will usually be small and probably in near
-- sorted order.
+ 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.
+
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
@@ -97,12 +101,13 @@
-- assignments component per component.
function Build_Record_Aggr_Code
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id;
- Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty)
- return List_Id;
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id;
+ Flist : Node_Id := Empty;
+ Obj : Entity_Id := Empty;
+ Is_Limited_Ancestor_Expansion : Boolean := False)
+ return List_Id;
-- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
-- of the aggregate. Target is an expression containing the
-- location on which the component by component assignments will
@@ -113,6 +118,8 @@
-- object declaration and dynamic allocation cases, it contains
-- an entity that allows to know if the value being created needs to be
-- attached to the final list in case of pragma finalize_Storage_Only.
+ -- Is_Limited_Ancestor_Expansion indicates that the function has been
+ -- called recursively to expand the limited ancestor to avoid copying it.
function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
-- Return true if one of the component is of a discriminated type with
@@ -1269,12 +1276,13 @@
----------------------------
function Build_Record_Aggr_Code
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id;
- Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty)
- return List_Id
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id;
+ Flist : Node_Id := Empty;
+ Obj : Entity_Id := Empty;
+ Is_Limited_Ancestor_Expansion : Boolean := False)
+ return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
L : constant List_Id := New_List;
@@ -1540,20 +1548,50 @@
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
- if Init_Pr then
- Append_List_To (L,
- Build_Initialization_Call (Loc,
- Id_Ref => Ref,
- Typ => RTE (RE_Record_Controller),
- In_Init_Proc => Within_Init_Proc));
- end if;
+ -- Give support to default initialization of limited types and
+ -- components
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
- Name_Initialize), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ if (Nkind (Target) = N_Identifier
+ and then Is_Limited_Type (Etype (Target)))
+ or else (Nkind (Target) = N_Selected_Component
+ and then Is_Limited_Type (Etype (Selector_Name (Target))))
+ or else (Nkind (Target) = N_Unchecked_Type_Conversion
+ and then Is_Limited_Type (Etype (Target)))
+ then
+
+ if Init_Pr then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => RTE (RE_Limited_Record_Controller),
+ In_Init_Proc => Within_Init_Proc));
+ end if;
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op (RTE (RE_Limited_Record_Controller),
+ Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+
+ else
+ if Init_Pr then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => RTE (RE_Record_Controller),
+ In_Init_Proc => Within_Init_Proc));
+ end if;
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
+ Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+
+ end if;
Append_To (L,
Make_Attach_Call (
@@ -1648,6 +1686,21 @@
Check_Ancestor_Discriminants (Entity (A));
end if;
+ -- 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;
+
+ Append_List_To (Start_L,
+ Build_Record_Aggr_Code (
+ N => Expression (A),
+ Typ => Etype (Expression (A)),
+ Target => Target,
+ Flist => Flist,
+ Obj => Obj,
+ Is_Limited_Ancestor_Expansion => True));
+
-- If the ancestor part is an expression "E", we generate
-- T(tmp) := E;
@@ -1767,6 +1820,22 @@
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
+ -- Default initialization of a limited component
+
+ if Box_Present (Comp)
+ and then Is_Limited_Type (Etype (Selector))
+ then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Occurrence_Of (Selector,
+ Loc)),
+ Typ => Etype (Selector)));
+
+ goto Next_Comp;
+ end if;
+
-- ???
if Ekind (Selector) /= E_Discriminant
@@ -1900,6 +1969,8 @@
end;
end if;
+ <<Next_Comp>>
+
Next (Comp);
end loop;
@@ -1997,7 +2068,9 @@
-- In the Has_Controlled component case, all the intermediate
-- controllers must be initialized
- if Has_Controlled_Component (Typ) then
+ if Has_Controlled_Component (Typ)
+ and not Is_Limited_Ancestor_Expansion
+ then
declare
Inner_Typ : Entity_Id;
Outer_Typ : Entity_Id;
@@ -4082,6 +4155,9 @@
then
Convert_To_Assignments (N, Typ);
+ elsif Has_Default_Init_Comps (N) then
+ Convert_To_Assignments (N, Typ);
+
elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
Convert_To_Assignments (N, Typ);
@@ -4401,6 +4477,31 @@
end if;
end if;
end Expand_Record_Aggregate;
+
+ ----------------------------
+ -- Has_Default_Init_Comps --
+ ----------------------------
+
+ function Has_Default_Init_Comps (N : Node_Id) return Boolean is
+ Comps : constant List_Id := Component_Associations (N);
+ C : Node_Id;
+ begin
+ pragma Assert (Nkind (N) = N_Aggregate
+ or else Nkind (N) = N_Extension_Aggregate);
+ if No (Comps) then
+ return False;
+ end if;
+
+ C := First (Comps);
+ while Present (C) loop
+ if Box_Present (C) then
+ return True;
+ end if;
+
+ Next (C);
+ end loop;
+ return False;
+ end Has_Default_Init_Comps;
--------------------------
-- Is_Delayed_Aggregate --
Index: gnatlbr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlbr.adb,v
retrieving revision 1.7
diff -u -r1.7 gnatlbr.adb
--- gnatlbr.adb 21 Oct 2003 13:42:08 -0000 1.7
+++ gnatlbr.adb 13 Nov 2003 22:38:21 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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- --
@@ -47,7 +47,6 @@
with Gnatvsn; use Gnatvsn;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with Osint; use Osint;
-with Sdefault; use Sdefault;
with System;
procedure GnatLbr is
@@ -192,7 +191,7 @@
-- there are two.
--
Include_Dirs := 0;
- Include_Dir_Name := String_Access (Include_Dir_Default_Name);
+ Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (String_Access (Include_Dir_Name));
loop
@@ -208,7 +207,7 @@
end loop;
Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (String_Access (Object_Dir_Name));
loop
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.9
diff -u -r1.9 gnatlink.adb
--- gnatlink.adb 24 Oct 2003 14:39:55 -0000 1.9
+++ gnatlink.adb 13 Nov 2003 22:38:21 -0000
@@ -619,6 +619,10 @@
GNAT_Shared : Boolean := False;
-- Save state of -shared option.
+ Xlinker_Was_Previous : Boolean := False;
+ -- Indicate that "-Xlinker" was the option preceding the current
+ -- option. If True, then the current option is never suppressed.
+
-- Rollback data
-- These data items are used to store current binder file context.
@@ -936,8 +940,17 @@
-- Process switches and options
if Next_Line (Nfirst .. Nlast) /= End_Info then
+ Xlinker_Was_Previous := False;
+
loop
- if Next_Line (Nfirst .. Nlast) = "-static" then
+ if Xlinker_Was_Previous
+ or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
+ then
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
+
+ elsif Next_Line (Nfirst .. Nlast) = "-static" then
GNAT_Static := True;
elsif Next_Line (Nfirst .. Nlast) = "-shared" then
@@ -946,9 +959,7 @@
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
- elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast))
- or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
- then
+ elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
@@ -1124,6 +1135,8 @@
new String'(Next_Line (Nfirst .. Nlast));
end if;
end if;
+
+ Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker";
Get_Next_Line;
exit when Next_Line (Nfirst .. Nlast) = End_Info;
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.8
diff -u -r1.8 lib-writ.adb
--- lib-writ.adb 30 Oct 2003 11:50:12 -0000 1.8
+++ lib-writ.adb 13 Nov 2003 22:38:21 -0000
@@ -91,6 +91,8 @@
System_Fname : File_Name_Type;
-- File name for system spec if needed for dummy entry
+ Save_Style : constant Boolean := Style_Check;
+
begin
-- Nothing to do if we already compiled System
@@ -133,9 +135,12 @@
Error_Location => No_Location);
-- Parse system.ads so that the checksum is set right
+ -- Style checks are not applied.
+ Style_Check := False;
Initialize_Scanner (Units.Last, System_Source_File_Index);
Discard_List (Par (Configuration_Pragmas => False));
+ Style_Check := Save_Style;
end Ensure_System_Dependency;
---------------
Index: mdll-utl.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mdll-utl.adb,v
retrieving revision 1.4
diff -u -r1.4 mdll-utl.adb
--- mdll-utl.adb 21 Oct 2003 13:42:09 -0000 1.4
+++ mdll-utl.adb 13 Nov 2003 22:38:21 -0000
@@ -30,7 +30,7 @@
with Ada.Exceptions;
with GNAT.Directory_Operations;
-with Sdefault;
+with Osint;
package body MDLL.Utl is
@@ -155,7 +155,7 @@
Base_File : String := "";
Build_Lib : Boolean := False)
is
- use Sdefault;
+ use Osint;
Arguments : OS_Lib.Argument_List
(1 .. 5 + Files'Length + Options'Length);
@@ -167,7 +167,7 @@
Out_V : aliased String := Output_File;
Bas_Opt : aliased String := "-Wl,--base-file," & Base_File;
Lib_Opt : aliased String := "-mdll";
- Lib_Dir : aliased String := "-L" & Object_Dir_Default_Name.all;
+ Lib_Dir : aliased String := "-L" & Object_Dir_Default_Prefix;
begin
A := A + 1;
Index: osint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.adb,v
retrieving revision 1.13
diff -u -r1.13 osint.adb
--- osint.adb 10 Nov 2003 09:42:57 -0000 1.13
+++ osint.adb 13 Nov 2003 22:38:21 -0000
@@ -41,9 +41,12 @@
package body Osint is
Running_Program : Program_Type := Unspecified;
- Program_Set : Boolean := False;
+ -- comment required here ???
- Std_Prefix : String_Ptr;
+ Program_Set : Boolean := False;
+ -- comment required here ???
+
+ Std_Prefix : String_Ptr;
-- Standard prefix, computed dynamically the first time Relocate_Path
-- is called, and cached for subsequent calls.
@@ -66,8 +69,7 @@
function Append_Suffix_To_File_Name
(Name : Name_Id;
- Suffix : String)
- return Name_Id;
+ Suffix : String) return Name_Id;
-- Appends Suffix to Name and returns the new name.
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
@@ -81,14 +83,14 @@
-- The executable must be located in a directory called "bin", or
-- under root/lib/gcc-lib/..., or under root/libexec/gcc/... Thus, if
-- the executable is stored in directory "/foo/bar/bin", this routine
- -- returns "/foo/bar/".
- -- Return "" if the location is not recognized as described above.
+ -- returns "/foo/bar/". Return "" if the location is not recognized
+ -- as described above.
function Update_Path (Path : String_Ptr) return String_Ptr;
-- Update the specified path to replace the prefix with the location
-- where GNAT is installed. See the file prefix.c in GCC for details.
- procedure Write_With_Check (A : Address; N : Integer);
+ procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
@@ -99,8 +101,7 @@
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
- Name : String)
- return File_Name_Type;
+ Name : String) return File_Name_Type;
-- See if the file N whose name is Name exists in directory Dir. Dir is
-- an index into the Lib_Search_Directories table if T = Library.
-- Otherwise if T = Source, Dir is an index into the
@@ -112,8 +113,7 @@
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access;
+ Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String. Are we doing this to avoid
-- withing Interfaces.C.Strings ???
@@ -218,17 +218,15 @@
Equal => "=");
function Smart_Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type;
-- Exactly like Find_File except that if File_Cache_Enabled is True this
-- routine looks first in the hash table to see if the full name of the
-- file is already available.
function Smart_File_Stamp
- (N : File_Name_Type;
- T : File_Type)
- return Time_Stamp_Type;
+ (N : File_Name_Type;
+ T : File_Type) return Time_Stamp_Type;
-- Takes the same parameter as the routine above (N is a file name
-- without any prefix directory information) and behaves like File_Stamp
-- except that if File_Cache_Enabled is True this routine looks first in
@@ -591,8 +589,7 @@
function Append_Suffix_To_File_Name
(Name : Name_Id;
- Suffix : String)
- return Name_Id
+ Suffix : String) return Name_Id
is
begin
Get_Name_String (Name);
@@ -785,7 +782,7 @@
return new String'("");
end Get_Install_Dir;
- -- Beginning of Executable_Prefix
+ -- Start of processing for Executable_Prefix
begin
Osint.Fill_Arg (Exec_Name'Address, 0);
@@ -799,7 +796,7 @@
end if;
end loop;
- -- If you are here, the user has typed the executable name with no
+ -- If we come here, the user has typed the executable name with no
-- directory prefix.
return Get_Install_Dir (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name).all);
@@ -890,9 +887,8 @@
---------------
function Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type
is
begin
Get_Name_String (N);
@@ -1089,8 +1085,7 @@
-- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
function Get_Next_Dir_In_Path
- (Search_Path : String_Access)
- return String_Access
+ (Search_Path : String_Access) return String_Access
is
Lower_Bound : Positive := Search_Path_Pos;
Upper_Bound : Positive;
@@ -1143,8 +1138,7 @@
function Get_RTS_Search_Dir
(Search_Dir : String;
- File_Type : Search_File_Type)
- return String_Ptr
+ File_Type : Search_File_Type) return String_Ptr
is
procedure Get_Current_Dir
(Dir : System.Address;
@@ -1299,6 +1293,28 @@
end if;
end Get_RTS_Search_Dir;
+ --------------------------------
+ -- Include_Dir_Default_Prefix --
+ --------------------------------
+
+ function Include_Dir_Default_Prefix return String is
+ Include_Dir : String_Access :=
+ String_Access (Update_Path (Include_Dir_Default_Name));
+
+ begin
+ if Include_Dir = null then
+ return "";
+
+ else
+ declare
+ Result : constant String := Include_Dir.all;
+ begin
+ Free (Include_Dir);
+ return Result;
+ end;
+ end if;
+ end Include_Dir_Default_Prefix;
+
----------------
-- Initialize --
----------------
@@ -1409,8 +1425,7 @@
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
- Name : String)
- return File_Name_Type
+ Name : String) return File_Name_Type
is
Dir_Name : String_Ptr;
@@ -1451,9 +1466,8 @@
-------------------------------
function Matching_Full_Source_Name
- (N : File_Name_Type;
- T : Time_Stamp_Type)
- return File_Name_Type
+ (N : File_Name_Type;
+ T : Time_Stamp_Type) return File_Name_Type
is
begin
Get_Name_String (N);
@@ -1680,6 +1694,28 @@
return Number_File_Names;
end Number_Of_Files;
+ -------------------------------
+ -- Object_Dir_Default_Prefix --
+ -------------------------------
+
+ function Object_Dir_Default_Prefix return String is
+ Object_Dir : String_Access :=
+ String_Access (Update_Path (Object_Dir_Default_Name));
+
+ begin
+ if Object_Dir = null then
+ return "";
+
+ else
+ declare
+ Result : constant String := Object_Dir.all;
+ begin
+ Free (Object_Dir);
+ return Result;
+ end;
+ end if;
+ end Object_Dir_Default_Prefix;
+
----------------------
-- Object_File_Name --
----------------------
@@ -1768,8 +1804,7 @@
function Read_Default_Search_Dirs
(Search_Dir_Prefix : String_Access;
Search_File : String_Access;
- Search_Dir_Default_Name : String_Access)
- return String_Access
+ Search_Dir_Default_Name : String_Access) return String_Access
is
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
@@ -1888,8 +1923,7 @@
function Read_Library_Info
(Lib_File : File_Name_Type;
- Fatal_Err : Boolean := False)
- return Text_Buffer_Ptr
+ Fatal_Err : Boolean := False) return Text_Buffer_Ptr
is
Lib_FD : File_Descriptor;
-- The file descriptor for the current library file. A negative value
@@ -2201,9 +2235,8 @@
----------------------
function Smart_File_Stamp
- (N : File_Name_Type;
- T : File_Type)
- return Time_Stamp_Type
+ (N : File_Name_Type;
+ T : File_Type) return Time_Stamp_Type
is
Time_Stamp : Time_Stamp_Type;
@@ -2228,8 +2261,7 @@
function Smart_Find_File
(N : File_Name_Type;
- T : File_Type)
- return File_Name_Type
+ T : File_Type) return File_Name_Type
is
Full_File_Name : File_Name_Type;
@@ -2320,13 +2352,11 @@
function To_Canonical_Dir_Spec
(Host_Dir : String;
- Prefix_Style : Boolean)
- return String_Access
+ Prefix_Style : Boolean) return String_Access
is
function To_Canonical_Dir_Spec
(Host_Dir : Address;
- Prefix_Flag : Integer)
- return Address;
+ Prefix_Flag : Integer) return Address;
pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
C_Host_Dir : String (1 .. Host_Dir'Length + 1);
@@ -2362,13 +2392,11 @@
function To_Canonical_File_List
(Wildcard_Host_File : String;
- Only_Dirs : Boolean)
- return String_Access_List_Access
+ Only_Dirs : Boolean) return String_Access_List_Access
is
function To_Canonical_File_List_Init
(Host_File : Address;
- Only_Dirs : Integer)
- return Integer;
+ Only_Dirs : Integer) return Integer;
pragma Import (C, To_Canonical_File_List_Init,
"__gnat_to_canonical_file_list_init");
@@ -2421,8 +2449,7 @@
----------------------------
function To_Canonical_File_Spec
- (Host_File : String)
- return String_Access
+ (Host_File : String) return String_Access
is
function To_Canonical_File_Spec (Host_File : Address) return Address;
pragma Import
@@ -2457,8 +2484,7 @@
----------------------------
function To_Canonical_Path_Spec
- (Host_Path : String)
- return String_Access
+ (Host_Path : String) return String_Access
is
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
pragma Import
@@ -2492,13 +2518,11 @@
function To_Host_Dir_Spec
(Canonical_Dir : String;
- Prefix_Style : Boolean)
- return String_Access
+ Prefix_Style : Boolean) return String_Access
is
function To_Host_Dir_Spec
(Canonical_Dir : Address;
- Prefix_Flag : Integer)
- return Address;
+ Prefix_Flag : Integer) return Address;
pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
@@ -2528,8 +2552,7 @@
----------------------------
function To_Host_File_Spec
- (Canonical_File : String)
- return String_Access
+ (Canonical_File : String) return String_Access
is
function To_Host_File_Spec (Canonical_File : Address) return Address;
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
@@ -2559,8 +2582,7 @@
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access
+ Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
type Path_String_Access is access Path_String;
Index: osint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.ads,v
retrieving revision 1.9
diff -u -r1.9 osint.ads
--- osint.ads 10 Nov 2003 09:42:57 -0000 1.9
+++ osint.ads 13 Nov 2003 22:38:21 -0000
@@ -217,6 +217,14 @@
-- Search Dir Routines --
-------------------------
+ function Include_Dir_Default_Prefix return String;
+ -- Return the directory of the run-time library sources, as modified
+ -- by update_path.
+
+ function Object_Dir_Default_Prefix return String;
+ -- Return the directory of the run-time library ALI and object files, as
+ -- modified by update_path.
+
procedure Add_Default_Search_Dirs;
-- This routine adds the default search dirs indicated by the
-- environment variables and sdefault package.
Index: par-ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch4.adb,v
retrieving revision 1.6
diff -u -r1.6 par-ch4.adb
--- par-ch4.adb 21 Oct 2003 13:42:10 -0000 1.6
+++ par-ch4.adb 13 Nov 2003 22:38:21 -0000
@@ -28,6 +28,8 @@
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
+with Hostparm; use Hostparm;
+
separate (Par)
package body Ch4 is
@@ -1116,6 +1118,7 @@
-- POSITIONAL_ARRAY_AGGREGATE ::=
-- (EXPRESSION, EXPRESSION {, EXPRESSION})
-- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
+ -- | (EXPRESSION {, EXPRESSION}, others => <>)
-- NAMED_ARRAY_AGGREGATE ::=
-- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
@@ -1354,6 +1357,7 @@
-- RECORD_COMPONENT_ASSOCIATION ::=
-- [COMPONENT_CHOICE_LIST =>] EXPRESSION
+ -- | COMPONENT_CHOICE_LIST => <>
-- COMPONENT_CHOICE_LIST =>
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
@@ -1361,6 +1365,7 @@
-- ARRAY_COMPONENT_ASSOCIATION ::=
-- DISCRETE_CHOICE_LIST => EXPRESSION
+ -- | DISCRETE_CHOICE_LIST => <>
-- Note: this routine only handles the named cases, including others.
-- Cases where the component choice list is not present have already
@@ -1376,7 +1381,27 @@
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
Set_Sloc (Assoc_Node, Token_Ptr);
TF_Arrow;
- Set_Expression (Assoc_Node, P_Expression);
+
+ if Token = Tok_Box then
+ if not Extensions_Allowed then
+ Error_Msg_SP
+ ("Limited aggregates are an Ada0X 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_Box_Present (Assoc_Node);
+ Scan; -- Past box
+ else
+ Set_Expression (Assoc_Node, P_Expression);
+ end if;
return Assoc_Node;
end P_Record_Or_Array_Component_Association;
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.8
diff -u -r1.8 sem_aggr.adb
--- sem_aggr.adb 21 Oct 2003 13:42:18 -0000 1.8
+++ sem_aggr.adb 13 Nov 2003 22:38:21 -0000
@@ -866,7 +866,9 @@
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
- elsif Is_Limited_Type (Typ) then
+ elsif Is_Limited_Type (Typ)
+ and not Extensions_Allowed
+ then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
@@ -1913,7 +1915,9 @@
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
- elsif Is_Limited_Type (Typ) then
+ elsif Is_Limited_Type (Typ)
+ and not Extensions_Allowed
+ then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
@@ -2017,7 +2021,19 @@
--
-- This variable is updated as a side effect of function Get_Value
- procedure Add_Association (Component : Entity_Id; Expr : Node_Id);
+ Mbox_Present : Boolean := False;
+ Others_Mbox : Boolean := False;
+ -- Variables used in case of default initialization to provide a
+ -- functionality similar to Others_Etype. Mbox_Present indicates
+ -- that the component takes its default initialization; Others_Mbox
+ -- indicates that at least one component takes its default initiali-
+ -- zation. Similar to Others_Etype, they are also updated as a side
+ -- effect of function Get_Value.
+
+ procedure Add_Association
+ (Component : Entity_Id;
+ Expr : Node_Id;
+ Box_Present : Boolean := False);
-- Builds a new N_Component_Association node which associates
-- Component to expression Expr and adds it to the new association
-- list New_Assoc_List being built.
@@ -2064,7 +2080,11 @@
-- Add_Association --
---------------------
- procedure Add_Association (Component : Entity_Id; Expr : Node_Id) is
+ procedure Add_Association
+ (Component : Entity_Id;
+ Expr : Node_Id;
+ Box_Present : Boolean := False)
+ is
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
@@ -2072,8 +2092,9 @@
Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
New_Assoc :=
Make_Component_Association (Sloc (Expr),
- Choices => Choice_List,
- Expression => Expr);
+ Choices => Choice_List,
+ Expression => Expr,
+ Box_Present => Box_Present);
Append (New_Assoc, New_Assoc_List);
end Add_Association;
@@ -2174,7 +2195,37 @@
Expr : Node_Id := Empty;
Selector_Name : Node_Id;
+ procedure Check_Non_Limited_Type;
+ -- Relax check to allow the default initialization of limited types.
+ -- For example:
+ -- record
+ -- C : Lim := (..., others => <>);
+ -- end record;
+
+ procedure Check_Non_Limited_Type is
+ begin
+ if Is_Limited_Type (Etype (Compon))
+ and then Comes_From_Source (Compon)
+ and then not In_Instance_Body
+ then
+
+ if Extensions_Allowed
+ and then Present (Expression (Assoc))
+ and then Nkind (Expression (Assoc)) = N_Aggregate
+ then
+ null;
+ else
+ Error_Msg_N
+ ("initialization not allowed for limited types", N);
+ Explain_Limited_Type (Etype (Compon), Compon);
+ end if;
+
+ end if;
+ end Check_Non_Limited_Type;
+
begin
+ Mbox_Present := False;
+
if Present (From) then
Assoc := First (From);
else
@@ -2186,14 +2237,6 @@
while Present (Selector_Name) loop
if Nkind (Selector_Name) = N_Others_Choice then
if Consider_Others_Choice and then No (Expr) then
- if Present (Others_Etype) and then
- Base_Type (Others_Etype) /= Base_Type (Etype (Compon))
- then
- Error_Msg_N ("components in OTHERS choice must " &
- "have same type", Selector_Name);
- end if;
-
- Others_Etype := Etype (Compon);
-- We need to duplicate the expression for each
-- successive component covered by the others choice.
@@ -2202,10 +2245,34 @@
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
- if Expander_Active then
- return New_Copy_Tree (Expression (Assoc));
+ if Box_Present (Assoc) then
+ Others_Mbox := True;
+ Mbox_Present := True;
+
+ if Expander_Active then
+ return New_Copy_Tree (Expression (Parent (Compon)));
+ else
+ return Expression (Parent (Compon));
+ end if;
else
- return Expression (Assoc);
+
+ Check_Non_Limited_Type;
+
+ if Present (Others_Etype) and then
+ Base_Type (Others_Etype) /= Base_Type (Etype
+ (Compon))
+ then
+ Error_Msg_N ("components in OTHERS choice must " &
+ "have same type", Selector_Name);
+ end if;
+
+ Others_Etype := Etype (Compon);
+
+ if Expander_Active then
+ return New_Copy_Tree (Expression (Assoc));
+ else
+ return Expression (Assoc);
+ end if;
end if;
end if;
@@ -2216,10 +2283,27 @@
-- components are grouped together with a "|" choice.
-- For instance "filed1 | filed2 => Expr"
- if Present (Next (Selector_Name)) then
- Expr := New_Copy_Tree (Expression (Assoc));
+ if Box_Present (Assoc) then
+ Mbox_Present := True;
+
+ -- Duplicate the default expression of the component
+ -- from the record type declaration
+
+ if Present (Next (Selector_Name)) then
+ Expr := New_Copy_Tree
+ (Expression (Parent (Compon)));
+ else
+ Expr := Expression (Parent (Compon));
+ end if;
else
- Expr := Expression (Assoc);
+
+ Check_Non_Limited_Type;
+
+ if Present (Next (Selector_Name)) then
+ Expr := New_Copy_Tree (Expression (Assoc));
+ else
+ Expr := Expression (Assoc);
+ end if;
end if;
Generate_Reference (Compon, Selector_Name);
@@ -2753,7 +2837,18 @@
Component := Node (Component_Elmt);
Expr := Get_Value (Component, Component_Associations (N), True);
- if No (Expr) then
+ if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
+
+ -- In case of default initialization of a limited component we
+ -- pass the limited component to the expander. The expander will
+ -- generate calls to the corresponding initialization subprograms.
+
+ Add_Association
+ (Component => Component,
+ Expr => Empty,
+ Box_Present => True);
+
+ elsif No (Expr) then
Error_Msg_NE ("no value supplied for component &!", N, Component);
else
Resolve_Aggr_Expr (Expr, Component);
@@ -2783,7 +2878,9 @@
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
- if No (Others_Etype) then
+ if No (Others_Etype)
+ and then not Others_Mbox
+ then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
end if;
@@ -2804,8 +2901,10 @@
-- component supplied by a previous expansion.
if No (New_Assoc) then
+ if Box_Present (Parent (Selectr)) then
+ null;
- if Chars (Selectr) /= Name_uTag
+ elsif Chars (Selectr) /= Name_uTag
and then Chars (Selectr) /= Name_uParent
and then Chars (Selectr) /= Name_uController
then
@@ -2827,8 +2926,13 @@
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
- Error_Msg_N
- ("components in choice list must have same type", Selectr);
+
+ if not Box_Present (Parent (Selectr)) then
+ Error_Msg_N
+ ("components in choice list must have same type",
+ Selectr);
+ end if;
+
end if;
Next (Selectr);
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.20
diff -u -r1.20 sem_ch3.adb
--- sem_ch3.adb 24 Oct 2003 13:02:42 -0000 1.20
+++ sem_ch3.adb 13 Nov 2003 22:38:22 -0000
@@ -6234,9 +6234,19 @@
or else Is_Limited_Composite (T))
and then not In_Instance
then
- Error_Msg_N
- ("cannot initialize entities of limited type", Exp);
- Explain_Limited_Type (T, Exp);
+ -- Relax the strictness of the front-end in case of limited
+ -- aggregates and extension aggregates.
+
+ if Extensions_Allowed
+ and then (Nkind (Exp) = N_Aggregate
+ or else Nkind (Exp) = N_Extension_Aggregate)
+ then
+ null;
+ else
+ Error_Msg_N
+ ("cannot initialize entities of limited type", Exp);
+ Explain_Limited_Type (T, Exp);
+ end if;
end if;
end Check_Initialization;
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.7
diff -u -r1.7 sem_ch4.adb
--- sem_ch4.adb 21 Oct 2003 13:42:19 -0000 1.7
+++ sem_ch4.adb 13 Nov 2003 22:38:22 -0000
@@ -338,7 +338,8 @@
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
- if Is_Limited_Type (Type_Id)
+ if Nkind (Expression (E)) /= N_Aggregate
+ and then Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
then
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.12
diff -u -r1.12 sem_ch8.adb
--- sem_ch8.adb 10 Nov 2003 17:29:59 -0000 1.12
+++ sem_ch8.adb 13 Nov 2003 22:38:22 -0000
@@ -4063,10 +4063,9 @@
if Is_Access_Type (P_Type)
and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
then
- Error_Msg_Node_2 := Selector_Name (N);
- Error_Msg_NE (
- "\incomplete type& has no visible component&", P,
- Designated_Type (P_Type));
+ Error_Msg_N
+ ("\dereference must not be of an incomplete type " &
+ "('R'M 3.10.1)", P);
end if;
else
Index: sem_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch9.adb,v
retrieving revision 1.6
diff -u -r1.6 sem_ch9.adb
--- sem_ch9.adb 21 Oct 2003 13:42:20 -0000 1.6
+++ sem_ch9.adb 13 Nov 2003 22:38:22 -0000
@@ -294,6 +294,7 @@
while Present (E1) loop
if Ekind (E1) = E_Procedure
+ and then Chars (E1) = Chars (Entry_Nam)
and then Type_Conformant (E1, Entry_Nam)
then
Error_Msg_N ("entry name is not visible", N);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.12
diff -u -r1.12 sem_res.adb
--- sem_res.adb 4 Nov 2003 12:51:46 -0000 1.12
+++ sem_res.adb 13 Nov 2003 22:38:22 -0000
@@ -1940,9 +1940,25 @@
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
- Error_Msg_Node_2 := Typ;
- Error_Msg_NE ("no visible interpretation of&" &
- " matches expected type&", N, Name (N));
+ declare
+ Subp_Name : Node_Id;
+ begin
+ if Is_Entity_Name (Name (N)) then
+ Subp_Name := Name (N);
+
+ elsif Nkind (Name (N)) = N_Selected_Component then
+
+ -- Protected operation: retrieve operation name.
+
+ Subp_Name := Selector_Name (Name (N));
+ else
+ raise Program_Error;
+ end if;
+
+ Error_Msg_Node_2 := Typ;
+ Error_Msg_NE ("no visible interpretation of&" &
+ " matches expected type&", N, Subp_Name);
+ end;
if All_Errors_Mode then
declare
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.9
diff -u -r1.9 sinfo.adb
--- sinfo.adb 10 Nov 2003 17:29:59 -0000 1.9
+++ sinfo.adb 13 Nov 2003 22:38:22 -0000
@@ -297,6 +297,7 @@
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
return Flag15 (N);
@@ -2729,6 +2730,7 @@
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
Set_Flag15 (N, Val);
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.13
diff -u -r1.13 sinfo.ads
--- sinfo.ads 10 Nov 2003 17:29:59 -0000 1.13
+++ sinfo.ads 13 Nov 2003 22:38:23 -0000
@@ -3008,6 +3008,7 @@
-- Choices (List1)
-- Loop_Actions (List2-Sem)
-- Expression (Node3)
+ -- Box_Present (Flag15)
-- Note: this structure is used for both record component associations
-- and array component associations, since the two cases aren't always
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.9
diff -u -r1.9 sprint.adb
--- sprint.adb 10 Nov 2003 17:30:00 -0000 1.9
+++ sprint.adb 13 Nov 2003 22:38:23 -0000
@@ -928,7 +928,11 @@
Set_Debug_Sloc;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
- Sprint_Node (Expression (Node));
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check ("<>");
+ else
+ Sprint_Node (Expression (Node));
+ end if;
when N_Component_Clause =>
Write_Indent;
Index: s-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.adb,v
retrieving revision 1.3
diff -u -r1.3 s-thread.adb
--- s-thread.adb 10 Nov 2003 17:30:00 -0000 1.3
+++ s-thread.adb 13 Nov 2003 22:38:23 -0000
@@ -31,13 +31,14 @@
-- --
------------------------------------------------------------------------------
--- This is the VxWorks/Cert version of this package
+-- This is the VxWorks version of this package
-with System.Init;
with System.Secondary_Stack;
with Unchecked_Conversion;
+with System.Threads.Initialization;
+
package body System.Threads is
package SSS renames System.Secondary_Stack;
@@ -48,6 +49,12 @@
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
+ procedure Init_Float;
+ pragma Import (C, Init_Float, "__gnat_init_float");
+
+ procedure Install_Handler;
+ pragma Import (C, Install_Handler, "__gnat_install_handler");
+
-----------------------
-- Get_Current_Excep --
-----------------------
@@ -122,8 +129,8 @@
SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
Current_ATSD := Process_ATSD_Address;
- System.Init.Install_Handler;
- System.Init.Init_Float;
+ Install_Handler;
+ Init_Float;
end Thread_Body_Enter;
----------------------------------
@@ -136,6 +143,7 @@
pragma Unreferenced (EO);
begin
-- No action for this target
+
null;
end Thread_Body_Exceptional_Exit;
@@ -146,7 +154,10 @@
procedure Thread_Body_Leave is
begin
-- No action for this target
+
null;
end Thread_Body_Leave;
+begin
+ System.Threads.Initialization.Init_RTS;
end System.Threads;
Index: vms_conv.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.ads,v
retrieving revision 1.1
diff -u -r1.1 vms_conv.ads
--- vms_conv.ads 21 Oct 2003 13:42:23 -0000 1.1
+++ vms_conv.ads 13 Nov 2003 22:38:23 -0000
@@ -25,7 +25,7 @@
------------------------------------------------------------------------------
-- This package is part of the GNAT driver. It contains a procedure
--- VMS_Conversion to convert the command line in VMS form to the wquivalent
+-- VMS_Conversion to convert the command line in VMS form to the equivalent
-- command line with switches for the GNAT tools that the GNAT driver will
-- invoke.
--
@@ -97,9 +97,9 @@
type Command_Type is
(Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Name, Preprocess, Pretty, Shared, Standard, Stub, Xref, Undefined);
+ Make, Name, Preprocess, Pretty, Shared, Stub, Xref, Undefined);
- type Alternate_Command is (Comp, Ls, Kr, Pp, Prep, Psta);
+ type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command libel for non VMS system
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
@@ -107,8 +107,7 @@
Ls => List,
Kr => Krunch,
Prep => Preprocess,
- Pp => Pretty,
- Psta => Standard);
+ Pp => Pretty);
-- Mapping of alternate commands to commands
subtype Real_Command_Type is Command_Type range Bind .. Xref;
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.1
diff -u -r1.1 vms_conv.adb
--- vms_conv.adb 21 Oct 2003 13:42:23 -0000 1.1
+++ vms_conv.adb 13 Nov 2003 22:38:23 -0000
@@ -25,8 +25,7 @@
------------------------------------------------------------------------------
with Hostparm;
-with Osint; use Osint;
-with Sdefault; use Sdefault;
+with Osint; use Osint;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
@@ -141,7 +140,7 @@
begin
Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (Object_Dir_Name);
loop
@@ -287,13 +286,13 @@
Make =>
(Cname => new S'("MAKE"),
- Usage => new S'("GNAT MAKE file /qualifiers (includes "
+ Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
& "COMPILE /qualifiers)"),
VMS_Only => False,
Unixcmd => new S'("gnatmake"),
Unixsws => null,
Switches => Make_Switches'Access,
- Params => new Parameter_Array'(1 => File),
+ Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
Name =>
@@ -340,16 +339,6 @@
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
- Standard =>
- (Cname => new S'("STANDARD"),
- Usage => new S'("GNAT STANDARD"),
- VMS_Only => False,
- Unixcmd => new S'("gnatpsta"),
- Unixsws => null,
- Switches => Standard_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
Stub =>
(Cname => new S'("STUB"),
Usage => new S'("GNAT STUB file [directory]/qualifiers"),
@@ -1092,231 +1081,270 @@
Arg_Idx := Argv'First;
<<Tryagain_After_Coalesce>>
- loop
- declare
- Next_Arg_Idx : Integer;
- Arg : String_Access;
-
- begin
- Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
+ loop
+ declare
+ Next_Arg_Idx : Integer;
+ Arg : String_Access;
- -- The first one must be a command name
+ begin
+ Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
- if Arg_Num = 1 and then Arg_Idx = Argv'First then
+ -- The first one must be a command name
- Command := Matching_Name (Arg.all, Commands);
+ if Arg_Num = 1 and then Arg_Idx = Argv'First then
- if Command = null then
- raise Error_Exit;
- end if;
+ Command := Matching_Name (Arg.all, Commands);
- The_Command := Command.Command;
+ if Command = null then
+ raise Error_Exit;
+ end if;
- -- Give usage information if only command given
+ The_Command := Command.Command;
- if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
- and then Command.Command /= VMS_Conv.Standard
- then
- Output_Version;
- New_Line;
- Put_Line
- ("List of available qualifiers and options");
- New_Line;
-
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
-
- declare
- Sw : Item_Ptr := Command.Switches;
-
- begin
- while Sw /= null loop
- Put (" ");
- Put (Sw.Name.all);
-
- case Sw.Translation is
-
- when T_Other =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all &
- "/<other>");
-
- when T_Direct =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all);
-
- when T_Directories =>
- Put ("=(direc,direc,..direc)");
- Set_Col (53);
- Put (Sw.Unix_String.all);
- Put (" direc ");
- Put (Sw.Unix_String.all);
- Put_Line (" direc ...");
+ -- Give usage information if only command given
- when T_Directory =>
- Put ("=directory");
- Set_Col (53);
- Put (Sw.Unix_String.all);
+ if Argument_Count = 1
+ and then Next_Arg_Idx = Argv'Last
+ then
+ Output_Version;
+ New_Line;
+ Put_Line
+ ("List of available qualifiers and options");
+ New_Line;
+
+ Put (Command.Usage.all);
+ Set_Col (53);
+ Put_Line (Command.Unix_String.all);
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ declare
+ Sw : Item_Ptr := Command.Switches;
- Put_Line ("directory ");
+ begin
+ while Sw /= null loop
+ Put (" ");
+ Put (Sw.Name.all);
- when T_File | T_No_Space_File =>
- Put ("=file");
- Set_Col (53);
- Put (Sw.Unix_String.all);
+ case Sw.Translation is
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ when T_Other =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all &
+ "/<other>");
- Put_Line ("file ");
+ when T_Direct =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all);
- when T_Numeric =>
- Put ("=nnn");
- Set_Col (53);
+ when T_Directories =>
+ Put ("=(direc,direc,..direc)");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+ Put (" direc ");
+ Put (Sw.Unix_String.all);
+ Put_Line (" direc ...");
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
+ when T_Directory =>
+ Put ("=directory");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
- Put_Line ("nnn");
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
- when T_Alphanumplus =>
- Put ("=xyz");
- Set_Col (53);
+ Put_Line ("directory ");
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
+ when T_File | T_No_Space_File =>
+ Put ("=file");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
- Put_Line ("xyz");
+ Put_Line ("file ");
- when T_String =>
- Put ("=");
- Put ('"');
- Put ("<string>");
- Put ('"');
- Set_Col (53);
+ when T_Numeric =>
+ Put ("=nnn");
+ Set_Col (53);
+ if Sw.Unix_String (Sw.Unix_String'First)
+ = '`'
+ then
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
Put (Sw.Unix_String.all);
+ end if;
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ Put_Line ("nnn");
- Put ("<string>");
- New_Line;
+ when T_Alphanumplus =>
+ Put ("=xyz");
+ Set_Col (53);
- when T_Commands =>
- Put (" (switches for ");
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 7
- .. Sw.Unix_String'Last));
- Put (')');
- Set_Col (53);
+ if Sw.Unix_String (Sw.Unix_String'First)
+ = '`'
+ then
Put (Sw.Unix_String
- (Sw.Unix_String'First
- .. Sw.Unix_String'First + 5));
- Put_Line (" switches");
-
- when T_Options =>
- declare
- Opt : Item_Ptr := Sw.Options;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
+ Put (Sw.Unix_String.all);
+ end if;
- end case;
+ Put_Line ("xyz");
- Sw := Sw.Next;
- end loop;
- end;
+ when T_String =>
+ Put ("=");
+ Put ('"');
+ Put ("<string>");
+ Put ('"');
+ Set_Col (53);
- raise Normal_Exit;
- end if;
+ Put (Sw.Unix_String.all);
+
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put ("<string>");
+ New_Line;
+
+ when T_Commands =>
+ Put (" (switches for ");
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 7
+ .. Sw.Unix_String'Last));
+ Put (')');
+ Set_Col (53);
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First
+ .. Sw.Unix_String'First + 5));
+ Put_Line (" switches");
+
+ when T_Options =>
+ declare
+ Opt : Item_Ptr := Sw.Options;
+
+ begin
+ Put_Line ("=(option,option..)");
+
+ while Opt /= null loop
+ Put (" ");
+ Put (Opt.Name.all);
+
+ if Opt = Sw.Options then
+ Put (" (D)");
+ end if;
+
+ Set_Col (53);
+ Put_Line (Opt.Unix_String.all);
+ Opt := Opt.Next;
+ end loop;
+ end;
+
+ end case;
+
+ Sw := Sw.Next;
+ end loop;
+ end;
+
+ raise Normal_Exit;
+ end if;
-- Special handling for internal debugging switch /?
- elsif Arg.all = "/?" then
- Display_Command := True;
+ elsif Arg.all = "/?" then
+ Display_Command := True;
-- Copy -switch unchanged
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
+ elsif Arg (Arg'First) = '-' then
+ Place (' ');
+ Place (Arg.all);
-- Copy quoted switch with quotes stripped
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ elsif Arg (Arg'First) = '"' then
+ if Arg (Arg'Last) /= '"' then
+ Put (Standard_Error, "misquoted argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- else
- Place (' ');
- Place (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
+ else
+ Place (' ');
+ Place (Arg (Arg'First + 1 .. Arg'Last - 1));
+ end if;
-- Parameter Argument
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
+ elsif Arg (Arg'First) /= '/'
+ and then Make_Commands_Active = null
+ then
+ Param_Count := Param_Count + 1;
+
+ if Param_Count <= Command.Params'Length then
+
+ case Command.Params (Param_Count) is
+
+ when File | Optional_File =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
- if Param_Count <= Command.Params'Length then
+ begin
+ Place (' ');
+ Place_Lower (Normal_File.all);
- case Command.Params (Param_Count) is
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+ end;
+
+ when Unlimited_Files =>
+ declare
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg.all);
+
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
+
+ begin
+ for J in Arg'Range loop
+ if Arg (J) = '*'
+ or else Arg (J) = '%'
+ then
+ File_Is_Wild := True;
+ end if;
+ end loop;
- when File | Optional_File =>
- declare
- Normal_File : constant String_Access :=
- To_Canonical_File_Spec
- (Arg.all);
+ if File_Is_Wild then
+ File_List := To_Canonical_File_List
+ (Arg.all, False);
- begin
+ for J in File_List.all'Range loop
+ Place (' ');
+ Place_Lower (File_List.all (J).all);
+ end loop;
+
+ else
Place (' ');
Place_Lower (Normal_File.all);
@@ -1326,36 +1354,92 @@
Place ('.');
Place (Command.Defext);
end if;
- end;
+ end if;
- when Unlimited_Files =>
- declare
- Normal_File :
- constant String_Access :=
- To_Canonical_File_Spec (Arg.all);
+ Param_Count := Param_Count - 1;
+ end;
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
+ when Other_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+
+ when Unlimited_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+ Param_Count := Param_Count - 1;
+
+ when Files_Or_Wildcard =>
+
+ -- Remove spaces from a comma separated list
+ -- of file names and adjust control variables
+ -- accordingly.
+
+ while Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
+ loop
+ Argv := new String'
+ (Argv.all & Argument (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx :=
+ Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ end loop;
+
+ -- Parse the comma separated list of VMS
+ -- filenames and place them on the command
+ -- line as space separated Unix style
+ -- filenames. Lower case and add default
+ -- extension as appropriate.
+
+ declare
+ Arg1_Idx : Integer := Arg'First;
+
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer;
+ -- Begins looking at Arg_Idx + 1 and
+ -- returns the index of the last character
+ -- before a comma or else the index of the
+ -- last character in the string Arg.
+
+ ------------------
+ -- Get_Arg1_End --
+ ------------------
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer
+ is
begin
- for J in Arg'Range loop
- if Arg (J) = '*'
- or else Arg (J) = '%'
- then
- File_Is_Wild := True;
+ for J in Arg_Idx + 1 .. Arg'Last loop
+ if Arg (J) = ',' then
+ return J - 1;
end if;
end loop;
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for J in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (J).all);
- end loop;
+ return Arg'Last;
+ end Get_Arg1_End;
- else
+ begin
+ loop
+ declare
+ Next_Arg1_Idx :
+ constant Integer :=
+ Get_Arg1_End (Arg.all, Arg1_Idx);
+
+ Arg1 :
+ constant String :=
+ Arg (Arg1_Idx .. Next_Arg1_Idx);
+
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg1);
+
+ begin
Place (' ');
Place_Lower (Normal_File.all);
@@ -1365,542 +1449,447 @@
Place ('.');
Place (Command.Defext);
end if;
- end if;
- Param_Count := Param_Count - 1;
- end;
+ Arg1_Idx := Next_Arg1_Idx + 1;
+ end;
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
-
- when Unlimited_As_Is =>
- Place (' ');
- Place (Arg.all);
- Param_Count := Param_Count - 1;
+ exit when Arg1_Idx > Arg'Last;
- when Files_Or_Wildcard =>
-
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
-
- while Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- loop
- Argv := new String'
- (Argv.all & Argument (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx :=
- Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- end loop;
-
- -- Parse the comma separated list of VMS
- -- filenames and place them on the command
- -- line as space separated Unix style
- -- filenames. Lower case and add default
- -- extension as appropriate.
-
- declare
- Arg1_Idx : Integer := Arg'First;
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and
- -- returns the index of the last character
- -- before a comma or else the index of the
- -- last character in the string Arg.
-
- ------------------
- -- Get_Arg1_End --
- ------------------
+ -- Don't allow two or more commas in
+ -- a row
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Arg'Last loop
- if Arg (J) = ',' then
- return J - 1;
- end if;
- end loop;
-
- return Arg'Last;
- end Get_Arg1_End;
-
- begin
- loop
- declare
- Next_Arg1_Idx :
- constant Integer :=
- Get_Arg1_End (Arg.all, Arg1_Idx);
-
- Arg1 :
- constant String :=
- Arg (Arg1_Idx .. Next_Arg1_Idx);
-
- Normal_File :
- constant String_Access :=
- To_Canonical_File_Spec (Arg1);
-
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
-
- Arg1_Idx := Next_Arg1_Idx + 1;
- end;
-
- exit when Arg1_Idx > Arg'Last;
-
- -- Don't allow two or more commas in
- -- a row
-
- if Arg (Arg1_Idx) = ',' then
- Arg1_Idx := Arg1_Idx + 1;
- if Arg1_Idx > Arg'Last or else
- Arg (Arg1_Idx) = ','
- then
- Put_Line
- (Standard_Error,
- "Malformed Parameter: " &
- Arg.all);
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error,
- Command.Usage.all);
- raise Error_Exit;
- end if;
+ if Arg (Arg1_Idx) = ',' then
+ Arg1_Idx := Arg1_Idx + 1;
+ if Arg1_Idx > Arg'Last or else
+ Arg (Arg1_Idx) = ','
+ then
+ Put_Line
+ (Standard_Error,
+ "Malformed Parameter: " &
+ Arg.all);
+ Put (Standard_Error, "usage: ");
+ Put_Line (Standard_Error,
+ Command.Usage.all);
+ raise Error_Exit;
end if;
+ end if;
- end loop;
- end;
- end case;
- end if;
-
- -- Qualifier argument
-
- else
- -- This code is too heavily nested, should be
- -- separated out as separate subprogram ???
+ end loop;
+ end;
+ end case;
+ end if;
- declare
- Sw : Item_Ptr;
- SwP : Natural;
- P2 : Natural;
- Endp : Natural := 0; -- avoid warning!
- Opt : Item_Ptr;
+ -- Qualifier argument
- begin
- SwP := Arg'First;
- while SwP < Arg'Last
- and then Arg (SwP + 1) /= '='
- loop
- SwP := SwP + 1;
- end loop;
+ else
+ -- This code is too heavily nested, should be
+ -- separated out as separate subprogram ???
- -- At this point, the switch name is in
- -- Arg (Arg'First..SwP) and if that is not the
- -- whole switch, then there is an equal sign at
- -- Arg (SwP + 1) and the rest of Arg is what comes
- -- after the equal sign.
-
- -- If make commands are active, see if we have
- -- another COMMANDS_TRANSLATION switch belonging
- -- to gnatmake.
+ declare
+ Sw : Item_Ptr;
+ SwP : Natural;
+ P2 : Natural;
+ Endp : Natural := 0; -- avoid warning!
+ Opt : Item_Ptr;
+
+ begin
+ SwP := Arg'First;
+ while SwP < Arg'Last
+ and then Arg (SwP + 1) /= '='
+ loop
+ SwP := SwP + 1;
+ end loop;
+
+ -- At this point, the switch name is in
+ -- Arg (Arg'First..SwP) and if that is not the
+ -- whole switch, then there is an equal sign at
+ -- Arg (SwP + 1) and the rest of Arg is what comes
+ -- after the equal sign.
+
+ -- If make commands are active, see if we have
+ -- another COMMANDS_TRANSLATION switch belonging
+ -- to gnatmake.
+
+ if Make_Commands_Active /= null then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw /= null
+ and then Sw.Translation = T_Commands
+ then
+ null;
- if Make_Commands_Active /= null then
+ else
Sw :=
Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw /= null
- and then Sw.Translation = T_Commands
- then
- null;
-
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Make_Commands_Active.Switches,
- Quiet => False);
- end if;
+ (Arg (Arg'First .. SwP),
+ Make_Commands_Active.Switches,
+ Quiet => False);
+ end if;
-- For case of GNAT MAKE or CHOP, if we cannot
-- find the switch, then see if it is a
-- recognized compiler switch instead, and if
-- so process the compiler switch.
- elsif Command.Name.all = "MAKE"
- or else Command.Name.all = "CHOP" then
+ elsif Command.Name.all = "MAKE"
+ or else Command.Name.all = "CHOP" then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw = null then
Sw :=
Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw = null then
- Sw :=
+ (Arg (Arg'First .. SwP),
Matching_Name
- (Arg (Arg'First .. SwP),
- Matching_Name
- ("COMPILE", Commands).Switches,
- Quiet => False);
- end if;
+ ("COMPILE", Commands).Switches,
+ Quiet => False);
+ end if;
-- For all other cases, just search the relevant
-- command.
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => False);
- end if;
+ else
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => False);
+ end if;
- if Sw /= null then
- case Sw.Translation is
+ if Sw /= null then
+ case Sw.Translation is
- when T_Direct =>
- Place_Unix_Switches (Sw.Unix_String);
- if SwP < Arg'Last
- and then Arg (SwP + 1) = '='
+ when T_Direct =>
+ Place_Unix_Switches (Sw.Unix_String);
+ if SwP < Arg'Last
+ and then Arg (SwP + 1) = '='
+ then
+ Put (Standard_Error,
+ "qualifier options ignored: ");
+ Put_Line (Standard_Error, Arg.all);
+ end if;
+
+ when T_Directories =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directories for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+
+ -- Remove spaces from a comma separated
+ -- list of file names and adjust
+ -- control variables accordingly.
+
+ if Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
then
- Put (Standard_Error,
- "qualifier options ignored: ");
- Put_Line (Standard_Error, Arg.all);
+ Argv :=
+ new String'(Argv.all
+ & Argument
+ (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx
+ := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ goto Tryagain_After_Coalesce;
end if;
- when T_Directories =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directories for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
-
- -- Remove spaces from a comma separated
- -- list of file names and adjust
- -- control variables accordingly.
-
- if Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- then
- Argv :=
- new String'(Argv.all
- & Argument
- (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx
- := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- goto Tryagain_After_Coalesce;
- end if;
+ Put (Standard_Error,
+ "incorrectly parenthesized " &
+ "or malformed argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
+
+ while SwP <= Endp loop
+ declare
+ Dir_Is_Wild : Boolean := False;
+ Dir_Maybe_Is_Wild : Boolean := False;
+ Dir_List : String_Access_List_Access;
+ begin
+ P2 := SwP;
- Put (Standard_Error,
- "incorrectly parenthesized " &
- "or malformed argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
+ -- A wildcard directory spec on
+ -- VMS will contain either * or
+ -- % or ...
+
+ if Arg (P2) = '*' then
+ Dir_Is_Wild := True;
+
+ elsif Arg (P2) = '%' then
+ Dir_Is_Wild := True;
+
+ elsif Dir_Maybe_Is_Wild
+ and then Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Is_Wild := True;
+ Dir_Maybe_Is_Wild := False;
- while SwP <= Endp loop
- declare
- Dir_Is_Wild : Boolean := False;
- Dir_Maybe_Is_Wild : Boolean := False;
- Dir_List : String_Access_List_Access;
- begin
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
-
- -- A wildcard directory spec on
- -- VMS will contain either * or
- -- % or ...
-
- if Arg (P2) = '*' then
- Dir_Is_Wild := True;
-
- elsif Arg (P2) = '%' then
- Dir_Is_Wild := True;
-
- elsif Dir_Maybe_Is_Wild
- and then Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Is_Wild := True;
- Dir_Maybe_Is_Wild := False;
-
- elsif Dir_Maybe_Is_Wild then
- Dir_Maybe_Is_Wild := False;
-
- elsif Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Maybe_Is_Wild := True;
+ elsif Dir_Maybe_Is_Wild then
+ Dir_Maybe_Is_Wild := False;
- end if;
+ elsif Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Maybe_Is_Wild := True;
- P2 := P2 + 1;
- end loop;
+ end if;
- if Dir_Is_Wild then
- Dir_List := To_Canonical_File_List
- (Arg (SwP .. P2), True);
-
- for J in Dir_List.all'Range loop
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (Dir_List.all (J).all);
- end loop;
+ P2 := P2 + 1;
+ end loop;
- else
+ if Dir_Is_Wild then
+ Dir_List := To_Canonical_File_List
+ (Arg (SwP .. P2), True);
+
+ for J in Dir_List.all'Range loop
Place_Unix_Switches
(Sw.Unix_String);
Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP .. P2), False).all);
- end if;
-
- SwP := P2 + 2;
- end;
- end loop;
-
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space
- -- here
+ (Dir_List.all (J).all);
+ end loop;
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
+ else
+ Place_Unix_Switches
+ (Sw.Unix_String);
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP .. P2), False).all);
end if;
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last),
- False).all);
- end if;
-
- when T_File | T_No_Space_File =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing file for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
+ SwP := P2 + 2;
+ end;
+ end loop;
- -- Some switches end in "=". No space
- -- here.
+ when T_Directory =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directory for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
+ else
+ Place_Unix_Switches (Sw.Unix_String);
- Place_Lower
- (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
+ -- Some switches end in "=". No space
+ -- here
- when T_Numeric =>
- if
- OK_Integer (Arg (SwP + 2 .. Arg'Last))
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line
- (Standard_Error, " must be numeric");
- Errors := Errors + 1;
+ Place (' ');
end if;
- when T_Alphanumplus =>
- if
- OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP + 2 .. Arg'Last),
+ False).all);
+ end if;
+
+ when T_File | T_No_Space_File =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing file for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
+ else
+ Place_Unix_Switches (Sw.Unix_String);
- when T_String =>
+ -- Some switches end in "=". No space
+ -- here.
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
- --
- -- The begining and ending of the string
- -- are flagged with embedded nulls which
- -- are removed when building the Spawn
- -- call. Nulls are use because they won't
- -- show up in a /? output. Quotes aren't
- -- used because that would make it
- -- difficult to embed them.
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
+ Place_Lower
+ (To_Canonical_File_Spec
+ (Arg (SwP + 2 .. Arg'Last)).all);
+ end if;
+
+ when T_Numeric =>
+ if
+ OK_Integer (Arg (SwP + 2 .. Arg'Last))
+ then
Place_Unix_Switches (Sw.Unix_String);
- if Next_Arg_Idx /= Argv'Last then
- Next_Arg_Idx := Argv'Last;
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
-
- SwP := Arg'First;
- while SwP < Arg'Last and then
- Arg (SwP + 1) /= '=' loop
- SwP := SwP + 1;
- end loop;
- end if;
- Place (ASCII.NUL);
Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
- when T_Commands =>
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line
+ (Standard_Error, " must be numeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_Alphanumplus =>
+ if
+ OK_Alphanumerplus
+ (Arg (SwP + 2 .. Arg'Last))
+ then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
- -- Output -largs/-bargs/-cargs
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line (Standard_Error,
+ " must be alphanumeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_String =>
+
+ -- A String value must be extended to the
+ -- end of the Argv, otherwise strings like
+ -- "foo/bar" get split at the slash.
+ --
+ -- The begining and ending of the string
+ -- are flagged with embedded nulls which
+ -- are removed when building the Spawn
+ -- call. Nulls are use because they won't
+ -- show up in a /? output. Quotes aren't
+ -- used because that would make it
+ -- difficult to embed them.
+
+ Place_Unix_Switches (Sw.Unix_String);
+ if Next_Arg_Idx /= Argv'Last then
+ Next_Arg_Idx := Argv'Last;
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
+ SwP := Arg'First;
+ while SwP < Arg'Last and then
+ Arg (SwP + 1) /= '=' loop
+ SwP := SwP + 1;
+ end loop;
+ end if;
+ Place (ASCII.NUL);
+ Place (Arg (SwP + 2 .. Arg'Last));
+ Place (ASCII.NUL);
- if Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last) =
- "MAKE"
- then
- Make_Commands_Active := null;
+ when T_Commands =>
- else
- -- Set source of new commands, also
- -- setting this non-null indicates that
- -- we are in the special commands mode
- -- for processing the -xargs case.
-
- Make_Commands_Active :=
- Matching_Name
- (Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last),
- Commands);
- end if;
+ -- Output -largs/-bargs/-cargs
- when T_Options =>
- if SwP + 1 > Arg'Last then
- Place_Unix_Switches
- (Sw.Options.Unix_String);
- SwP := Endp + 1;
+ Place (' ');
+ Place (Sw.Unix_String
+ (Sw.Unix_String'First ..
+ Sw.Unix_String'First + 5));
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last) =
+ "MAKE"
+ then
+ Make_Commands_Active := null;
+
+ else
+ -- Set source of new commands, also
+ -- setting this non-null indicates that
+ -- we are in the special commands mode
+ -- for processing the -xargs case.
+
+ Make_Commands_Active :=
+ Matching_Name
+ (Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last),
+ Commands);
+ end if;
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
- Put
- (Standard_Error,
- "incorrectly parenthesized " &
- "argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
- SwP := Endp + 1;
+ when T_Options =>
+ if SwP + 1 > Arg'Last then
+ Place_Unix_Switches
+ (Sw.Options.Unix_String);
+ SwP := Endp + 1;
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+ Put
+ (Standard_Error,
+ "incorrectly parenthesized " &
+ "argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+ SwP := Endp + 1;
+
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
- while SwP <= Endp loop
- P2 := SwP;
+ while SwP <= Endp loop
+ P2 := SwP;
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
+ P2 := P2 + 1;
+ end loop;
- -- Option name is in Arg (SwP .. P2)
+ -- Option name is in Arg (SwP .. P2)
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
+ Opt := Matching_Name (Arg (SwP .. P2),
+ Sw.Options);
- if Opt /= null then
- Place_Unix_Switches
- (Opt.Unix_String);
- end if;
+ if Opt /= null then
+ Place_Unix_Switches
+ (Opt.Unix_String);
+ end if;
- SwP := P2 + 2;
- end loop;
+ SwP := P2 + 2;
+ end loop;
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all &
- Arg.all));
+ when T_Other =>
+ Place_Unix_Switches
+ (new String'(Sw.Unix_String.all &
+ Arg.all));
- end case;
- end if;
- end;
- end if;
+ end case;
+ end if;
+ end;
+ end if;
- Arg_Idx := Next_Arg_Idx + 1;
- end;
+ Arg_Idx := Next_Arg_Idx + 1;
+ end;
- exit when Arg_Idx > Argv'Last;
+ exit when Arg_Idx > Argv'Last;
- end loop;
+ end loop;
end Process_Argument;
Arg_Num := Arg_Num + 1;
Index: vms_data.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_data.ads,v
retrieving revision 1.2
diff -u -r1.2 vms_data.ads
--- vms_data.ads 10 Nov 2003 17:30:00 -0000 1.2
+++ vms_data.ads 13 Nov 2003 22:38:23 -0000
@@ -1591,6 +1591,17 @@
-- communicated to the compiler through logical names
-- ADA_PRJ_INCLUDE_FILE and ADA_PRJ_OBJECTS_FILE.
+ S_GCC_Psta : aliased constant S := "/PRINT_STANDARD " &
+ "-gnatS";
+ -- /PRINT_STANDARD
+ --
+ -- cause the compiler to output a representation of package Standard
+ -- in a form very close to standard Ada. It is not quite possible to
+ -- do this and remain entirely Standard (since new numeric base types
+ -- cannot be created in standard Ada), but the output is easily
+ -- readable to any Ada programmer, and is useful to determine the
+ -- characteristics of target dependent types in package Standard.
+
S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
"VERBOSE " &
"-gnatv " &
@@ -2278,10 +2289,6 @@
"-gnatwA " &
"ALL_GCC " &
"-Wall " &
- "BIASED_ROUNDING " &
- "-gnatwb " &
- "NOBIASED_ROUNDING " &
- "-gnatwB " &
"CONDITIONALS " &
"-gnatwc " &
"NOCONDITIONALS " &
@@ -2399,30 +2406,6 @@
-- backend. Most of these are not relevant
-- to Ada.
--
- -- BIASED_ROUNDING Activate warnings on biased rounding.
- -- If a static floating-point expression has
- -- a value that is exactly half way between
- -- two adjacent machine numbers, then the
- -- rules of Ada (Ada Reference Manual,
- -- para 4.9(38)) require that this rounding
- -- be done away from zero, even if the normal
- -- unbiased rounding rules at run time would
- -- require rounding towards zero.
- --
- -- This warning message alerts you to such
- -- instances where compile-time rounding and
- -- run-time rounding are not equivalent.
- -- If it is important to get proper run-time
- -- rounding, then you can force this by
- -- making one of the operands into a
- -- variable. The default is that such
- -- warnings are not generated. Note that
- -- /WARNINGS=ALL does not affect the setting
- -- of this warning option.
- --
- -- NOBIASED_ROUNDING Suppress warnings on biased rounding.
- -- Disable warnings on biased rounding.
- --
-- CONDITIONALS Activate warnings for conditional
-- Expressions used in tests that are known
-- to be True or False at compile time. The
@@ -2820,6 +2803,7 @@
S_GCC_OptX 'Access,
S_GCC_Polling 'Access,
S_GCC_Project 'Access,
+ S_GCC_Psta 'Access,
S_GCC_Report 'Access,
S_GCC_ReportX 'Access,
S_GCC_Repinfo 'Access,
@@ -4642,12 +4626,6 @@
S_Shared_Noinhib 'Access,
S_Shared_Verb 'Access,
S_Shared_ZZZZZ 'Access);
-
- --------------------------------
- -- Switches for GNAT STANDARD --
- --------------------------------
-
- Standard_Switches : aliased constant Switches := (1 .. 0 => null);
----------------------------
-- Switches for GNAT STUB --
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: Ada updates
@ 2003-11-04 12:59 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-11-04 12:59 UTC (permalink / raw)
To: gcc-patches
This patch introduces a temporary work around for the Ada bootstrap
failures.
Other fixes and improvements also included.
Tested on x86-linux
--
2003-11-04 Doug Rupp <rupp@gnat.com>
* sysdep.c: Problem discovered during IA64 VMS port.
[VMS] #include <unixio.h> to get proper prototypes.
* adaint.c:
Issues discovered/problems fixed during IA64 VMS port.
[VMS] #define _POSIX_EXIT for proper semantics.
[VMS] #include <unixio.h> for proper prototypes.
[VMS] (fork): #define IA64 version.
(__gnat_os_exit): Remove unnecessary VMS specific code.
2003-11-04 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
Part of PR ada/12806
* ada-tree.h (TYPE_DIGITS_VALUE, SET_TYPE_DIGITS_VALUE): Save count as
tree, not integer.
* decl.c:
(gnat_to_gnu_entity, case E_Floating_Point_Type): Save count as tree,
not integer.
* targtyps.c, decl.c, misc.c,
gigi.h (fp_prec_to_size, fp_size_to_prec): Temporary
routines to work around change in FP sizing semantics in GCC.
* utils.c:
(build_vms_descriptor): TYPE_DIGITS_VALUE is tree, not integer.
* gigi.h: (enumerate_modes): New function.
* Make-lang.in: (ada/misc.o): Add real.h.
* misc.c: (enumerate_modes): New function.
2003-11-04 Robert Dewar <dewar@gnat.com>
* 3vtrasym.adb: Minor reformatting
Use terminology encoded/decoded name, rather than C++ specific notion
of mangling (this is the terminology used throughout GNAT).
* einfo.h: Regenerated
* einfo.ads, einfo.adb: Add new flag Is_Thread_Body
* exp_ch6.adb:
(Expand_N_Subprogram_Body): Handle expansion of thread body procedure
* par-prag.adb: Add dummy entry for Thread_Body pragma
* rtsfind.ads:
Add entries for System.Threads entities for thread body processing
* sem_attr.adb:
(Analyze_Pragma, Access attributes): Check these are not applied to a
thread body, since this is not permitted
* sem_prag.adb: Add processing for Thread_Body pragma.
Minor comment fix.
* sem_res.adb:
(Resolve_Call): Check for incorrect attempt to call a thread body
procedure with a direct call.
* snames.ads, snames.adb: Add entry for Thread_Body pragma
Add names associated with thread body expansion
* snames.h: Add entry for Thread_Body pragma
* s-thread.adb: Add entries for thread body processing
These are dummy bodies so far
* s-thread.ads: Add documentation on thread body handling.
Add entries for thread body processing.
2003-11-04 Javier Miranda <miranda@gnat.com>
* sem_ch10.adb:
(Build_Limited_Views): Return after posting an error in case of limited
with_clause on subprograms, generics, instances or generic renamings
(Install_Limited_Withed_Unit): Do nothing in case of limited with_clause
on subprograms, generics, instances or generic renamings
2003-11-04 Arnaud Charlet <charlet@act-europe.fr>
* raise.c (setup_to_install): Correct mistake in last revision; two
arguments out of order.
* trans.c, cuintp.c, argv.c, aux-io.c, cal.c, errno.c, exit.c,
gnatbl.c, init.c, stringt.h, utils.c, utils2.c: Update copyright
notice, missed in previous change.
Remove trailing blanks and other style errors introduced in previous
change.
2003-11-04 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_field): Adjust the conditions under which we get
rid of the wrapper for a LJM type, ensuring we don't do that if the
field is addressable. This avoids potential low level type view
mismatches later on, for instance in a by-reference argument passing
process.
2003-11-04 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_field): No longer check for BLKmode being
aligned at byte boundary.
2003-11-04 Joel Brobecker <brobecker@gnat.com>
* decl.c (components_to_record): Do not delete the empty variants from
the end of the union type.
2003-11-04 Ed Schonberg <schonberg@gnat.com>
* exp_ch4.adb (Expand_N_Op_Eq): Use base type when locating primitive
operation for a derived type, an explicit declaration may use a local
subtype of Boolean.
2003-11-04 Vincent Celier <celier@gnat.com>
* make.adb (Gnatmake): Allow main sources on the command line with a
library project when it is only for compilation (no binding or
linking).
--
Index: 3vtrasym.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vtrasym.adb,v
retrieving revision 1.3
diff -u -c -3 -p -r1.3 3vtrasym.adb
*** 3vtrasym.adb 30 Oct 2003 11:50:12 -0000 1.3
--- 3vtrasym.adb 4 Nov 2003 12:49:11 -0000
*************** package body GNAT.Traceback.Symbolic is
*** 97,172 ****
Value, Value),
User_Act_Proc);
! function Demangle_Ada (Mangled : String) return String;
! -- Demangles an Ada symbol. Removes leading "_ada_" and trailing
-- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
- ------------------
- -- Demangle_Ada --
- ------------------
-
- function Demangle_Ada (Mangled : String) return String is
- Demangled : String (1 .. Mangled'Length);
- Pos : Integer := Mangled'First;
- Last : Integer := Mangled'Last;
- DPos : Integer := 1;
begin
-
if Pos > Last then
return "";
end if;
-- Skip leading _ada_
! if Mangled'Length > 4 and then Mangled (Pos .. Pos + 4) = "_ada_" then
Pos := Pos + 5;
end if;
-- Skip trailing __{DIGIT}+ or ${DIGIT}+
! if Mangled (Last) in '0' .. '9' then
!
for J in reverse Pos + 2 .. Last - 1 loop
!
! case Mangled (J) is
when '0' .. '9' =>
null;
when '$' =>
Last := J - 1;
exit;
when '_' =>
! if Mangled (J - 1) = '_' then
Last := J - 2;
end if;
exit;
when others =>
exit;
end case;
-
end loop;
-
end if;
! -- Now just copy Mangled to Demangled, converting "__" to '.' on the fly
while Pos <= Last loop
!
! if Mangled (Pos) = '_' and then Mangled (Pos + 1) = '_'
! and then Pos /= Mangled'First then
! Demangled (DPos) := '.';
Pos := Pos + 2;
else
! Demangled (DPos) := Mangled (Pos);
Pos := Pos + 1;
end if;
DPos := DPos + 1;
-
end loop;
! return Demangled (1 .. DPos - 1);
! end Demangle_Ada;
------------------------
-- Symbolic_Traceback --
--- 97,169 ----
Value, Value),
User_Act_Proc);
! function Decode_Ada_Name (Encoded_Name : String) return String;
! -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing
-- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
+ ---------------------
+ -- Decode_Ada_Name --
+ ---------------------
+
+ function Decode_Ada_Name (Encoded_Name : String) return String is
+ Decoded_Name : String (1 .. Encoded_Name'Length);
+ Pos : Integer := Encoded_Name'First;
+ Last : Integer := Encoded_Name'Last;
+ DPos : Integer := 1;
begin
if Pos > Last then
return "";
end if;
-- Skip leading _ada_
! if Encoded_Name'Length > 4
! and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
! then
Pos := Pos + 5;
end if;
-- Skip trailing __{DIGIT}+ or ${DIGIT}+
! if Encoded_Name (Last) in '0' .. '9' then
for J in reverse Pos + 2 .. Last - 1 loop
! case Encoded_Name (J) is
when '0' .. '9' =>
null;
when '$' =>
Last := J - 1;
exit;
when '_' =>
! if Encoded_Name (J - 1) = '_' then
Last := J - 2;
end if;
exit;
when others =>
exit;
end case;
end loop;
end if;
! -- Now just copy encoded name to decoded name, converting "__" to '.'
while Pos <= Last loop
! if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
! and then Pos /= Encoded_Name'First
! then
! Decoded_Name (DPos) := '.';
Pos := Pos + 2;
+
else
! Decoded_Name (DPos) := Encoded_Name (Pos);
Pos := Pos + 1;
end if;
DPos := DPos + 1;
end loop;
! return Decoded_Name (1 .. DPos - 1);
! end Decode_Ada_Name;
------------------------
-- Symbolic_Traceback --
*************** package body GNAT.Traceback.Symbolic is
*** 225,231 ****
First : Integer := Len + 1;
Last : Integer := First + 80 - 1;
Pos : Integer;
! Routine_Name_D : String := Demangle_Ada
(To_Ada
(Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
False));
--- 222,228 ----
First : Integer := Len + 1;
Last : Integer := First + 80 - 1;
Pos : Integer;
! Routine_Name_D : String := Decode_Ada_Name
(To_Ada
(Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
False));
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.20
diff -u -c -3 -p -r1.20 adaint.c
*** adaint.c 31 Oct 2003 01:08:39 -0000 1.20
--- adaint.c 4 Nov 2003 12:49:12 -0000
***************
*** 50,55 ****
--- 50,59 ----
#endif /* VxWorks */
+ #ifdef VMS
+ #define _POSIX_EXIT 1
+ #endif
+
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
***************
*** 57,62 ****
--- 61,69 ----
#include <sys/stat.h>
#include <fcntl.h>
#include <time.h>
+ #ifdef VMS
+ #include <unixio.h>
+ #endif
/* We don't have libiberty, so use malloc. */
#define xmalloc(S) malloc (S)
*************** __gnat_is_symbolic_link (char *name ATTR
*** 1463,1470 ****
#ifdef VMS
/* Defined in VMS header files. */
#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
! LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
#endif
#if defined (sun) && defined (__SVR4)
--- 1470,1482 ----
#ifdef VMS
/* Defined in VMS header files. */
+ #if defined (__ALPHA)
#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
! LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
! #elif defined (__IA64)
! #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
! LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1)
! #endif
#endif
#if defined (sun) && defined (__SVR4)
*************** __gnat_waitpid (int pid)
*** 1816,1827 ****
void
__gnat_os_exit (int status)
{
- #ifdef VMS
- /* Exit without changing 0 to 1. */
- __posix_exit (status);
- #else
exit (status);
- #endif
}
/* Locate a regular file, give a Path value. */
--- 1828,1834 ----
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 ada-tree.h
*** ada-tree.h 29 Oct 2003 10:26:12 -0000 1.9
--- ada-tree.h 4 Nov 2003 12:49:12 -0000
*************** struct lang_type GTY(())
*** 174,187 ****
#define TYPE_INDEX_TYPE(NODE) \
(&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic)
#define SET_TYPE_INDEX_TYPE(NODE, X) \
! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(X))
/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the
Digits_Value. */
! #define TYPE_DIGITS_VALUE(NODE) \
! ((long) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)))
#define SET_TYPE_DIGITS_VALUE(NODE, X) \
! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(size_t)(X))
/* For INTEGER_TYPE, stores the RM_Size of the type. */
#define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE))
--- 174,187 ----
#define TYPE_INDEX_TYPE(NODE) \
(&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic)
#define SET_TYPE_INDEX_TYPE(NODE, X) \
! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *) (X))
/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the
Digits_Value. */
! #define TYPE_DIGITS_VALUE(NODE) \
! (&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic)
#define SET_TYPE_DIGITS_VALUE(NODE, X) \
! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *) (X))
/* For INTEGER_TYPE, stores the RM_Size of the type. */
#define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE))
*************** struct lang_type GTY(())
*** 271,280 ****
discriminant number. */
#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
! /* This is a horrible kludge to store the loop_id of a loop into a tree
! node. We need to find some other place to store it! */
#define TREE_LOOP_ID(NODE) \
! (((union lang_tree_node *)TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id)
/* Define fields and macros for statements.
--- 271,279 ----
discriminant number. */
#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
! /* This is the loop id for a GNAT_LOOP_ID node. */
#define TREE_LOOP_ID(NODE) \
! ((union lang_tree_node *) TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id
/* Define fields and macros for statements.
Index: argv.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/argv.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 argv.c
*** argv.c 31 Oct 2003 01:08:40 -0000 1.5
--- argv.c 4 Nov 2003 12:49:12 -0000
***************
*** 6,12 ****
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2002 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- *
--- 6,12 ----
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2003 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- *
*************** __gnat_len_arg (int arg_num)
*** 83,89 ****
}
void
! __gnat_fill_arg ( char *a, int i)
{
strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
}
--- 83,89 ----
}
void
! __gnat_fill_arg (char *a, int i)
{
strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
}
Index: aux-io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/aux-io.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 aux-io.c
*** aux-io.c 31 Oct 2003 01:08:40 -0000 1.5
--- aux-io.c 4 Nov 2003 12:49:12 -0000
***************
*** 6,12 ****
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2001 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- *
--- 6,12 ----
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2003 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- *
*************** void *null_function (void);
*** 52,71 ****
int c_fileno (FILE *);
FILE *
! c_stdin (void)
! {
! return stdin;
}
FILE *
! c_stdout (void)
! {
return stdout;
}
FILE *
! c_stderr (void)
! {
return stderr;
}
--- 52,71 ----
int c_fileno (FILE *);
FILE *
! c_stdin (void)
! {
! return stdin;
}
FILE *
! c_stdout (void)
! {
return stdout;
}
FILE *
! c_stderr (void)
! {
return stderr;
}
*************** c_stderr (void)
*** 75,99 ****
#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */
#endif
! int
! seek_set_function (void)
! {
! return SEEK_SET;
}
! int
! seek_end_function (void)
! {
! return SEEK_END;
}
! void *null_function (void)
! {
! return NULL;
}
! int
! c_fileno (FILE *s)
! {
! return fileno (s);
}
--- 75,99 ----
#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */
#endif
! int
! seek_set_function (void)
! {
! return SEEK_SET;
}
! int
! seek_end_function (void)
! {
! return SEEK_END;
}
! void *null_function (void)
! {
! return NULL;
}
! int
! c_fileno (FILE *s)
! {
! return fileno (s);
}
Index: cal.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cal.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 cal.c
*** cal.c 31 Oct 2003 01:08:40 -0000 1.5
--- cal.c 4 Nov 2003 12:49:12 -0000
***************
*** 6,12 ****
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2002, 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- *
--- 6,12 ----
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2003, 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- *
Index: cuintp.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cuintp.c,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 cuintp.c
*** cuintp.c 31 Oct 2003 01:08:40 -0000 1.6
--- cuintp.c 4 Nov 2003 12:49:12 -0000
*************** UI_To_gnu (Uint Input, tree type)
*** 62,68 ****
tree gnu_ret;
if (Input <= Uint_Direct_Last)
! gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias,
Input < Uint_Direct_Bias ? -1 : 0));
else
{
--- 62,68 ----
tree gnu_ret;
if (Input <= Uint_Direct_Last)
! gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias,
Input < Uint_Direct_Bias ? -1 : 0));
else
{
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.20
diff -u -c -3 -p -r1.20 decl.c
*** decl.c 31 Oct 2003 01:08:40 -0000 1.20
--- decl.c 4 Nov 2003 12:49:12 -0000
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 166,172 ****
&& UI_Is_In_Int_Range (Esize (gnat_entity)))
? MIN (UI_To_Int (Esize (gnat_entity)),
IN (kind, Float_Kind)
! ? LONG_DOUBLE_TYPE_SIZE
: IN (kind, Access_Kind) ? POINTER_SIZE * 2
: LONG_LONG_TYPE_SIZE)
: LONG_LONG_TYPE_SIZE);
--- 166,172 ----
&& UI_Is_In_Int_Range (Esize (gnat_entity)))
? MIN (UI_To_Int (Esize (gnat_entity)),
IN (kind, Float_Kind)
! ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
: IN (kind, Access_Kind) ? POINTER_SIZE * 2
: LONG_LONG_TYPE_SIZE)
: LONG_LONG_TYPE_SIZE);
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 1337,1350 ****
gnu_type = make_signed_type (esize);
TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
SET_TYPE_DIGITS_VALUE (gnu_type,
! UI_To_Int (Digits_Value (gnat_entity)));
break;
}
/* The type of the Low and High bounds can be our type if this is
a type from Standard, so set them at the end of the function. */
gnu_type = make_node (REAL_TYPE);
! TYPE_PRECISION (gnu_type) = esize;
layout_type (gnu_type);
break;
--- 1337,1351 ----
gnu_type = make_signed_type (esize);
TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
SET_TYPE_DIGITS_VALUE (gnu_type,
! UI_To_gnu (Digits_Value (gnat_entity),
! sizetype));
break;
}
/* The type of the Low and High bounds can be our type if this is
a type from Standard, so set them at the end of the function. */
gnu_type = make_node (REAL_TYPE);
! TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
layout_type (gnu_type);
break;
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 1560,1567 ****
tem = gnat_to_gnu_type (Component_Type (gnat_entity));
/* Get and validate any specified Component_Size, but if Packed,
! ignore it since the front end will have taken care of it. Also,
! allow sizes not a multiple of Storage_Unit if packed. */
gnu_comp_size
= validate_size (Component_Size (gnat_entity), tem,
gnat_entity,
--- 1561,1567 ----
tem = gnat_to_gnu_type (Component_Type (gnat_entity));
/* Get and validate any specified Component_Size, but if Packed,
! ignore it since the front end will have taken care of it. */
gnu_comp_size
= validate_size (Component_Size (gnat_entity), tem,
gnat_entity,
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 1884,1891 ****
}
/* Get and validate any specified Component_Size, but if Packed,
! ignore it since the front end will have taken care of it. Also,
! allow sizes not a multiple of Storage_Unit if packed. */
gnu_comp_size
= validate_size (Component_Size (gnat_entity), gnu_type,
gnat_entity,
--- 1884,1890 ----
}
/* Get and validate any specified Component_Size, but if Packed,
! ignore it since the front end will have taken care of it. */
gnu_comp_size
= validate_size (Component_Size (gnat_entity), gnu_type,
gnat_entity,
*************** gnat_to_gnu_field (Entity_Id gnat_field,
*** 4924,4933 ****
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, 0, 1);
! /* If the field's type is a left-justified modular type, make the field
! the type of the inner object unless it is aliases. We don't need
! the the wrapper here and it can prevent packing. */
! if (! Is_Aliased (gnat_field) && TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
--- 4923,4936 ----
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, 0, 1);
! /* If the field's type is left-justified modular, the wrapper can prevent
! packing so we make the field the type of the inner object unless the
! situation forbids it. We may not do that when the field is addressable_p,
! typically because in that case this field may later be passed by-ref for
! a formal argument expecting the left justification. The condition below
! is then matching the addressable_p code for COMPONENT_REF. */
! if (! Is_Aliased (gnat_field) && flag_strict_aliasing
! && TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
*************** gnat_to_gnu_field (Entity_Id gnat_field,
*** 5050,5066 ****
if (Is_Atomic (gnat_field))
check_ok_for_atomic (gnu_field_type, gnat_field, 0);
-
- if (gnu_pos != 0 && TYPE_MODE (gnu_field_type) == BLKmode
- && (! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
- bitsize_unit_node)))
- && TYPE_MODE (gnu_field_type) == BLKmode)
- {
- post_error_ne ("fields of& must start at storage unit boundary",
- First_Bit (Component_Clause (gnat_field)),
- Etype (gnat_field));
- gnu_pos = 0;
- }
}
/* If the record has rep clauses and this is the tag field, make a rep
--- 5053,5058 ----
*************** gnat_to_gnu_field (Entity_Id gnat_field,
*** 5072,5088 ****
gnu_size = TYPE_SIZE (gnu_field_type);
}
- /* If a size is specified and this is a BLKmode field, it must be an
- integral number of bytes. */
- if (gnu_size != 0 && TYPE_MODE (gnu_field_type) == BLKmode
- && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
- bitsize_unit_node)))
- {
- post_error_ne ("size of fields of& must be multiple of a storage unit",
- gnat_field, Etype (gnat_field));
- gnu_pos = gnu_size = 0;
- }
-
/* We need to make the size the maximum for the type if it is
self-referential and an unconstrained type. In that case, we can't
pack the field since we can't make a copy to align it. */
--- 5064,5069 ----
*************** components_to_record (tree gnu_record_ty
*** 5341,5351 ****
gnu_variant_list = gnu_field;
}
! /* We can delete any empty variants from the end. This may leave none
! left. Note we cannot delete variants from anywhere else. */
! while (gnu_variant_list != 0
! && TYPE_FIELDS (TREE_TYPE (gnu_variant_list)) == 0)
! gnu_variant_list = TREE_CHAIN (gnu_variant_list);
/* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
if (gnu_variant_list != 0)
--- 5322,5332 ----
gnu_variant_list = gnu_field;
}
! /* We use to delete the empty variants from the end. However,
! we no longer do that because we need them to generate complete
! debugging information for the variant record. Otherwise,
! the union type definition will be missing the fields associated
! to these empty variants. */
/* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
if (gnu_variant_list != 0)
Index: einfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 einfo.adb
*** einfo.adb 29 Oct 2003 10:26:13 -0000 1.10
--- einfo.adb 4 Nov 2003 12:49:13 -0000
*************** package body Einfo is
*** 302,307 ****
--- 302,308 ----
-- Is_CPP_Class Flag74
-- Has_Non_Standard_Rep Flag75
-- Is_Constructor Flag76
+ -- Is_Thread_Body Flag77
-- Is_Tag Flag78
-- Has_All_Calls_Remote Flag79
-- Is_Constr_Subt_For_U_Nominal Flag80
*************** package body Einfo is
*** 420,426 ****
-- Remaining flags are currently unused and available
- -- (unused) Flag77
-- (unused) Flag136
-- (unused) Flag183
--- 421,426 ----
*************** package body Einfo is
*** 1640,1645 ****
--- 1640,1650 ----
return Flag55 (Id);
end Is_Tagged_Type;
+ function Is_Thread_Body (Id : E) return B is
+ begin
+ return Flag77 (Id);
+ end Is_Thread_Body;
+
function Is_True_Constant (Id : E) return B is
begin
return Flag163 (Id);
*************** package body Einfo is
*** 3581,3586 ****
--- 3586,3596 ----
Set_Flag55 (Id, V);
end Set_Is_Tagged_Type;
+ procedure Set_Is_Thread_Body (Id : E; V : B := True) is
+ begin
+ Set_Flag77 (Id, V);
+ end Set_Is_Thread_Body;
+
procedure Set_Is_True_Constant (Id : E; V : B := True) is
begin
Set_Flag163 (Id, V);
*************** package body Einfo is
*** 6199,6204 ****
--- 6209,6215 ----
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
+ W ("Is_Thread_Body", Flag77 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.13
diff -u -c -3 -p -r1.13 einfo.ads
*** einfo.ads 29 Oct 2003 10:26:13 -0000 1.13
--- einfo.ads 4 Nov 2003 12:49:13 -0000
*************** package Einfo is
*** 2276,2281 ****
--- 2276,2285 ----
-- Is_Task_Type (synthesized)
-- Applies to all entities, true for task types and subtypes
+ -- Is_Thread_Body (Flag77)
+ -- Applies to subprogram entities. Set if a valid Thread_Body pragma
+ -- applies to this subprogram, which is thus a thread body.
+
-- Is_True_Constant (Flag163)
-- This flag is set in constants and variables which have an initial
-- value specified but which are never assigned, partially or in the
*************** package Einfo is
*** 4252,4257 ****
--- 4256,4262 ----
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
+ -- Is_Thread_Body (Flag77) (non-generic case only)
-- Is_Visible_Child_Unit (Flag116)
-- Needs_No_Actuals (Flag22)
-- Return_Present (Flag54)
*************** package Einfo is
*** 4496,4501 ****
--- 4501,4507 ----
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
+ -- Is_Thread_Body (Flag77) (non-generic case only)
-- Is_Valued_Procedure (Flag127)
-- Is_Visible_Child_Unit (Flag116)
-- Needs_No_Actuals (Flag22)
*************** package Einfo is
*** 5117,5122 ****
--- 5123,5129 ----
function Is_Statically_Allocated (Id : E) return B;
function Is_Tag (Id : E) return B;
function Is_Tagged_Type (Id : E) return B;
+ function Is_Thread_Body (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
*************** package Einfo is
*** 5589,5594 ****
--- 5596,5602 ----
procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
procedure Set_Is_Tag (Id : E; V : B := True);
procedure Set_Is_Tagged_Type (Id : E; V : B := True);
+ procedure Set_Is_Thread_Body (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
*************** package Einfo is
*** 6111,6116 ****
--- 6119,6125 ----
pragma Inline (Is_Subprogram);
pragma Inline (Is_Tag);
pragma Inline (Is_Tagged_Type);
+ pragma Inline (Is_Thread_Body);
pragma Inline (Is_True_Constant);
pragma Inline (Is_Task_Type);
pragma Inline (Is_Type);
*************** package Einfo is
*** 6418,6423 ****
--- 6427,6433 ----
pragma Inline (Set_Is_Statically_Allocated);
pragma Inline (Set_Is_Tag);
pragma Inline (Set_Is_Tagged_Type);
+ pragma Inline (Set_Is_Thread_Body);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
pragma Inline (Set_Is_Unsigned_Type);
Index: errno.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/errno.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 errno.c
*** errno.c 31 Oct 2003 01:08:42 -0000 1.5
--- errno.c 4 Nov 2003 12:49:13 -0000
***************
*** 6,12 ****
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2001 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- *
--- 6,12 ----
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2003 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- *
Index: exit.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exit.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 exit.c
*** exit.c 31 Oct 2003 01:08:42 -0000 1.5
--- exit.c 4 Nov 2003 12:49:13 -0000
***************
*** 6,12 ****
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2001 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- *
--- 6,12 ----
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2003 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- *
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 exp_ch4.adb
*** exp_ch4.adb 21 Oct 2003 13:41:59 -0000 1.9
--- exp_ch4.adb 4 Nov 2003 12:49:13 -0000
*************** package body Exp_Ch4 is
*** 3713,3719 ****
exit when Chars (Node (Prim)) = Name_Op_Eq
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
! and then Etype (Node (Prim)) = Standard_Boolean;
Next_Elmt (Prim);
pragma Assert (Present (Prim));
--- 3713,3720 ----
exit when Chars (Node (Prim)) = Name_Op_Eq
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
! and then
! Base_Type (Etype (Node (Prim))) = Standard_Boolean;
Next_Elmt (Prim);
pragma Assert (Present (Prim));
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 exp_ch6.adb
*** exp_ch6.adb 21 Oct 2003 13:41:59 -0000 1.9
--- exp_ch6.adb 4 Nov 2003 12:49:13 -0000
*************** with Sem_Ch12; use Sem_Ch12;
*** 59,70 ****
--- 59,72 ----
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
+ with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
*************** package body Exp_Ch6 is
*** 2849,2854 ****
--- 2851,2858 ----
-- Reset Pure indication if any parameter has root type System.Address
+ -- Wrap thread body
+
procedure Expand_N_Subprogram_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
H : constant Node_Id := Handled_Statement_Sequence (N);
*************** package body Exp_Ch6 is
*** 2866,2871 ****
--- 2870,2878 ----
-- the latter test is not critical, it does not matter if we add a
-- few extra returns, since they get eliminated anyway later on.
+ procedure Expand_Thread_Body;
+ -- Perform required expansion of a thread body
+
----------------
-- Add_Return --
----------------
*************** package body Exp_Ch6 is
*** 2882,2887 ****
--- 2889,3053 ----
end if;
end Add_Return;
+ ------------------------
+ -- Expand_Thread_Body --
+ ------------------------
+
+ -- The required expansion of a thread body is as follows
+
+ -- procedure <thread body procedure name> is
+
+ -- _Secondary_Stack : aliased
+ -- Storage_Elements.Storage_Array
+ -- (1 .. Storage_Offset (Sec_Stack_Size));
+ -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
+
+ -- _Process_ATSD : aliased System.Threads.ATSD;
+
+ -- begin
+ -- System.Threads.Thread_Body_Enter;
+ -- (_Secondary_Stack'Address,
+ -- _Secondary_Stack'Length,
+ -- _Process_ATSD'Address);
+
+ -- declare
+ -- <user declarations>
+ -- begin
+ -- <user statements>
+ -- <user exception handlers>
+ -- end;
+
+ -- System.Threads.Thread_Body_Leave;
+
+ -- exception
+ -- when E : others =>
+ -- System.Threads.Thread_Body_Exceptional_Exit (E);
+ -- end;
+
+ -- Note the exception handler is omitted if pragma Restriction
+ -- No_Exception_Handlers is currently active.
+
+ procedure Expand_Thread_Body is
+ User_Decls : constant List_Id := Declarations (N);
+ Sec_Stack_Len : Node_Id;
+
+ TB_Pragma : constant Node_Id :=
+ Get_Rep_Pragma (Spec_Id, Name_Thread_Body);
+
+ Ent_SS : Entity_Id;
+ Ent_ATSD : Entity_Id;
+ Ent_EO : Entity_Id;
+
+ Decl_SS : Node_Id;
+ Decl_ATSD : Node_Id;
+
+ Excep_Handlers : List_Id;
+
+ begin
+ -- Get proper setting for secondary stack size
+
+ if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
+ Sec_Stack_Len :=
+ Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
+ else
+ Sec_Stack_Len :=
+ Make_Integer_Literal (Loc,
+ Intval =>
+ Expr_Value
+ (Expression (RTE (RE_Default_Secondary_Stack_Size))));
+ end if;
+
+ Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
+
+ -- Build and set declarations for the wrapped thread body
+
+ Ent_SS := Make_Defining_Identifier (Loc, Name_uSecondary_Stack);
+ Ent_ATSD := Make_Defining_Identifier (Loc, Name_uProcess_ATSD);
+
+ Decl_SS :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent_SS,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Sec_Stack_Len)))));
+
+ Decl_ATSD :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent_ATSD,
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (RTE (RE_ATSD), Loc));
+
+ Set_Declarations (N, New_List (Decl_SS, Decl_ATSD));
+ Analyze (Decl_SS);
+ Analyze (Decl_ATSD);
+ Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment));
+
+ -- Create new exception handler
+
+ if Restrictions (No_Exception_Handlers) then
+ Excep_Handlers := No_List;
+
+ else
+ Check_Restriction (No_Exception_Handlers, N);
+
+ Ent_EO := Make_Defining_Identifier (Loc, Name_uE);
+
+ Excep_Handlers := New_List (
+ Make_Exception_Handler (Loc,
+ Choice_Parameter => Ent_EO,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Thread_Body_Exceptional_Exit), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Ent_EO, Loc))))));
+ end if;
+
+ -- Now build new handled statement sequence and analyze it
+
+ Set_Handled_Statement_Sequence (N,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc),
+ Parameter_Associations => New_List (
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent_SS, Loc),
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent_SS, Loc),
+ Attribute_Name => Name_Length),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent_ATSD, Loc),
+ Attribute_Name => Name_Address))),
+
+ Make_Block_Statement (Loc,
+ Declarations => User_Decls,
+ Handled_Statement_Sequence => H),
+
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))),
+
+ Exception_Handlers => Excep_Handlers));
+
+ Analyze (Handled_Statement_Sequence (N));
+ end Expand_Thread_Body;
+
-- Start of processing for Expand_N_Subprogram_Body
begin
*************** package body Exp_Ch6 is
*** 3148,3153 ****
--- 3314,3325 ----
Next_Formal (Formal);
end loop;
end;
+ end if;
+
+ -- Deal with thread body
+
+ if Is_Thread_Body (Spec_Id) then
+ Expand_Thread_Body;
end if;
-- If the subprogram does not have pending instantiations, then we
Index: gigi.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gigi.h,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 gigi.h
*** gigi.h 31 Oct 2003 12:55:36 -0000 1.19
--- gigi.h 4 Nov 2003 12:49:13 -0000
*************** extern tree create_param_decl (tree, tre
*** 570,576 ****
INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate
fields in the FUNCTION_DECL. */
! extern tree create_subprog_decl (tree, tree, tree, tree, int, int, int,
struct attrib *);
/* Returns a LABEL_DECL node for LABEL_NAME. */
--- 570,576 ----
INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate
fields in the FUNCTION_DECL. */
! extern tree create_subprog_decl (tree, tree, tree, tree, int, int, int,
struct attrib *);
/* Returns a LABEL_DECL node for LABEL_NAME. */
*************** extern tree fill_vms_descriptor (tree, E
*** 720,725 ****
--- 720,744 ----
/* Indicate that we need to make the address of EXPR_NODE and it therefore
should not be allocated in a register. Return true if successful. */
extern bool gnat_mark_addressable (tree);
+
+ /* This function is called by the front end to enumerate all the supported
+ modes for the machine. We pass a function which is called back with
+ the following integer parameters:
+
+ FLOAT_P nonzero if this represents a floating-point mode
+ COMPLEX_P nonzero is this represents a complex mode
+ COUNT count of number of items, nonzero for vector mode
+ PRECISION number of bits in data representation
+ MANTISSA number of bits in mantissa, if FP and known, else zero.
+ SIZE number of bits used to store data
+ ALIGN number of bits to which mode is aligned. */
+ extern void enumerate_modes (void (*f) (int, int, int, int, int, int,
+ unsigned int));
+
+ /* These are temporary function to deal with recent GCC changes related to
+ FP type sizes and precisions. */
+ extern int fp_prec_to_size (int);
+ extern int fp_size_to_prec (int);
/* These functions return the basic data type sizes and related parameters
about the target machine. */
Index: gnatbl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbl.c,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 gnatbl.c
*** gnatbl.c 31 Oct 2003 01:08:42 -0000 1.6
--- gnatbl.c 4 Nov 2003 12:49:13 -0000
***************
*** 6,12 ****
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2001 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- *
--- 6,12 ----
* *
* C Implementation File *
* *
! * Copyright (C) 1992-2003 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- *
*************** main (int argc, char **argv)
*** 289,295 ****
{
if (done_an_ali)
{
! fprintf (stderr,
"Sorry - cannot handle more than one ALI file\n");
exit (1);
}
--- 289,295 ----
{
if (done_an_ali)
{
! fprintf (stderr,
"Sorry - cannot handle more than one ALI file\n");
exit (1);
}
*************** main (int argc, char **argv)
*** 323,329 ****
exit (retcode);
}
}
! else
addarg (argv[i]);
}
#ifdef MSDOS
--- 323,329 ----
exit (retcode);
}
}
! else
addarg (argv[i]);
}
#ifdef MSDOS
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 init.c
*** init.c 31 Oct 2003 01:08:42 -0000 1.19
--- init.c 4 Nov 2003 12:49:13 -0000
*************** extern struct Machine_State *(*Get_Machi
*** 82,98 ****
#define Check_Abort_Status \
system__soft_links__check_abort_status
! extern int (*Check_Abort_Status) (void);
#define Raise_From_Signal_Handler \
ada__exceptions__raise_from_signal_handler
! extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
#define Propagate_Signal_Exception \
__gnat_propagate_sig_exc
! extern void Propagate_Signal_Exception (struct Machine_State *,
! struct Exception_Data *,
! const char *);
/* Copies of global values computed by the binder */
int __gl_main_priority = -1;
--- 82,98 ----
#define Check_Abort_Status \
system__soft_links__check_abort_status
! extern int (*Check_Abort_Status) (void);
#define Raise_From_Signal_Handler \
ada__exceptions__raise_from_signal_handler
! extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
#define Propagate_Signal_Exception \
__gnat_propagate_sig_exc
! extern void Propagate_Signal_Exception (struct Machine_State *,
! struct Exception_Data *,
! const char *);
/* Copies of global values computed by the binder */
int __gl_main_priority = -1;
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.20
diff -u -c -3 -p -r1.20 make.adb
*** make.adb 29 Oct 2003 10:26:14 -0000 1.20
--- make.adb 4 Nov 2003 12:49:14 -0000
*************** package body Make is
*** 3363,3369 ****
-- cannot be specified on the command line.
if Osint.Number_Of_Files /= 0 then
! if Projects.Table (Main_Project).Library then
Make_Failed ("cannot specify a main program " &
"on the command line for a library project file");
--- 3363,3372 ----
-- cannot be specified on the command line.
if Osint.Number_Of_Files /= 0 then
! if Projects.Table (Main_Project).Library
! and then not Unique_Compile
! and then ((not Make_Steps) or else Bind_Only or else Link_Only)
! then
Make_Failed ("cannot specify a main program " &
"on the command line for a library project file");
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.48
diff -u -c -3 -p -r1.48 Make-lang.in
*** Make-lang.in 4 Nov 2003 00:25:46 -0000 1.48
--- Make-lang.in 4 Nov 2003 12:49:14 -0000
*************** ada/misc.o : ada/misc.c $(CONFIG_H) $(SY
*** 1201,1207 ****
$(LANGHOOKS_DEF_H) libfuncs.h $(OPTABS_H) ada/ada.h ada/types.h \
ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \
ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \
! ada/adadecode.h opts.h options.h target.h
ada/targtyps.o : ada/targtyps.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
ada/ada.h ada/types.h ada/atree.h ada/nlists.h ada/elists.h ada/uintp.h \
--- 1201,1207 ----
$(LANGHOOKS_DEF_H) libfuncs.h $(OPTABS_H) ada/ada.h ada/types.h \
ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \
ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \
! ada/adadecode.h opts.h options.h target.h real.h
ada/targtyps.o : ada/targtyps.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
ada/ada.h ada/types.h ada/atree.h ada/nlists.h ada/elists.h ada/uintp.h \
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/misc.c,v
retrieving revision 1.68
diff -u -c -3 -p -r1.68 misc.c
*** misc.c 31 Oct 2003 01:08:42 -0000 1.68
--- misc.c 4 Nov 2003 12:49:14 -0000
***************
*** 39,44 ****
--- 39,45 ----
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
+ #include "real.h"
#include "rtl.h"
#include "errors.h"
#include "diagnostic.h"
*************** static void gnat_adjust_rli (record_lay
*** 146,152 ****
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
! /* Tables describing GCC tree codes used only by GNAT.
Table indexed by tree code giving a string containing a character
classifying the tree code. Possibilities are
--- 147,153 ----
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
! /* Tables describing GCC tree codes used only by GNAT.
Table indexed by tree code giving a string containing a character
classifying the tree code. Possibilities are
*************** gnat_handle_option (size_t scode, const
*** 272,278 ****
case OPT_gant:
warning ("`-gnat' misspelled as `-gant'");
!
/* ... fall through ... */
case OPT_gnat:
--- 273,279 ----
case OPT_gant:
warning ("`-gnat' misspelled as `-gant'");
!
/* ... fall through ... */
case OPT_gnat:
*************** gnat_handle_option (size_t scode, const
*** 283,289 ****
gnat_argc++;
if (arg[0] == 'O')
! for (i = 1; i < save_argc - 1; i++)
if (!strncmp (save_argv[i], "-gnatO", 6))
if (save_argv[++i][0] != '-')
{
--- 284,290 ----
gnat_argc++;
if (arg[0] == 'O')
! for (i = 1; i < save_argc - 1; i++)
if (!strncmp (save_argv[i], "-gnatO", 6))
if (save_argv[++i][0] != '-')
{
*************** static unsigned int
*** 304,311 ****
gnat_init_options (unsigned int argc, const char **argv)
{
/* Initialize gnat_argv with save_argv size. */
! gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
! gnat_argv[0] = xstrdup (argv[0]); /* name of the command */
gnat_argc = 1;
save_argc = argc;
--- 305,312 ----
gnat_init_options (unsigned int argc, const char **argv)
{
/* Initialize gnat_argv with save_argv size. */
! gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
! gnat_argv[0] = xstrdup (argv[0]); /* name of the command */
gnat_argc = 1;
save_argc = argc;
*************** static int
*** 706,712 ****
gnat_eh_type_covers (tree a, tree b)
{
/* a catches b if they represent the same exception id or if a
! is an "others".
??? integer_zero_node for "others" is hardwired in too many places
currently. */
--- 707,713 ----
gnat_eh_type_covers (tree a, tree b)
{
/* a catches b if they represent the same exception id or if a
! is an "others".
??? integer_zero_node for "others" is hardwired in too many places
currently. */
*************** must_pass_by_ref (tree gnu_type)
*** 886,888 ****
--- 887,994 ----
|| (TYPE_SIZE (gnu_type) != 0
&& TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
}
+
+ /* This function is called by the front end to enumerate all the supported
+ modes for the machine. We pass a function which is called back with
+ the following integer parameters:
+
+ FLOAT_P nonzero if this represents a floating-point mode
+ COMPLEX_P nonzero is this represents a complex mode
+ COUNT count of number of items, nonzero for vector mode
+ PRECISION number of bits in data representation
+ MANTISSA number of bits in mantissa, if FP and known, else zero.
+ SIZE number of bits used to store data
+ ALIGN number of bits to which mode is aligned. */
+
+ void
+ enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
+ {
+ enum machine_mode i;
+
+ for (i = 0; i < NUM_MACHINE_MODES; i++)
+ {
+ enum machine_mode j;
+ bool float_p = 0;
+ bool complex_p = 0;
+ bool vector_p = 0;
+ bool skip_p = 0;
+ int mantissa = 0;
+ enum machine_mode inner_mode = i;
+
+ switch (GET_MODE_CLASS (i))
+ {
+ case MODE_INT:
+ break;
+ case MODE_FLOAT:
+ float_p = 1;
+ break;
+ case MODE_COMPLEX_INT:
+ complex_p = 1;
+ inner_mode = GET_MODE_INNER (i);
+ break;
+ case MODE_COMPLEX_FLOAT:
+ float_p = 1;
+ complex_p = 1;
+ inner_mode = GET_MODE_INNER (i);
+ break;
+ case MODE_VECTOR_INT:
+ vector_p = 1;
+ inner_mode = GET_MODE_INNER (i);
+ break;
+ case MODE_VECTOR_FLOAT:
+ float_p = 1;
+ vector_p = 1;
+ inner_mode = GET_MODE_INNER (i);
+ break;
+ default:
+ skip_p = 1;
+ }
+
+ /* Skip this mode if it's one the front end doesn't need to know about
+ (e.g., the CC modes) or if there is no add insn for that mode (or
+ any wider mode), meaning it is not supported by the hardware. If
+ this a complex or vector mode, we care about the inner mode. */
+ for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
+ if (add_optab->handlers[j].insn_code != CODE_FOR_nothing)
+ break;
+
+ if (float_p)
+ {
+ const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
+
+ mantissa = fmt->p * fmt->log2_b;
+ }
+
+ if (!skip_p && j != VOIDmode)
+ (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
+ GET_MODE_BITSIZE (i), mantissa,
+ GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
+ }
+ }
+
+ int
+ fp_prec_to_size (int prec)
+ {
+ enum machine_mode mode;
+
+ for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
+ mode = GET_MODE_WIDER_MODE (mode))
+ if (GET_MODE_BITSIZE (mode) == prec)
+ return GET_MODE_SIZE (mode) * BITS_PER_UNIT;
+
+ abort ();
+ }
+
+ int
+ fp_size_to_prec (int size)
+ {
+ enum machine_mode mode;
+
+ for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
+ mode = GET_MODE_WIDER_MODE (mode))
+ if (GET_MODE_SIZE (mode) * BITS_PER_UNIT == size)
+ return GET_MODE_BITSIZE (mode);
+
+ abort ();
+ }
+
Index: par-prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-prag.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 par-prag.adb
*** par-prag.adb 21 Oct 2003 13:42:11 -0000 1.7
--- par-prag.adb 4 Nov 2003 12:49:14 -0000
*************** begin
*** 980,985 ****
--- 980,986 ----
Pragma_Task_Info |
Pragma_Task_Name |
Pragma_Task_Storage |
+ Pragma_Thread_Body |
Pragma_Time_Slice |
Pragma_Title |
Pragma_Unchecked_Union |
Index: raise.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/raise.c,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 raise.c
*** raise.c 31 Oct 2003 12:37:54 -0000 1.10
--- raise.c 4 Nov 2003 12:49:14 -0000
*************** get_action_description_for (_Unwind_Cont
*** 940,947 ****
static void
setup_to_install (_Unwind_Context *uw_context,
_Unwind_Exception *uw_exception,
! int uw_filter,
! _Unwind_Ptr uw_landing_pad)
{
#ifndef EH_RETURN_DATA_REGNO
/* We should not be called if the appropriate underlying support is not
--- 940,947 ----
static void
setup_to_install (_Unwind_Context *uw_context,
_Unwind_Exception *uw_exception,
! _Unwind_Ptr uw_landing_pad,
! int uw_filter)
{
#ifndef EH_RETURN_DATA_REGNO
/* We should not be called if the appropriate underlying support is not
Index: rtsfind.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/rtsfind.ads,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 rtsfind.ads
*** rtsfind.ads 21 Oct 2003 13:42:13 -0000 1.8
--- rtsfind.ads 4 Nov 2003 12:49:14 -0000
*************** package Rtsfind is
*** 298,303 ****
--- 298,304 ----
System_String_Ops_Concat_5,
System_Task_Info,
System_Tasking,
+ System_Threads,
System_Unsigned_Types,
System_Val_Bool,
System_Val_Char,
*************** package Rtsfind is
*** 1034,1039 ****
--- 1035,1041 ----
RE_IS_Ilf, -- System.Scalar_Values
RE_IS_Ill, -- System.Scalar_Values
+ RE_Default_Secondary_Stack_Size, -- System.Secondary_Stack
RE_Mark_Id, -- System.Secondary_Stack
RE_SS_Allocate, -- System.Secondary_Stack
RE_SS_Pool, -- System.Secondary_Stack
*************** package Rtsfind is
*** 1164,1169 ****
--- 1166,1176 ----
RE_Get_GNAT_Exception, -- System.Soft_Links
RE_Update_Exception, -- System.Soft_Links
+ RE_ATSD, -- System.Threads
+ RE_Thread_Body_Enter, -- System.Threads
+ RE_Thread_Body_Exceptional_Exit, -- System.Threads
+ RE_Thread_Body_Leave, -- System.Threads
+
RE_Bits_1, -- System.Unsigned_Types
RE_Bits_2, -- System.Unsigned_Types
RE_Bits_4, -- System.Unsigned_Types
*************** package Rtsfind is
*** 1968,1973 ****
--- 1975,1981 ----
RE_IS_Ilf => System_Scalar_Values,
RE_IS_Ill => System_Scalar_Values,
+ RE_Default_Secondary_Stack_Size => System_Secondary_Stack,
RE_Mark_Id => System_Secondary_Stack,
RE_SS_Allocate => System_Secondary_Stack,
RE_SS_Mark => System_Secondary_Stack,
*************** package Rtsfind is
*** 2097,2102 ****
--- 2105,2115 ----
RE_Get_Current_Excep => System_Soft_Links,
RE_Get_GNAT_Exception => System_Soft_Links,
RE_Update_Exception => System_Soft_Links,
+
+ RE_ATSD => System_Threads,
+ RE_Thread_Body_Enter => System_Threads,
+ RE_Thread_Body_Exceptional_Exit => System_Threads,
+ RE_Thread_Body_Leave => System_Threads,
RE_Bits_1 => System_Unsigned_Types,
RE_Bits_2 => System_Unsigned_Types,
Index: sem_attr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_attr.adb,v
retrieving revision 1.13
diff -u -c -3 -p -r1.13 sem_attr.adb
*** sem_attr.adb 21 Oct 2003 13:42:18 -0000 1.13
--- sem_attr.adb 4 Nov 2003 12:49:14 -0000
*************** package body Sem_Attr is
*** 372,379 ****
----------------------------------
procedure Build_Access_Subprogram_Type (P : Node_Id) is
! Index : Interp_Index;
! It : Interp;
function Get_Kind (E : Entity_Id) return Entity_Kind;
-- Distinguish between access to regular and protected
--- 372,379 ----
----------------------------------
procedure Build_Access_Subprogram_Type (P : Node_Id) is
! Index : Interp_Index;
! It : Interp;
function Get_Kind (E : Entity_Id) return Entity_Kind;
-- Distinguish between access to regular and protected
*************** package body Sem_Attr is
*** 395,400 ****
--- 395,404 ----
-- Start of processing for Build_Access_Subprogram_Type
begin
+ -- In the case of an access to subprogram, use the name of the
+ -- subprogram itself as the designated type. Type-checking in
+ -- this case compares the signatures of the designated types.
+
if not Is_Overloaded (P) then
Acc_Type :=
New_Internal_Entity
*************** package body Sem_Attr is
*** 408,414 ****
Set_Etype (N, Any_Type);
while Present (It.Nam) loop
-
if not Is_Intrinsic_Subprogram (It.Nam) then
Acc_Type :=
New_Internal_Entity
--- 412,417 ----
*************** package body Sem_Attr is
*** 437,453 ****
("prefix of % attribute cannot be enumeration literal", P);
end if;
! -- In the case of an access to subprogram, use the name of the
! -- subprogram itself as the designated type. Type-checking in
! -- this case compares the signatures of the designated types.
if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
then
if not Is_Library_Level_Entity (Entity (P)) then
Check_Restriction (No_Implicit_Dynamic_Code, P);
end if;
Build_Access_Subprogram_Type (P);
-- For unrestricted access, kill current values, since this
--- 440,459 ----
("prefix of % attribute cannot be enumeration literal", P);
end if;
! -- Case of access to subprogram
if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
then
+ -- Not allowed for nested subprograms if No_Implicit_Dynamic_Code
+ -- restriction set (since in general a trampoline is required).
+
if not Is_Library_Level_Entity (Entity (P)) then
Check_Restriction (No_Implicit_Dynamic_Code, P);
end if;
+ -- Build the appropriate subprogram type
+
Build_Access_Subprogram_Type (P);
-- For unrestricted access, kill current values, since this
*************** package body Sem_Attr is
*** 460,466 ****
return;
! -- Component is an operation of a protected type.
elsif Nkind (P) = N_Selected_Component
and then Is_Overloadable (Entity (Selector_Name (P)))
--- 466,472 ----
return;
! -- Component is an operation of a protected type
elsif Nkind (P) = N_Selected_Component
and then Is_Overloadable (Entity (Selector_Name (P)))
*************** package body Sem_Attr is
*** 6406,6412 ****
end if;
if Is_Entity_Name (P) then
-
if Is_Overloaded (P) then
Get_First_Interp (P, Index, It);
--- 6412,6417 ----
*************** package body Sem_Attr is
*** 6437,6455 ****
Resolve (P);
end if;
if not Is_Entity_Name (P) then
null;
elsif Is_Abstract (Entity (P))
and then Is_Overloadable (Entity (P))
then
- Error_Msg_Name_1 := Aname;
Error_Msg_N ("prefix of % attribute cannot be abstract", P);
Set_Etype (N, Any_Type);
elsif Convention (Entity (P)) = Convention_Intrinsic then
- Error_Msg_Name_1 := Aname;
-
if Ekind (Entity (P)) = E_Enumeration_Literal then
Error_Msg_N
("prefix of % attribute cannot be enumeration literal",
--- 6442,6459 ----
Resolve (P);
end if;
+ Error_Msg_Name_1 := Aname;
+
if not Is_Entity_Name (P) then
null;
elsif Is_Abstract (Entity (P))
and then Is_Overloadable (Entity (P))
then
Error_Msg_N ("prefix of % attribute cannot be abstract", P);
Set_Etype (N, Any_Type);
elsif Convention (Entity (P)) = Convention_Intrinsic then
if Ekind (Entity (P)) = E_Enumeration_Literal then
Error_Msg_N
("prefix of % attribute cannot be enumeration literal",
*************** package body Sem_Attr is
*** 6460,6465 ****
--- 6464,6473 ----
end if;
Set_Etype (N, Any_Type);
+
+ elsif Is_Thread_Body (Entity (P)) then
+ Error_Msg_N
+ ("prefix of % attribute cannot be a thread body", P);
end if;
-- Assignments, return statements, components of aggregates,
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 sem_ch10.adb
*** sem_ch10.adb 29 Oct 2003 10:26:14 -0000 1.10
--- sem_ch10.adb 4 Nov 2003 12:49:14 -0000
*************** package body Sem_Ch10 is
*** 3233,3240 ****
Unum : Unit_Number_Type :=
Get_Source_Unit (Library_Unit (N));
P_Unit : Entity_Id := Unit (Library_Unit (N));
! P : Entity_Id :=
! Defining_Unit_Name (Specification (P_Unit));
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
Is_Child_Package : Boolean := False;
--- 3233,3239 ----
Unum : Unit_Number_Type :=
Get_Source_Unit (Library_Unit (N));
P_Unit : Entity_Id := Unit (Library_Unit (N));
! P : Entity_Id;
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
Is_Child_Package : Boolean := False;
*************** package body Sem_Ch10 is
*** 3261,3266 ****
--- 3260,3292 ----
-- Start of processing for Install_Limited_Withed_Unit
begin
+ -- In case of limited with_clause on subprograms, generics, instances,
+ -- or generic renamings, the corresponding error was previously posted
+ -- and we have nothing to do here.
+
+ case Nkind (P_Unit) is
+
+ when N_Package_Declaration =>
+ null;
+
+ when N_Subprogram_Declaration |
+ N_Generic_Package_Declaration |
+ N_Generic_Subprogram_Declaration |
+ N_Package_Instantiation |
+ N_Function_Instantiation |
+ N_Procedure_Instantiation |
+ N_Generic_Package_Renaming_Declaration |
+ N_Generic_Procedure_Renaming_Declaration |
+ N_Generic_Function_Renaming_Declaration =>
+ return;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+
+ P := Defining_Unit_Name (Specification (P_Unit));
+
if Nkind (P) = N_Defining_Program_Unit_Name then
-- Retrieve entity of child package
*************** package body Sem_Ch10 is
*** 3803,3825 ****
--- 3829,3855 ----
when N_Subprogram_Declaration =>
Error_Msg_N ("subprograms not allowed in "
& "limited with_clauses", N);
+ return;
when N_Generic_Package_Declaration |
N_Generic_Subprogram_Declaration =>
Error_Msg_N ("generics not allowed in "
& "limited with_clauses", N);
+ return;
when N_Package_Instantiation |
N_Function_Instantiation |
N_Procedure_Instantiation =>
Error_Msg_N ("generic instantiations not allowed in "
& "limited with_clauses", N);
+ return;
when N_Generic_Package_Renaming_Declaration |
N_Generic_Procedure_Renaming_Declaration |
N_Generic_Function_Renaming_Declaration =>
Error_Msg_N ("generic renamings not allowed in "
& "limited with_clauses", N);
+ return;
when others =>
pragma Assert (False);
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 sem_prag.adb
*** sem_prag.adb 27 Oct 2003 14:27:17 -0000 1.11
--- sem_prag.adb 4 Nov 2003 12:49:14 -0000
*************** package body Sem_Prag is
*** 9082,9087 ****
--- 9082,9161 ----
end if;
end Task_Storage;
+ -----------------
+ -- Thread_Body --
+ -----------------
+
+ -- pragma Thread_Body
+ -- ( [Entity =>] LOCAL_NAME
+ -- [,[Secondary_Stack_Size =>] static_integer_EXPRESSION]);
+
+ when Pragma_Thread_Body => Thread_Body : declare
+ Id : Node_Id;
+ SS : Node_Id;
+ E : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Id := Expression (Arg1);
+
+ if not Is_Entity_Name (Id)
+ or else not Is_Subprogram (Entity (Id))
+ then
+ Error_Pragma_Arg ("subprogram name required", Arg1);
+ end if;
+
+ E := Entity (Id);
+
+ -- Go to renamed subprogram if present, since Thread_Body applies
+ -- to the actual renamed entity, not to the renaming entity.
+
+ if Present (Alias (E))
+ and then Nkind (Parent (Declaration_Node (E))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ E := Alias (E);
+ end if;
+
+ -- Various error checks
+
+ if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body then
+ Error_Pragma
+ ("pragma% requires separate spec and must come before body");
+
+ elsif Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ raise Pragma_Exit;
+
+ elsif Is_Thread_Body (E) then
+ Error_Pragma_Arg
+ ("only one thread body pragma allowed", Arg1);
+
+ elsif Present (Homonym (E))
+ and then Scope (Homonym (E)) = Current_Scope
+ then
+ Error_Pragma_Arg
+ ("thread body subprogram must not be overloaded", Arg1);
+ end if;
+
+ Set_Is_Thread_Body (E);
+
+ -- Deal with secondary stack argument
+
+ if Arg_Count = 2 then
+ Check_Optional_Identifier (Arg2, Name_Secondary_Stack_Size);
+ SS := Expression (Arg2);
+ Analyze_And_Resolve (SS, Any_Integer);
+ end if;
+ end Thread_Body;
+
----------------
-- Time_Slice --
----------------
*************** package body Sem_Prag is
*** 9812,9817 ****
--- 9886,9892 ----
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
+ Pragma_Thread_Body => +2,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => -1,
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 sem_res.adb
*** sem_res.adb 21 Oct 2003 13:42:21 -0000 1.11
--- sem_res.adb 4 Nov 2003 12:49:15 -0000
*************** package body Sem_Res is
*** 3315,3321 ****
-- dereference made explicit in Analyze_Call.
if Ekind (Etype (Subp)) = E_Subprogram_Type then
-
if not Is_Overloaded (Subp) then
Nam := Etype (Subp);
--- 3315,3320 ----
*************** package body Sem_Res is
*** 3421,3426 ****
--- 3420,3431 ----
end if;
end loop;
end;
+ end if;
+
+ -- Cannot call thread body directly
+
+ if Is_Thread_Body (Nam) then
+ Error_Msg_N ("cannot call thread body directly", N);
end if;
-- If the subprogram is not global, then kill all checks. This is
Index: snames.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 snames.h
*** snames.h 21 Oct 2003 13:42:22 -0000 1.6
--- snames.h 4 Nov 2003 12:49:15 -0000
*************** extern unsigned char Get_Pragma_Id (int)
*** 326,346 ****
#define Pragma_Task_Info 124
#define Pragma_Task_Name 125
#define Pragma_Task_Storage 126
! #define Pragma_Time_Slice 127
! #define Pragma_Title 128
! #define Pragma_Unchecked_Union 129
! #define Pragma_Unimplemented_Unit 130
! #define Pragma_Unreferenced 131
! #define Pragma_Unreserve_All_Interrupts 132
! #define Pragma_Volatile 133
! #define Pragma_Volatile_Components 134
! #define Pragma_Weak_External 135
/* The following are deliberately out of alphabetical order, see Snames */
! #define Pragma_AST_Entry 136
! #define Pragma_Storage_Size 137
! #define Pragma_Storage_Unit 138
/* Define the numeric values for the conventions. */
--- 326,347 ----
#define Pragma_Task_Info 124
#define Pragma_Task_Name 125
#define Pragma_Task_Storage 126
! #define Pragma_Thread_Body 127
! #define Pragma_Time_Slice 128
! #define Pragma_Title 129
! #define Pragma_Unchecked_Union 130
! #define Pragma_Unimplemented_Unit 131
! #define Pragma_Unreferenced 132
! #define Pragma_Unreserve_All_Interrupts 133
! #define Pragma_Volatile 134
! #define Pragma_Volatile_Components 135
! #define Pragma_Weak_External 136
/* The following are deliberately out of alphabetical order, see Snames */
! #define Pragma_AST_Entry 137
! #define Pragma_Storage_Size 138
! #define Pragma_Storage_Unit 139
/* Define the numeric values for the conventions. */
Index: s-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 s-thread.adb
*** s-thread.adb 21 Oct 2003 13:42:17 -0000 1.1
--- s-thread.adb 4 Nov 2003 12:49:15 -0000
*************** package body System.Threads is
*** 43,48 ****
--- 43,50 ----
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
+
+
-----------------------
-- Get_Current_Excep --
-----------------------
*************** package body System.Threads is
*** 97,101 ****
--- 99,140 ----
pragma Assert (Current_ATSD /= System.Null_Address);
CTSD.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
+
+ -----------------------
+ -- Thread_Body_Enter --
+ -----------------------
+
+ procedure Thread_Body_Enter
+ (Sec_Stack_Address : System.Address;
+ Sec_Stack_Size : Natural;
+ Process_ATSD_Address : System.Address)
+ is
+ pragma Unreferenced (Sec_Stack_Address);
+ pragma Unreferenced (Sec_Stack_Size);
+ pragma Unreferenced (Process_ATSD_Address);
+ begin
+ null;
+ end Thread_Body_Enter;
+
+ ----------------------------------
+ -- Thread_Body_Exceptional_Exit --
+ ----------------------------------
+
+ procedure Thread_Body_Exceptional_Exit
+ (EO : Ada.Exceptions.Exception_Occurrence)
+ is
+ pragma Unreferenced (EO);
+ begin
+ null;
+ end Thread_Body_Exceptional_Exit;
+
+ -----------------------
+ -- Thread_Body_Leave --
+ -----------------------
+
+ procedure Thread_Body_Leave is
+ begin
+ null;
+ end Thread_Body_Leave;
end System.Threads;
Index: s-thread.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.ads,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 s-thread.ads
*** s-thread.ads 21 Oct 2003 13:42:18 -0000 1.1
--- s-thread.ads 4 Nov 2003 12:49:15 -0000
*************** package System.Threads is
*** 48,54 ****
type ATSD_Access is access ATSD;
! -- Get/Set for the attributes of the current thread.
function Get_Jmpbuf_Address return Address;
pragma Inline (Get_Jmpbuf_Address);
--- 48,54 ----
type ATSD_Access is access ATSD;
! -- Get/Set for the attributes of the current thread
function Get_Jmpbuf_Address return Address;
pragma Inline (Get_Jmpbuf_Address);
*************** package System.Threads is
*** 64,69 ****
--- 64,136 ----
function Get_Current_Excep return EOA;
pragma Inline (Get_Current_Excep);
+
+ --------------------------
+ -- Thread Body Handling --
+ --------------------------
+
+ -- The subprograms in this section are called by the expansion of a
+ -- subprogram body to which a Thread_Body pragma has been applied:
+
+ -- Given a subprogram body
+
+ -- procedure xyz (params ....) is -- can also be a function
+ -- <user declarations>
+ -- begin
+ -- <user statements>
+ -- <user exception handlers>
+ -- end xyz;
+
+ -- The expansion resulting from use of the Thread_Body pragma is:
+
+ -- procedure xyz (params ...) is
+
+ -- _Secondary_Stack : aliased
+ -- Storage_Elements.Storage_Array
+ -- (1 .. Storage_Offset (Sec_Stack_Size));
+ -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
+
+ -- _Process_ATSD : aliased System.Threads.ATSD;
+
+ -- begin
+ -- System.Threads.Thread_Body_Enter;
+ -- (_Secondary_Stack'Address,
+ -- _Secondary_Stack'Length,
+ -- _Process_ATSD'Address);
+
+ -- declare
+ -- <user declarations>
+ -- begin
+ -- <user statements>
+ -- <user exception handlers>
+ -- end;
+
+ -- System.Threads.Thread_Body_Leave;
+
+ -- exception
+ -- when E : others =>
+ -- System.Threads.Thread_Body_Exceptional_Exit (E);
+ -- end;
+
+ -- Note the exception handler is omitted if pragma Restriction
+ -- No_Exception_Handlers is currently active.
+
+ -- Note: the secondary stack size (Sec_Stack_Size) comes either from
+ -- the pragma, if specified, or is the default value taken from
+ -- the declaration in System.Secondary_Stack.
+
+ procedure Thread_Body_Enter
+ (Sec_Stack_Address : System.Address;
+ Sec_Stack_Size : Natural;
+ Process_ATSD_Address : System.Address);
+ -- Enter thread body, see above for details
+
+ procedure Thread_Body_Leave;
+ -- Leave thread body (normally), see above for details
+
+ procedure Thread_Body_Exceptional_Exit
+ (EO : Ada.Exceptions.Exception_Occurrence);
+ -- Leave thread body (abnormally on exception), see above for details
private
Index: stringt.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/stringt.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 stringt.h
*** stringt.h 24 Oct 2003 02:28:37 -0000 1.6
--- stringt.h 4 Nov 2003 12:49:15 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * Copyright (C) 1992-2001 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * Copyright (C) 1992-2003 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,48 ****
/* This file is the C file that corresponds to the Ada package spec
Stringt. It was created manually from stringt.ads and stringt.adb
!
Note: only the access functions are provided, since the tree transformer
is not allowed to modify the tree or its auxiliary structures.
!
This package contains routines for handling the strings table which is
used to store string constants encountered in the source, and also those
additional string constants generated by compile time concatenation and
other similar processing.
!
A string constant in this table consists of a series of Char_Code values,
so that 16-bit character codes can be properly handled if this feature is
implemented in the scanner.
!
There is no guarantee that hashing is used in the implementation. This
means that the caller cannot count on having the same Id value for two
identical strings stored separately.
!
The String_Id values reference entries in the Strings table, which
contains String_Entry records that record the length of each stored string
and its starting location in the String_Chars table. */
--- 26,48 ----
/* This file is the C file that corresponds to the Ada package spec
Stringt. It was created manually from stringt.ads and stringt.adb
!
Note: only the access functions are provided, since the tree transformer
is not allowed to modify the tree or its auxiliary structures.
!
This package contains routines for handling the strings table which is
used to store string constants encountered in the source, and also those
additional string constants generated by compile time concatenation and
other similar processing.
!
A string constant in this table consists of a series of Char_Code values,
so that 16-bit character codes can be properly handled if this feature is
implemented in the scanner.
!
There is no guarantee that hashing is used in the implementation. This
means that the caller cannot count on having the same Id value for two
identical strings stored separately.
!
The String_Id values reference entries in the Strings table, which
contains String_Entry records that record the length of each stored string
and its starting location in the String_Chars table. */
Index: sysdep.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sysdep.c,v
retrieving revision 1.12
diff -u -c -3 -p -r1.12 sysdep.c
*** sysdep.c 31 Oct 2003 01:08:43 -0000 1.12
--- sysdep.c 4 Nov 2003 12:49:15 -0000
***************
*** 45,50 ****
--- 45,53 ----
#include <fcntl.h>
#include <sys/stat.h>
#include "time.h"
+ #ifdef VMS
+ #include <unixio.h>
+ #endif
#else
#include "config.h"
#include "system.h"
Index: targtyps.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targtyps.c,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 targtyps.c
*** targtyps.c 31 Oct 2003 01:08:43 -0000 1.7
--- targtyps.c 4 Nov 2003 12:49:15 -0000
*************** get_target_long_long_size (void)
*** 120,139 ****
Pos
get_target_float_size (void)
{
! return FLOAT_TYPE_SIZE;
}
Pos
get_target_double_size (void)
{
! return DOUBLE_TYPE_SIZE;
}
Pos
get_target_long_double_size (void)
{
! return WIDEST_HARDWARE_FP_SIZE;
}
Pos
get_target_pointer_size (void)
--- 120,140 ----
Pos
get_target_float_size (void)
{
! return fp_prec_to_size (FLOAT_TYPE_SIZE);
}
Pos
get_target_double_size (void)
{
! return fp_prec_to_size (DOUBLE_TYPE_SIZE);
}
Pos
get_target_long_double_size (void)
{
! return fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE);
}
+
Pos
get_target_pointer_size (void)
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.38
diff -u -c -3 -p -r1.38 trans.c
*** trans.c 31 Oct 2003 01:08:43 -0000 1.38
--- trans.c 4 Nov 2003 12:49:15 -0000
*************** static void
*** 4406,4412 ****
process_decls (List_Id gnat_decls,
List_Id gnat_decls2,
Node_Id gnat_end_list,
! int pass1p,
int pass2p)
{
List_Id gnat_decl_array[2];
--- 4406,4412 ----
process_decls (List_Id gnat_decls,
List_Id gnat_decls2,
Node_Id gnat_end_list,
! int pass1p,
int pass2p)
{
List_Id gnat_decl_array[2];
Index: utils2.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils2.c,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 utils2.c
*** utils2.c 31 Oct 2003 01:08:43 -0000 1.19
--- utils2.c 4 Nov 2003 12:49:15 -0000
*************** known_alignment (tree exp)
*** 153,160 ****
We always compute a type_alignment value and return the MAX of it
compared with what we get from the expression tree. Just set the
type_alignment value to 0 when the type information is to be ignored. */
! type_alignment
! = ((POINTER_TYPE_P (TREE_TYPE (exp))
&& ! TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))) : 0);
--- 153,160 ----
We always compute a type_alignment value and return the MAX of it
compared with what we get from the expression tree. Just set the
type_alignment value to 0 when the type information is to be ignored. */
! type_alignment
! = ((POINTER_TYPE_P (TREE_TYPE (exp))
&& ! TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))) : 0);
*************** known_alignment (tree exp)
*** 165,171 ****
case NON_LVALUE_EXPR:
/* Conversions between pointers and integers don't change the alignment
of the underlying object. */
! this_alignment = known_alignment (TREE_OPERAND (exp, 0));
break;
case PLUS_EXPR:
--- 165,171 ----
case NON_LVALUE_EXPR:
/* Conversions between pointers and integers don't change the alignment
of the underlying object. */
! this_alignment = known_alignment (TREE_OPERAND (exp, 0));
break;
case PLUS_EXPR:
*************** compare_arrays (tree result_type, tree a
*** 357,363 ****
tree comparison, this_a1_is_null, this_a2_is_null;
/* If the length of the first array is a constant, swap our operands
! unless the length of the second array is the constant zero.
Note that we have set the `length' values to the length - 1. */
if (TREE_CODE (length1) == INTEGER_CST
&& ! integer_zerop (fold (build (PLUS_EXPR, bt, length2,
--- 357,363 ----
tree comparison, this_a1_is_null, this_a2_is_null;
/* If the length of the first array is a constant, swap our operands
! unless the length of the second array is the constant zero.
Note that we have set the `length' values to the length - 1. */
if (TREE_CODE (length1) == INTEGER_CST
&& ! integer_zerop (fold (build (PLUS_EXPR, bt, length2,
*************** compare_arrays (tree result_type, tree a
*** 406,412 ****
nbt = get_base_type (TREE_TYPE (ub1));
comparison
! = build_binary_op (EQ_EXPR, result_type,
build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
--- 406,412 ----
nbt = get_base_type (TREE_TYPE (ub1));
comparison
! = build_binary_op (EQ_EXPR, result_type,
build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
*************** compare_arrays (tree result_type, tree a
*** 491,497 ****
modulus. */
static tree
! nonbinary_modular_operation (enum tree_code op_code,
tree type,
tree lhs,
tree rhs)
--- 491,497 ----
modulus. */
static tree
! nonbinary_modular_operation (enum tree_code op_code,
tree type,
tree lhs,
tree rhs)
*************** nonbinary_modular_operation (enum tree_c
*** 591,598 ****
have to do here is validate the work done by SEM and handle subtypes. */
tree
! build_binary_op (enum tree_code op_code,
! tree result_type,
tree left_operand,
tree right_operand)
{
--- 591,598 ----
have to do here is validate the work done by SEM and handle subtypes. */
tree
! build_binary_op (enum tree_code op_code,
! tree result_type,
tree left_operand,
tree right_operand)
{
*************** build_binary_op (enum tree_code op_code,
*** 937,943 ****
gigi_abort (505);
}
! /* If we are comparing a fat pointer against zero, we need to
just compare the data pointer. */
else if (TYPE_FAT_POINTER_P (left_base_type)
&& TREE_CODE (right_operand) == CONSTRUCTOR
--- 937,943 ----
gigi_abort (505);
}
! /* If we are comparing a fat pointer against zero, we need to
just compare the data pointer. */
else if (TYPE_FAT_POINTER_P (left_base_type)
&& TREE_CODE (right_operand) == CONSTRUCTOR
*************** build_simple_component_ref (tree record_
*** 1651,1657 ****
if (DECL_INTERNAL_P (new_field))
{
tree field_ref
! = build_simple_component_ref (record_variable,
NULL_TREE, new_field, no_fold_p);
ref = build_simple_component_ref (field_ref, NULL_TREE, field,
no_fold_p);
--- 1651,1657 ----
if (DECL_INTERNAL_P (new_field))
{
tree field_ref
! = build_simple_component_ref (record_variable,
NULL_TREE, new_field, no_fold_p);
ref = build_simple_component_ref (field_ref, NULL_TREE, field,
no_fold_p);
*************** build_call_alloc_dealloc (tree gnu_obj,
*** 1731,1737 ****
if (Present (gnat_proc))
{
! /* The storage pools are obviously always tagged types, but the
secondary stack uses the same mechanism and is not tagged */
if (Is_Tagged_Type (Etype (gnat_pool)))
{
--- 1731,1737 ----
if (Present (gnat_proc))
{
! /* The storage pools are obviously always tagged types, but the
secondary stack uses the same mechanism and is not tagged */
if (Is_Tagged_Type (Etype (gnat_pool)))
{
*************** build_call_alloc_dealloc (tree gnu_obj,
*** 1763,1769 ****
convert (gnu_size_type, gnu_size)));
gnu_args
= chainon (gnu_args,
! build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_align)));
gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
--- 1763,1769 ----
convert (gnu_size_type, gnu_size)));
gnu_args
= chainon (gnu_args,
! build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_align)));
gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
*************** build_call_alloc_dealloc (tree gnu_obj,
*** 1776,1782 ****
else
{
/* The size is the second parameter */
! Entity_Id gnat_size_type
= Etype (Next_Formal (First_Formal (gnat_proc)));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
tree gnu_proc = gnat_to_gnu (gnat_proc);
--- 1776,1782 ----
else
{
/* The size is the second parameter */
! Entity_Id gnat_size_type
= Etype (Next_Formal (First_Formal (gnat_proc)));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
tree gnu_proc = gnat_to_gnu (gnat_proc);
*************** build_allocator (tree type,
*** 1998,2004 ****
return convert (result_type, result);
}
\f
! /* Fill in a VMS descriptor for EXPR and return a constructor for it.
GNAT_FORMAL is how we find the descriptor record. */
tree
--- 1998,2004 ----
return convert (result_type, result);
}
\f
! /* Fill in a VMS descriptor for EXPR and return a constructor for it.
GNAT_FORMAL is how we find the descriptor record. */
tree
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.36
diff -u -c -3 -p -r1.36 utils.c
*** utils.c 31 Oct 2003 01:08:43 -0000 1.36
--- utils.c 4 Nov 2003 12:49:15 -0000
*************** build_vms_descriptor (tree type, Mechani
*** 2306,2312 ****
case INTEGER_TYPE:
case ENUMERAL_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
! switch ((int) TYPE_DIGITS_VALUE (type))
{
case 6:
dtype = 10;
--- 2306,2312 ----
case INTEGER_TYPE:
case ENUMERAL_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
! switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
{
case 6:
dtype = 10;
*************** build_vms_descriptor (tree type, Mechani
*** 2346,2352 ****
case COMPLEX_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type))
! switch ((int) TYPE_DIGITS_VALUE (type))
{
case 6:
dtype = 12;
--- 2346,2352 ----
case COMPLEX_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type))
! switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
{
case 6:
dtype = 12;
*************** build_vms_descriptor (tree type, Mechani
*** 2544,2550 ****
/* Utility routine for above code to make a field. */
static tree
! make_descriptor_field (const char *name, tree type, tree rec_type, tree initial)
{
tree field
= create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
--- 2544,2551 ----
/* Utility routine for above code to make a field. */
static tree
! make_descriptor_field (const char *name, tree type,
! tree rec_type, tree initial)
{
tree field
= create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
Index: einfo.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.h,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 einfo.h
*** einfo.h 29 Oct 2003 10:26:16 -0000 1.10
--- einfo.h 4 Nov 2003 12:49:16 -0000
***************
*** 450,455 ****
--- 450,456 ----
INLINE B Is_Statically_Allocated (E Id);
INLINE B Is_Tag (E Id);
INLINE B Is_Tagged_Type (E Id);
+ INLINE B Is_Thread_Body (E Id);
INLINE B Is_True_Constant (E Id);
INLINE B Is_Unchecked_Union (E Id);
INLINE B Is_Unsigned_Type (E Id);
***************
*** 1437,1442 ****
--- 1438,1446 ----
INLINE B Is_Tagged_Type (E Id)
{ return Flag55 (Id); }
+
+ INLINE B Is_Thread_Body (E Id)
+ { return Flag77 (Id); }
INLINE B Is_True_Constant (E Id)
{ return Flag163 (Id); }
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.12
retrieving revision 1.14
diff -u -c -3 -p -r1.12 -r1.14
*** snames.ads 21 Oct 2003 13:42:22 -0000 1.12
--- snames.ads 4 Nov 2003 12:56:59 -0000 1.14
*************** package Snames is
*** 145,152 ****
-- at the start of these names get translated to extra underscores. These
-- names are only referenced internally by expander generated code.
! Name_uAlignment : constant Name_Id := N + 005;
! Name_uAbort_Signal : constant Name_Id := N + 006;
Name_uAssign : constant Name_Id := N + 007;
Name_uChain : constant Name_Id := N + 008;
Name_uClean : constant Name_Id := N + 009;
--- 145,152 ----
-- at the start of these names get translated to extra underscores. These
-- names are only referenced internally by expander generated code.
! Name_uAbort_Signal : constant Name_Id := N + 005;
! Name_uAlignment : constant Name_Id := N + 006;
Name_uAssign : constant Name_Id := N + 007;
Name_uChain : constant Name_Id := N + 008;
Name_uClean : constant Name_Id := N + 009;
*************** package Snames is
*** 160,272 ****
Name_uMaster : constant Name_Id := N + 017;
Name_uObject : constant Name_Id := N + 018;
Name_uPriority : constant Name_Id := N + 019;
! Name_uService : constant Name_Id := N + 020;
! Name_uSize : constant Name_Id := N + 021;
! Name_uTags : constant Name_Id := N + 022;
! Name_uTask : constant Name_Id := N + 023;
! Name_uTask_Id : constant Name_Id := N + 024;
! Name_uTask_Info : constant Name_Id := N + 025;
! Name_uTask_Name : constant Name_Id := N + 026;
! Name_uTrace_Sp : constant Name_Id := N + 027;
-- Names of routines in Ada.Finalization, needed by expander
! Name_Initialize : constant Name_Id := N + 028;
! Name_Adjust : constant Name_Id := N + 029;
! Name_Finalize : constant Name_Id := N + 030;
-- Names of fields declared in System.Finalization_Implementation,
-- needed by the expander when generating code for finalization.
! Name_Next : constant Name_Id := N + 031;
! Name_Prev : constant Name_Id := N + 032;
-- Names of allocation routines, also needed by expander
! Name_Allocate : constant Name_Id := N + 033;
! Name_Deallocate : constant Name_Id := N + 034;
! Name_Dereference : constant Name_Id := N + 035;
-- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
! First_Text_IO_Package : constant Name_Id := N + 036;
! Name_Decimal_IO : constant Name_Id := N + 036;
! Name_Enumeration_IO : constant Name_Id := N + 037;
! Name_Fixed_IO : constant Name_Id := N + 038;
! Name_Float_IO : constant Name_Id := N + 039;
! Name_Integer_IO : constant Name_Id := N + 040;
! Name_Modular_IO : constant Name_Id := N + 041;
! Last_Text_IO_Package : constant Name_Id := N + 041;
subtype Text_IO_Package_Name is Name_Id
range First_Text_IO_Package .. Last_Text_IO_Package;
-- Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO
! Name_a_textio : constant Name_Id := N + 042;
! Name_a_witeio : constant Name_Id := N + 043;
-- Some miscellaneous names used for error detection/recovery
! Name_Const : constant Name_Id := N + 044;
! Name_Error : constant Name_Id := N + 045;
! Name_Go : constant Name_Id := N + 046;
! Name_Put : constant Name_Id := N + 047;
! Name_Put_Line : constant Name_Id := N + 048;
! Name_To : constant Name_Id := N + 049;
-- Names for packages that are treated specially by the compiler
! Name_Finalization : constant Name_Id := N + 050;
! Name_Finalization_Root : constant Name_Id := N + 051;
! Name_Interfaces : constant Name_Id := N + 052;
! Name_Standard : constant Name_Id := N + 053;
! Name_System : constant Name_Id := N + 054;
! Name_Text_IO : constant Name_Id := N + 055;
! Name_Wide_Text_IO : constant Name_Id := N + 056;
-- Names of identifiers used in expanding distribution stubs
! Name_Addr : constant Name_Id := N + 057;
! Name_Async : constant Name_Id := N + 058;
! Name_Get_Active_Partition_ID : constant Name_Id := N + 059;
! Name_Get_RCI_Package_Receiver : constant Name_Id := N + 060;
! Name_Origin : constant Name_Id := N + 061;
! Name_Params : constant Name_Id := N + 062;
! Name_Partition : constant Name_Id := N + 063;
! Name_Partition_Interface : constant Name_Id := N + 064;
! Name_Ras : constant Name_Id := N + 065;
! Name_RCI_Name : constant Name_Id := N + 066;
! Name_Receiver : constant Name_Id := N + 067;
! Name_Result : constant Name_Id := N + 068;
! Name_Rpc : constant Name_Id := N + 069;
! Name_Subp_Id : constant Name_Id := N + 070;
-- Operator Symbol entries. The actual names have an upper case O at
-- the start in place of the Op_ prefix (e.g. the actual name that
-- corresponds to Name_Op_Abs is "Oabs".
! First_Operator_Name : constant Name_Id := N + 071;
! Name_Op_Abs : constant Name_Id := N + 071; -- "abs"
! Name_Op_And : constant Name_Id := N + 072; -- "and"
! Name_Op_Mod : constant Name_Id := N + 073; -- "mod"
! Name_Op_Not : constant Name_Id := N + 074; -- "not"
! Name_Op_Or : constant Name_Id := N + 075; -- "or"
! Name_Op_Rem : constant Name_Id := N + 076; -- "rem"
! Name_Op_Xor : constant Name_Id := N + 077; -- "xor"
! Name_Op_Eq : constant Name_Id := N + 078; -- "="
! Name_Op_Ne : constant Name_Id := N + 079; -- "/="
! Name_Op_Lt : constant Name_Id := N + 080; -- "<"
! Name_Op_Le : constant Name_Id := N + 081; -- "<="
! Name_Op_Gt : constant Name_Id := N + 082; -- ">"
! Name_Op_Ge : constant Name_Id := N + 083; -- ">="
! Name_Op_Add : constant Name_Id := N + 084; -- "+"
! Name_Op_Subtract : constant Name_Id := N + 085; -- "-"
! Name_Op_Concat : constant Name_Id := N + 086; -- "&"
! Name_Op_Multiply : constant Name_Id := N + 087; -- "*"
! Name_Op_Divide : constant Name_Id := N + 088; -- "/"
! Name_Op_Expon : constant Name_Id := N + 089; -- "**"
! Last_Operator_Name : constant Name_Id := N + 089;
-- Names for all pragmas recognized by GNAT. The entries with the comment
-- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
--- 160,274 ----
Name_uMaster : constant Name_Id := N + 017;
Name_uObject : constant Name_Id := N + 018;
Name_uPriority : constant Name_Id := N + 019;
! Name_uProcess_ATSD : constant Name_Id := N + 020;
! Name_uSecondary_Stack : constant Name_Id := N + 021;
! Name_uService : constant Name_Id := N + 022;
! Name_uSize : constant Name_Id := N + 023;
! Name_uTags : constant Name_Id := N + 024;
! Name_uTask : constant Name_Id := N + 025;
! Name_uTask_Id : constant Name_Id := N + 026;
! Name_uTask_Info : constant Name_Id := N + 027;
! Name_uTask_Name : constant Name_Id := N + 028;
! Name_uTrace_Sp : constant Name_Id := N + 029;
-- Names of routines in Ada.Finalization, needed by expander
! Name_Initialize : constant Name_Id := N + 030;
! Name_Adjust : constant Name_Id := N + 031;
! Name_Finalize : constant Name_Id := N + 032;
-- Names of fields declared in System.Finalization_Implementation,
-- needed by the expander when generating code for finalization.
! Name_Next : constant Name_Id := N + 033;
! Name_Prev : constant Name_Id := N + 034;
-- Names of allocation routines, also needed by expander
! Name_Allocate : constant Name_Id := N + 035;
! Name_Deallocate : constant Name_Id := N + 036;
! Name_Dereference : constant Name_Id := N + 037;
-- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
! First_Text_IO_Package : constant Name_Id := N + 038;
! Name_Decimal_IO : constant Name_Id := N + 038;
! Name_Enumeration_IO : constant Name_Id := N + 039;
! Name_Fixed_IO : constant Name_Id := N + 040;
! Name_Float_IO : constant Name_Id := N + 041;
! Name_Integer_IO : constant Name_Id := N + 042;
! Name_Modular_IO : constant Name_Id := N + 043;
! Last_Text_IO_Package : constant Name_Id := N + 043;
subtype Text_IO_Package_Name is Name_Id
range First_Text_IO_Package .. Last_Text_IO_Package;
-- Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO
! Name_a_textio : constant Name_Id := N + 044;
! Name_a_witeio : constant Name_Id := N + 045;
-- Some miscellaneous names used for error detection/recovery
! Name_Const : constant Name_Id := N + 046;
! Name_Error : constant Name_Id := N + 047;
! Name_Go : constant Name_Id := N + 048;
! Name_Put : constant Name_Id := N + 049;
! Name_Put_Line : constant Name_Id := N + 050;
! Name_To : constant Name_Id := N + 051;
-- Names for packages that are treated specially by the compiler
! Name_Finalization : constant Name_Id := N + 052;
! Name_Finalization_Root : constant Name_Id := N + 053;
! Name_Interfaces : constant Name_Id := N + 054;
! Name_Standard : constant Name_Id := N + 055;
! Name_System : constant Name_Id := N + 056;
! Name_Text_IO : constant Name_Id := N + 057;
! Name_Wide_Text_IO : constant Name_Id := N + 058;
-- Names of identifiers used in expanding distribution stubs
! Name_Addr : constant Name_Id := N + 059;
! Name_Async : constant Name_Id := N + 060;
! Name_Get_Active_Partition_ID : constant Name_Id := N + 061;
! Name_Get_RCI_Package_Receiver : constant Name_Id := N + 062;
! Name_Origin : constant Name_Id := N + 063;
! Name_Params : constant Name_Id := N + 064;
! Name_Partition : constant Name_Id := N + 065;
! Name_Partition_Interface : constant Name_Id := N + 066;
! Name_Ras : constant Name_Id := N + 067;
! Name_RCI_Name : constant Name_Id := N + 068;
! Name_Receiver : constant Name_Id := N + 069;
! Name_Result : constant Name_Id := N + 070;
! Name_Rpc : constant Name_Id := N + 071;
! Name_Subp_Id : constant Name_Id := N + 072;
-- Operator Symbol entries. The actual names have an upper case O at
-- the start in place of the Op_ prefix (e.g. the actual name that
-- corresponds to Name_Op_Abs is "Oabs".
! First_Operator_Name : constant Name_Id := N + 073;
! Name_Op_Abs : constant Name_Id := N + 073; -- "abs"
! Name_Op_And : constant Name_Id := N + 074; -- "and"
! Name_Op_Mod : constant Name_Id := N + 075; -- "mod"
! Name_Op_Not : constant Name_Id := N + 076; -- "not"
! Name_Op_Or : constant Name_Id := N + 077; -- "or"
! Name_Op_Rem : constant Name_Id := N + 078; -- "rem"
! Name_Op_Xor : constant Name_Id := N + 079; -- "xor"
! Name_Op_Eq : constant Name_Id := N + 080; -- "="
! Name_Op_Ne : constant Name_Id := N + 081; -- "/="
! Name_Op_Lt : constant Name_Id := N + 082; -- "<"
! Name_Op_Le : constant Name_Id := N + 083; -- "<="
! Name_Op_Gt : constant Name_Id := N + 084; -- ">"
! Name_Op_Ge : constant Name_Id := N + 085; -- ">="
! Name_Op_Add : constant Name_Id := N + 086; -- "+"
! Name_Op_Subtract : constant Name_Id := N + 087; -- "-"
! Name_Op_Concat : constant Name_Id := N + 088; -- "&"
! Name_Op_Multiply : constant Name_Id := N + 089; -- "*"
! Name_Op_Divide : constant Name_Id := N + 090; -- "/"
! Name_Op_Expon : constant Name_Id := N + 091; -- "**"
! Last_Operator_Name : constant Name_Id := N + 091;
-- Names for all pragmas recognized by GNAT. The entries with the comment
-- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
*************** package Snames is
*** 286,344 ****
-- only in GNAT for the AAMP. They are ignored in other versions with
-- appropriate warnings.
! First_Pragma_Name : constant Name_Id := N + 090;
-- Configuration pragmas are grouped at start
! Name_Ada_83 : constant Name_Id := N + 090; -- GNAT
! Name_Ada_95 : constant Name_Id := N + 091; -- GNAT
! Name_C_Pass_By_Copy : constant Name_Id := N + 092; -- GNAT
! Name_Compile_Time_Warning : constant Name_Id := N + 093; -- GNAT
! Name_Component_Alignment : constant Name_Id := N + 094; -- GNAT
! Name_Convention_Identifier : constant Name_Id := N + 095; -- GNAT
! Name_Discard_Names : constant Name_Id := N + 096;
! Name_Elaboration_Checks : constant Name_Id := N + 097; -- GNAT
! Name_Eliminate : constant Name_Id := N + 098; -- GNAT
! Name_Explicit_Overriding : constant Name_Id := N + 099;
! Name_Extend_System : constant Name_Id := N + 100; -- GNAT
! Name_Extensions_Allowed : constant Name_Id := N + 101; -- GNAT
! Name_External_Name_Casing : constant Name_Id := N + 102; -- GNAT
! Name_Float_Representation : constant Name_Id := N + 103; -- GNAT
! Name_Initialize_Scalars : constant Name_Id := N + 104; -- GNAT
! Name_Interrupt_State : constant Name_Id := N + 105; -- GNAT
! Name_License : constant Name_Id := N + 106; -- GNAT
! Name_Locking_Policy : constant Name_Id := N + 107;
! Name_Long_Float : constant Name_Id := N + 108; -- VMS
! Name_No_Run_Time : constant Name_Id := N + 109; -- GNAT
! Name_Normalize_Scalars : constant Name_Id := N + 110;
! Name_Polling : constant Name_Id := N + 111; -- GNAT
! Name_Persistent_Data : constant Name_Id := N + 112; -- GNAT
! Name_Persistent_Object : constant Name_Id := N + 113; -- GNAT
! Name_Propagate_Exceptions : constant Name_Id := N + 114; -- GNAT
! Name_Queuing_Policy : constant Name_Id := N + 115;
! Name_Ravenscar : constant Name_Id := N + 116;
! Name_Restricted_Run_Time : constant Name_Id := N + 117;
! Name_Restrictions : constant Name_Id := N + 118;
! Name_Restriction_Warnings : constant Name_Id := N + 119; -- GNAT
! Name_Reviewable : constant Name_Id := N + 120;
! Name_Source_File_Name : constant Name_Id := N + 121; -- GNAT
! Name_Source_File_Name_Project : constant Name_Id := N + 122; -- GNAT
! Name_Style_Checks : constant Name_Id := N + 123; -- GNAT
! Name_Suppress : constant Name_Id := N + 124;
! Name_Suppress_Exception_Locations : constant Name_Id := N + 125; -- GNAT
! Name_Task_Dispatching_Policy : constant Name_Id := N + 126;
! Name_Universal_Data : constant Name_Id := N + 127; -- AAMP
! Name_Unsuppress : constant Name_Id := N + 128; -- GNAT
! Name_Use_VADS_Size : constant Name_Id := N + 129; -- GNAT
! Name_Validity_Checks : constant Name_Id := N + 130; -- GNAT
! Name_Warnings : constant Name_Id := N + 131; -- GNAT
! Last_Configuration_Pragma_Name : constant Name_Id := N + 131;
-- Remaining pragma names
! Name_Abort_Defer : constant Name_Id := N + 132; -- GNAT
! Name_All_Calls_Remote : constant Name_Id := N + 133;
! Name_Annotate : constant Name_Id := N + 134; -- GNAT
-- Note: AST_Entry is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
--- 288,346 ----
-- only in GNAT for the AAMP. They are ignored in other versions with
-- appropriate warnings.
! First_Pragma_Name : constant Name_Id := N + 092;
-- Configuration pragmas are grouped at start
! Name_Ada_83 : constant Name_Id := N + 092; -- GNAT
! Name_Ada_95 : constant Name_Id := N + 093; -- GNAT
! Name_C_Pass_By_Copy : constant Name_Id := N + 094; -- GNAT
! Name_Compile_Time_Warning : constant Name_Id := N + 095; -- GNAT
! Name_Component_Alignment : constant Name_Id := N + 096; -- GNAT
! Name_Convention_Identifier : constant Name_Id := N + 097; -- GNAT
! Name_Discard_Names : constant Name_Id := N + 098;
! Name_Elaboration_Checks : constant Name_Id := N + 099; -- GNAT
! Name_Eliminate : constant Name_Id := N + 100; -- GNAT
! Name_Explicit_Overriding : constant Name_Id := N + 101;
! Name_Extend_System : constant Name_Id := N + 102; -- GNAT
! Name_Extensions_Allowed : constant Name_Id := N + 103; -- GNAT
! Name_External_Name_Casing : constant Name_Id := N + 104; -- GNAT
! Name_Float_Representation : constant Name_Id := N + 105; -- GNAT
! Name_Initialize_Scalars : constant Name_Id := N + 106; -- GNAT
! Name_Interrupt_State : constant Name_Id := N + 107; -- GNAT
! Name_License : constant Name_Id := N + 108; -- GNAT
! Name_Locking_Policy : constant Name_Id := N + 109;
! Name_Long_Float : constant Name_Id := N + 110; -- VMS
! Name_No_Run_Time : constant Name_Id := N + 111; -- GNAT
! Name_Normalize_Scalars : constant Name_Id := N + 112;
! Name_Polling : constant Name_Id := N + 113; -- GNAT
! Name_Persistent_Data : constant Name_Id := N + 114; -- GNAT
! Name_Persistent_Object : constant Name_Id := N + 115; -- GNAT
! Name_Propagate_Exceptions : constant Name_Id := N + 116; -- GNAT
! Name_Queuing_Policy : constant Name_Id := N + 117;
! Name_Ravenscar : constant Name_Id := N + 118;
! Name_Restricted_Run_Time : constant Name_Id := N + 119;
! Name_Restrictions : constant Name_Id := N + 120;
! Name_Restriction_Warnings : constant Name_Id := N + 121; -- GNAT
! Name_Reviewable : constant Name_Id := N + 122;
! Name_Source_File_Name : constant Name_Id := N + 123; -- GNAT
! Name_Source_File_Name_Project : constant Name_Id := N + 124; -- GNAT
! Name_Style_Checks : constant Name_Id := N + 125; -- GNAT
! Name_Suppress : constant Name_Id := N + 126;
! Name_Suppress_Exception_Locations : constant Name_Id := N + 127; -- GNAT
! Name_Task_Dispatching_Policy : constant Name_Id := N + 128;
! Name_Universal_Data : constant Name_Id := N + 129; -- AAMP
! Name_Unsuppress : constant Name_Id := N + 130; -- GNAT
! Name_Use_VADS_Size : constant Name_Id := N + 131; -- GNAT
! Name_Validity_Checks : constant Name_Id := N + 132; -- GNAT
! Name_Warnings : constant Name_Id := N + 133; -- GNAT
! Last_Configuration_Pragma_Name : constant Name_Id := N + 133;
-- Remaining pragma names
! Name_Abort_Defer : constant Name_Id := N + 134; -- GNAT
! Name_All_Calls_Remote : constant Name_Id := N + 135;
! Name_Annotate : constant Name_Id := N + 136; -- GNAT
-- Note: AST_Entry is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
*************** package Snames is
*** 346,423 ****
-- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
-- AST_Entry is a VMS specific pragma.
! Name_Assert : constant Name_Id := N + 135; -- GNAT
! Name_Asynchronous : constant Name_Id := N + 136;
! Name_Atomic : constant Name_Id := N + 137;
! Name_Atomic_Components : constant Name_Id := N + 138;
! Name_Attach_Handler : constant Name_Id := N + 139;
! Name_Comment : constant Name_Id := N + 140; -- GNAT
! Name_Common_Object : constant Name_Id := N + 141; -- GNAT
! Name_Complex_Representation : constant Name_Id := N + 142; -- GNAT
! Name_Controlled : constant Name_Id := N + 143;
! Name_Convention : constant Name_Id := N + 144;
! Name_CPP_Class : constant Name_Id := N + 145; -- GNAT
! Name_CPP_Constructor : constant Name_Id := N + 146; -- GNAT
! Name_CPP_Virtual : constant Name_Id := N + 147; -- GNAT
! Name_CPP_Vtable : constant Name_Id := N + 148; -- GNAT
! Name_Debug : constant Name_Id := N + 149; -- GNAT
! Name_Elaborate : constant Name_Id := N + 150; -- Ada 83
! Name_Elaborate_All : constant Name_Id := N + 151;
! Name_Elaborate_Body : constant Name_Id := N + 152;
! Name_Export : constant Name_Id := N + 153;
! Name_Export_Exception : constant Name_Id := N + 154; -- VMS
! Name_Export_Function : constant Name_Id := N + 155; -- GNAT
! Name_Export_Object : constant Name_Id := N + 156; -- GNAT
! Name_Export_Procedure : constant Name_Id := N + 157; -- GNAT
! Name_Export_Value : constant Name_Id := N + 158; -- GNAT
! Name_Export_Valued_Procedure : constant Name_Id := N + 159; -- GNAT
! Name_External : constant Name_Id := N + 160; -- GNAT
! Name_Finalize_Storage_Only : constant Name_Id := N + 161; -- GNAT
! Name_Ident : constant Name_Id := N + 162; -- VMS
! Name_Import : constant Name_Id := N + 163;
! Name_Import_Exception : constant Name_Id := N + 164; -- VMS
! Name_Import_Function : constant Name_Id := N + 165; -- GNAT
! Name_Import_Object : constant Name_Id := N + 166; -- GNAT
! Name_Import_Procedure : constant Name_Id := N + 167; -- GNAT
! Name_Import_Valued_Procedure : constant Name_Id := N + 168; -- GNAT
! Name_Inline : constant Name_Id := N + 169;
! Name_Inline_Always : constant Name_Id := N + 170; -- GNAT
! Name_Inline_Generic : constant Name_Id := N + 171; -- GNAT
! Name_Inspection_Point : constant Name_Id := N + 172;
! Name_Interface : constant Name_Id := N + 173; -- Ada 83
! Name_Interface_Name : constant Name_Id := N + 174; -- GNAT
! Name_Interrupt_Handler : constant Name_Id := N + 175;
! Name_Interrupt_Priority : constant Name_Id := N + 176;
! Name_Java_Constructor : constant Name_Id := N + 177; -- GNAT
! Name_Java_Interface : constant Name_Id := N + 178; -- GNAT
! Name_Keep_Names : constant Name_Id := N + 179; -- GNAT
! Name_Link_With : constant Name_Id := N + 180; -- GNAT
! Name_Linker_Alias : constant Name_Id := N + 181; -- GNAT
! Name_Linker_Options : constant Name_Id := N + 182;
! Name_Linker_Section : constant Name_Id := N + 183; -- GNAT
! Name_List : constant Name_Id := N + 184;
! Name_Machine_Attribute : constant Name_Id := N + 185; -- GNAT
! Name_Main : constant Name_Id := N + 186; -- GNAT
! Name_Main_Storage : constant Name_Id := N + 187; -- GNAT
! Name_Memory_Size : constant Name_Id := N + 188; -- Ada 83
! Name_No_Return : constant Name_Id := N + 189; -- GNAT
! Name_Obsolescent : constant Name_Id := N + 190; -- GNAT
! Name_Optimize : constant Name_Id := N + 191;
! Name_Optional_Overriding : constant Name_Id := N + 192;
! Name_Overriding : constant Name_Id := N + 193;
! Name_Pack : constant Name_Id := N + 194;
! Name_Page : constant Name_Id := N + 195;
! Name_Passive : constant Name_Id := N + 196; -- GNAT
! Name_Preelaborate : constant Name_Id := N + 197;
! Name_Priority : constant Name_Id := N + 198;
! Name_Psect_Object : constant Name_Id := N + 199; -- VMS
! Name_Pure : constant Name_Id := N + 200;
! Name_Pure_Function : constant Name_Id := N + 201; -- GNAT
! Name_Remote_Call_Interface : constant Name_Id := N + 202;
! Name_Remote_Types : constant Name_Id := N + 203;
! Name_Share_Generic : constant Name_Id := N + 204; -- GNAT
! Name_Shared : constant Name_Id := N + 205; -- Ada 83
! Name_Shared_Passive : constant Name_Id := N + 206;
-- Note: Storage_Size is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
--- 348,425 ----
-- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
-- AST_Entry is a VMS specific pragma.
! Name_Assert : constant Name_Id := N + 137; -- GNAT
! Name_Asynchronous : constant Name_Id := N + 138;
! Name_Atomic : constant Name_Id := N + 139;
! Name_Atomic_Components : constant Name_Id := N + 140;
! Name_Attach_Handler : constant Name_Id := N + 141;
! Name_Comment : constant Name_Id := N + 142; -- GNAT
! Name_Common_Object : constant Name_Id := N + 143; -- GNAT
! Name_Complex_Representation : constant Name_Id := N + 144; -- GNAT
! Name_Controlled : constant Name_Id := N + 145;
! Name_Convention : constant Name_Id := N + 146;
! Name_CPP_Class : constant Name_Id := N + 147; -- GNAT
! Name_CPP_Constructor : constant Name_Id := N + 148; -- GNAT
! Name_CPP_Virtual : constant Name_Id := N + 149; -- GNAT
! Name_CPP_Vtable : constant Name_Id := N + 150; -- GNAT
! Name_Debug : constant Name_Id := N + 151; -- GNAT
! Name_Elaborate : constant Name_Id := N + 152; -- Ada 83
! Name_Elaborate_All : constant Name_Id := N + 153;
! Name_Elaborate_Body : constant Name_Id := N + 154;
! Name_Export : constant Name_Id := N + 155;
! Name_Export_Exception : constant Name_Id := N + 156; -- VMS
! Name_Export_Function : constant Name_Id := N + 157; -- GNAT
! Name_Export_Object : constant Name_Id := N + 158; -- GNAT
! Name_Export_Procedure : constant Name_Id := N + 159; -- GNAT
! Name_Export_Value : constant Name_Id := N + 160; -- GNAT
! Name_Export_Valued_Procedure : constant Name_Id := N + 161; -- GNAT
! Name_External : constant Name_Id := N + 162; -- GNAT
! Name_Finalize_Storage_Only : constant Name_Id := N + 163; -- GNAT
! Name_Ident : constant Name_Id := N + 164; -- VMS
! Name_Import : constant Name_Id := N + 165;
! Name_Import_Exception : constant Name_Id := N + 166; -- VMS
! Name_Import_Function : constant Name_Id := N + 167; -- GNAT
! Name_Import_Object : constant Name_Id := N + 168; -- GNAT
! Name_Import_Procedure : constant Name_Id := N + 169; -- GNAT
! Name_Import_Valued_Procedure : constant Name_Id := N + 170; -- GNAT
! Name_Inline : constant Name_Id := N + 171;
! Name_Inline_Always : constant Name_Id := N + 172; -- GNAT
! Name_Inline_Generic : constant Name_Id := N + 173; -- GNAT
! Name_Inspection_Point : constant Name_Id := N + 174;
! Name_Interface : constant Name_Id := N + 175; -- Ada 83
! Name_Interface_Name : constant Name_Id := N + 176; -- GNAT
! Name_Interrupt_Handler : constant Name_Id := N + 177;
! Name_Interrupt_Priority : constant Name_Id := N + 178;
! Name_Java_Constructor : constant Name_Id := N + 179; -- GNAT
! Name_Java_Interface : constant Name_Id := N + 180; -- GNAT
! Name_Keep_Names : constant Name_Id := N + 181; -- GNAT
! Name_Link_With : constant Name_Id := N + 182; -- GNAT
! Name_Linker_Alias : constant Name_Id := N + 183; -- GNAT
! Name_Linker_Options : constant Name_Id := N + 184;
! Name_Linker_Section : constant Name_Id := N + 185; -- GNAT
! Name_List : constant Name_Id := N + 186;
! Name_Machine_Attribute : constant Name_Id := N + 187; -- GNAT
! Name_Main : constant Name_Id := N + 188; -- GNAT
! Name_Main_Storage : constant Name_Id := N + 189; -- GNAT
! Name_Memory_Size : constant Name_Id := N + 190; -- Ada 83
! Name_No_Return : constant Name_Id := N + 191; -- GNAT
! Name_Obsolescent : constant Name_Id := N + 192; -- GNAT
! Name_Optimize : constant Name_Id := N + 193;
! Name_Optional_Overriding : constant Name_Id := N + 194;
! Name_Overriding : constant Name_Id := N + 195;
! Name_Pack : constant Name_Id := N + 196;
! Name_Page : constant Name_Id := N + 197;
! Name_Passive : constant Name_Id := N + 198; -- GNAT
! Name_Preelaborate : constant Name_Id := N + 199;
! Name_Priority : constant Name_Id := N + 200;
! Name_Psect_Object : constant Name_Id := N + 201; -- VMS
! Name_Pure : constant Name_Id := N + 202;
! Name_Pure_Function : constant Name_Id := N + 203; -- GNAT
! Name_Remote_Call_Interface : constant Name_Id := N + 204;
! Name_Remote_Types : constant Name_Id := N + 205;
! Name_Share_Generic : constant Name_Id := N + 206; -- GNAT
! Name_Shared : constant Name_Id := N + 207; -- Ada 83
! Name_Shared_Passive : constant Name_Id := N + 208;
-- Note: Storage_Size is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
*************** package Snames is
*** 427,452 ****
-- Note: Storage_Unit is also omitted from the list because of a clash
-- with an attribute name, and is treated similarly.
! Name_Source_Reference : constant Name_Id := N + 207; -- GNAT
! Name_Stream_Convert : constant Name_Id := N + 208; -- GNAT
! Name_Subtitle : constant Name_Id := N + 209; -- GNAT
! Name_Suppress_All : constant Name_Id := N + 210; -- GNAT
! Name_Suppress_Debug_Info : constant Name_Id := N + 211; -- GNAT
! Name_Suppress_Initialization : constant Name_Id := N + 212; -- GNAT
! Name_System_Name : constant Name_Id := N + 213; -- Ada 83
! Name_Task_Info : constant Name_Id := N + 214; -- GNAT
! Name_Task_Name : constant Name_Id := N + 215; -- GNAT
! Name_Task_Storage : constant Name_Id := N + 216; -- VMS
! Name_Time_Slice : constant Name_Id := N + 217; -- GNAT
! Name_Title : constant Name_Id := N + 218; -- GNAT
! Name_Unchecked_Union : constant Name_Id := N + 219; -- GNAT
! Name_Unimplemented_Unit : constant Name_Id := N + 220; -- GNAT
! Name_Unreferenced : constant Name_Id := N + 221; -- GNAT
! Name_Unreserve_All_Interrupts : constant Name_Id := N + 222; -- GNAT
! Name_Volatile : constant Name_Id := N + 223;
! Name_Volatile_Components : constant Name_Id := N + 224;
! Name_Weak_External : constant Name_Id := N + 225; -- GNAT
! Last_Pragma_Name : constant Name_Id := N + 225;
-- Language convention names for pragma Convention/Export/Import/Interface
-- Note that Name_C is not included in this list, since it was already
--- 429,455 ----
-- Note: Storage_Unit is also omitted from the list because of a clash
-- with an attribute name, and is treated similarly.
! Name_Source_Reference : constant Name_Id := N + 209; -- GNAT
! Name_Stream_Convert : constant Name_Id := N + 210; -- GNAT
! Name_Subtitle : constant Name_Id := N + 211; -- GNAT
! Name_Suppress_All : constant Name_Id := N + 212; -- GNAT
! Name_Suppress_Debug_Info : constant Name_Id := N + 213; -- GNAT
! Name_Suppress_Initialization : constant Name_Id := N + 214; -- GNAT
! Name_System_Name : constant Name_Id := N + 215; -- Ada 83
! Name_Task_Info : constant Name_Id := N + 216; -- GNAT
! Name_Task_Name : constant Name_Id := N + 217; -- GNAT
! Name_Task_Storage : constant Name_Id := N + 218; -- VMS
! Name_Thread_Body : constant Name_Id := N + 219; -- GNAT
! Name_Time_Slice : constant Name_Id := N + 220; -- GNAT
! Name_Title : constant Name_Id := N + 221; -- GNAT
! Name_Unchecked_Union : constant Name_Id := N + 222; -- GNAT
! Name_Unimplemented_Unit : constant Name_Id := N + 223; -- GNAT
! Name_Unreferenced : constant Name_Id := N + 224; -- GNAT
! Name_Unreserve_All_Interrupts : constant Name_Id := N + 225; -- GNAT
! Name_Volatile : constant Name_Id := N + 226;
! Name_Volatile_Components : constant Name_Id := N + 227;
! Name_Weak_External : constant Name_Id := N + 228; -- GNAT
! Last_Pragma_Name : constant Name_Id := N + 228;
-- Language convention names for pragma Convention/Export/Import/Interface
-- Note that Name_C is not included in this list, since it was already
*************** package Snames is
*** 457,551 ****
-- Entry and Protected, this is because these conventions cannot be
-- specified by a pragma.
! First_Convention_Name : constant Name_Id := N + 226;
! Name_Ada : constant Name_Id := N + 226;
! Name_Assembler : constant Name_Id := N + 227;
! Name_COBOL : constant Name_Id := N + 228;
! Name_CPP : constant Name_Id := N + 229;
! Name_Fortran : constant Name_Id := N + 230;
! Name_Intrinsic : constant Name_Id := N + 231;
! Name_Java : constant Name_Id := N + 232;
! Name_Stdcall : constant Name_Id := N + 233;
! Name_Stubbed : constant Name_Id := N + 234;
! Last_Convention_Name : constant Name_Id := N + 234;
-- The following names are preset as synonyms for Assembler
! Name_Asm : constant Name_Id := N + 235;
! Name_Assembly : constant Name_Id := N + 236;
-- The following names are preset as synonyms for C
! Name_Default : constant Name_Id := N + 237;
-- Name_Exernal (previously defined as pragma)
-- The following names are present as synonyms for Stdcall
! Name_DLL : constant Name_Id := N + 238;
! Name_Win32 : constant Name_Id := N + 239;
-- Other special names used in processing pragma arguments
! Name_As_Is : constant Name_Id := N + 240;
! Name_Body_File_Name : constant Name_Id := N + 241;
! Name_Casing : constant Name_Id := N + 242;
! Name_Code : constant Name_Id := N + 243;
! Name_Component : constant Name_Id := N + 244;
! Name_Component_Size_4 : constant Name_Id := N + 245;
! Name_Copy : constant Name_Id := N + 246;
! Name_D_Float : constant Name_Id := N + 247;
! Name_Descriptor : constant Name_Id := N + 248;
! Name_Dot_Replacement : constant Name_Id := N + 249;
! Name_Dynamic : constant Name_Id := N + 250;
! Name_Entity : constant Name_Id := N + 251;
! Name_External_Name : constant Name_Id := N + 252;
! Name_First_Optional_Parameter : constant Name_Id := N + 253;
! Name_Form : constant Name_Id := N + 254;
! Name_G_Float : constant Name_Id := N + 255;
! Name_Gcc : constant Name_Id := N + 256;
! Name_Gnat : constant Name_Id := N + 257;
! Name_GPL : constant Name_Id := N + 258;
! Name_IEEE_Float : constant Name_Id := N + 259;
! Name_Homonym_Number : constant Name_Id := N + 260;
! Name_Internal : constant Name_Id := N + 261;
! Name_Link_Name : constant Name_Id := N + 262;
! Name_Lowercase : constant Name_Id := N + 263;
! Name_Max_Size : constant Name_Id := N + 264;
! Name_Mechanism : constant Name_Id := N + 265;
! Name_Mixedcase : constant Name_Id := N + 266;
! Name_Modified_GPL : constant Name_Id := N + 267;
! Name_Name : constant Name_Id := N + 268;
! Name_NCA : constant Name_Id := N + 269;
! Name_No : constant Name_Id := N + 270;
! Name_On : constant Name_Id := N + 271;
! Name_Parameter_Types : constant Name_Id := N + 272;
! Name_Reference : constant Name_Id := N + 273;
! Name_Restricted : constant Name_Id := N + 274;
! Name_Result_Mechanism : constant Name_Id := N + 275;
! Name_Result_Type : constant Name_Id := N + 276;
! Name_Runtime : constant Name_Id := N + 277;
! Name_SB : constant Name_Id := N + 278;
! Name_Section : constant Name_Id := N + 279;
! Name_Semaphore : constant Name_Id := N + 280;
! Name_Spec_File_Name : constant Name_Id := N + 281;
! Name_Static : constant Name_Id := N + 282;
! Name_Stack_Size : constant Name_Id := N + 283;
! Name_Subunit_File_Name : constant Name_Id := N + 284;
! Name_Task_Stack_Size_Default : constant Name_Id := N + 285;
! Name_Task_Type : constant Name_Id := N + 286;
! Name_Time_Slicing_Enabled : constant Name_Id := N + 287;
! Name_Top_Guard : constant Name_Id := N + 288;
! Name_UBA : constant Name_Id := N + 289;
! Name_UBS : constant Name_Id := N + 290;
! Name_UBSB : constant Name_Id := N + 291;
! Name_Unit_Name : constant Name_Id := N + 292;
! Name_Unknown : constant Name_Id := N + 293;
! Name_Unrestricted : constant Name_Id := N + 294;
! Name_Uppercase : constant Name_Id := N + 295;
! Name_User : constant Name_Id := N + 296;
! Name_VAX_Float : constant Name_Id := N + 297;
! Name_VMS : constant Name_Id := N + 298;
! Name_Working_Storage : constant Name_Id := N + 299;
-- 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
--- 460,555 ----
-- Entry and Protected, this is because these conventions cannot be
-- specified by a pragma.
! First_Convention_Name : constant Name_Id := N + 229;
! Name_Ada : constant Name_Id := N + 229;
! Name_Assembler : constant Name_Id := N + 230;
! Name_COBOL : constant Name_Id := N + 231;
! Name_CPP : constant Name_Id := N + 232;
! Name_Fortran : constant Name_Id := N + 233;
! Name_Intrinsic : constant Name_Id := N + 234;
! Name_Java : constant Name_Id := N + 235;
! Name_Stdcall : constant Name_Id := N + 236;
! Name_Stubbed : constant Name_Id := N + 237;
! Last_Convention_Name : constant Name_Id := N + 237;
-- The following names are preset as synonyms for Assembler
! Name_Asm : constant Name_Id := N + 238;
! Name_Assembly : constant Name_Id := N + 239;
-- The following names are preset as synonyms for C
! Name_Default : constant Name_Id := N + 240;
-- Name_Exernal (previously defined as pragma)
-- The following names are present as synonyms for Stdcall
! Name_DLL : constant Name_Id := N + 241;
! Name_Win32 : constant Name_Id := N + 242;
-- Other special names used in processing pragma arguments
! Name_As_Is : constant Name_Id := N + 243;
! Name_Body_File_Name : constant Name_Id := N + 244;
! Name_Casing : constant Name_Id := N + 245;
! Name_Code : constant Name_Id := N + 246;
! Name_Component : constant Name_Id := N + 247;
! Name_Component_Size_4 : constant Name_Id := N + 248;
! Name_Copy : constant Name_Id := N + 249;
! Name_D_Float : constant Name_Id := N + 250;
! Name_Descriptor : constant Name_Id := N + 251;
! Name_Dot_Replacement : constant Name_Id := N + 252;
! Name_Dynamic : constant Name_Id := N + 253;
! Name_Entity : constant Name_Id := N + 254;
! Name_External_Name : constant Name_Id := N + 255;
! Name_First_Optional_Parameter : constant Name_Id := N + 256;
! Name_Form : constant Name_Id := N + 257;
! Name_G_Float : constant Name_Id := N + 258;
! Name_Gcc : constant Name_Id := N + 259;
! Name_Gnat : constant Name_Id := N + 260;
! Name_GPL : constant Name_Id := N + 261;
! Name_IEEE_Float : constant Name_Id := N + 262;
! Name_Homonym_Number : constant Name_Id := N + 263;
! Name_Internal : constant Name_Id := N + 264;
! Name_Link_Name : constant Name_Id := N + 265;
! Name_Lowercase : constant Name_Id := N + 266;
! Name_Max_Size : constant Name_Id := N + 267;
! Name_Mechanism : constant Name_Id := N + 268;
! Name_Mixedcase : constant Name_Id := N + 269;
! Name_Modified_GPL : constant Name_Id := N + 270;
! Name_Name : constant Name_Id := N + 271;
! Name_NCA : constant Name_Id := N + 272;
! Name_No : constant Name_Id := N + 273;
! 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;
-- 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
*************** package Snames is
*** 559,716 ****
-- 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 + 300;
! Name_Abort_Signal : constant Name_Id := N + 300; -- GNAT
! Name_Access : constant Name_Id := N + 301;
! Name_Address : constant Name_Id := N + 302;
! Name_Address_Size : constant Name_Id := N + 303; -- GNAT
! Name_Aft : constant Name_Id := N + 304;
! Name_Alignment : constant Name_Id := N + 305;
! Name_Asm_Input : constant Name_Id := N + 306; -- GNAT
! Name_Asm_Output : constant Name_Id := N + 307; -- GNAT
! Name_AST_Entry : constant Name_Id := N + 308; -- VMS
! Name_Bit : constant Name_Id := N + 309; -- GNAT
! Name_Bit_Order : constant Name_Id := N + 310;
! Name_Bit_Position : constant Name_Id := N + 311; -- GNAT
! Name_Body_Version : constant Name_Id := N + 312;
! Name_Callable : constant Name_Id := N + 313;
! Name_Caller : constant Name_Id := N + 314;
! Name_Code_Address : constant Name_Id := N + 315; -- GNAT
! Name_Component_Size : constant Name_Id := N + 316;
! Name_Compose : constant Name_Id := N + 317;
! Name_Constrained : constant Name_Id := N + 318;
! Name_Count : constant Name_Id := N + 319;
! Name_Default_Bit_Order : constant Name_Id := N + 320; -- GNAT
! Name_Definite : constant Name_Id := N + 321;
! Name_Delta : constant Name_Id := N + 322;
! Name_Denorm : constant Name_Id := N + 323;
! Name_Digits : constant Name_Id := N + 324;
! Name_Elaborated : constant Name_Id := N + 325; -- GNAT
! Name_Emax : constant Name_Id := N + 326; -- Ada 83
! Name_Enum_Rep : constant Name_Id := N + 327; -- GNAT
! Name_Epsilon : constant Name_Id := N + 328; -- Ada 83
! Name_Exponent : constant Name_Id := N + 329;
! Name_External_Tag : constant Name_Id := N + 330;
! Name_First : constant Name_Id := N + 331;
! Name_First_Bit : constant Name_Id := N + 332;
! Name_Fixed_Value : constant Name_Id := N + 333; -- GNAT
! Name_Fore : constant Name_Id := N + 334;
! Name_Has_Discriminants : constant Name_Id := N + 335; -- GNAT
! Name_Identity : constant Name_Id := N + 336;
! Name_Img : constant Name_Id := N + 337; -- GNAT
! Name_Integer_Value : constant Name_Id := N + 338; -- GNAT
! Name_Large : constant Name_Id := N + 339; -- Ada 83
! Name_Last : constant Name_Id := N + 340;
! Name_Last_Bit : constant Name_Id := N + 341;
! Name_Leading_Part : constant Name_Id := N + 342;
! Name_Length : constant Name_Id := N + 343;
! Name_Machine_Emax : constant Name_Id := N + 344;
! Name_Machine_Emin : constant Name_Id := N + 345;
! Name_Machine_Mantissa : constant Name_Id := N + 346;
! Name_Machine_Overflows : constant Name_Id := N + 347;
! Name_Machine_Radix : constant Name_Id := N + 348;
! Name_Machine_Rounds : constant Name_Id := N + 349;
! Name_Machine_Size : constant Name_Id := N + 350; -- GNAT
! Name_Mantissa : constant Name_Id := N + 351; -- Ada 83
! Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 352;
! Name_Maximum_Alignment : constant Name_Id := N + 353; -- GNAT
! Name_Mechanism_Code : constant Name_Id := N + 354; -- GNAT
! Name_Model_Emin : constant Name_Id := N + 355;
! Name_Model_Epsilon : constant Name_Id := N + 356;
! Name_Model_Mantissa : constant Name_Id := N + 357;
! Name_Model_Small : constant Name_Id := N + 358;
! Name_Modulus : constant Name_Id := N + 359;
! Name_Null_Parameter : constant Name_Id := N + 360; -- GNAT
! Name_Object_Size : constant Name_Id := N + 361; -- GNAT
! Name_Partition_ID : constant Name_Id := N + 362;
! Name_Passed_By_Reference : constant Name_Id := N + 363; -- GNAT
! Name_Pool_Address : constant Name_Id := N + 364;
! Name_Pos : constant Name_Id := N + 365;
! Name_Position : constant Name_Id := N + 366;
! Name_Range : constant Name_Id := N + 367;
! Name_Range_Length : constant Name_Id := N + 368; -- GNAT
! Name_Round : constant Name_Id := N + 369;
! Name_Safe_Emax : constant Name_Id := N + 370; -- Ada 83
! Name_Safe_First : constant Name_Id := N + 371;
! Name_Safe_Large : constant Name_Id := N + 372; -- Ada 83
! Name_Safe_Last : constant Name_Id := N + 373;
! Name_Safe_Small : constant Name_Id := N + 374; -- Ada 83
! Name_Scale : constant Name_Id := N + 375;
! Name_Scaling : constant Name_Id := N + 376;
! Name_Signed_Zeros : constant Name_Id := N + 377;
! Name_Size : constant Name_Id := N + 378;
! Name_Small : constant Name_Id := N + 379;
! Name_Storage_Size : constant Name_Id := N + 380;
! Name_Storage_Unit : constant Name_Id := N + 381; -- GNAT
! Name_Tag : constant Name_Id := N + 382;
! Name_Target_Name : constant Name_Id := N + 383; -- GNAT
! Name_Terminated : constant Name_Id := N + 384;
! Name_To_Address : constant Name_Id := N + 385; -- GNAT
! Name_Type_Class : constant Name_Id := N + 386; -- GNAT
! Name_UET_Address : constant Name_Id := N + 387; -- GNAT
! Name_Unbiased_Rounding : constant Name_Id := N + 388;
! Name_Unchecked_Access : constant Name_Id := N + 389;
! Name_Unconstrained_Array : constant Name_Id := N + 390;
! Name_Universal_Literal_String : constant Name_Id := N + 391; -- GNAT
! Name_Unrestricted_Access : constant Name_Id := N + 392; -- GNAT
! Name_VADS_Size : constant Name_Id := N + 393; -- GNAT
! Name_Val : constant Name_Id := N + 394;
! Name_Valid : constant Name_Id := N + 395;
! Name_Value_Size : constant Name_Id := N + 396; -- GNAT
! Name_Version : constant Name_Id := N + 397;
! Name_Wchar_T_Size : constant Name_Id := N + 398; -- GNAT
! Name_Wide_Width : constant Name_Id := N + 399;
! Name_Width : constant Name_Id := N + 400;
! Name_Word_Size : constant Name_Id := N + 401; -- 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 + 402;
! Name_Adjacent : constant Name_Id := N + 402;
! Name_Ceiling : constant Name_Id := N + 403;
! Name_Copy_Sign : constant Name_Id := N + 404;
! Name_Floor : constant Name_Id := N + 405;
! Name_Fraction : constant Name_Id := N + 406;
! Name_Image : constant Name_Id := N + 407;
! Name_Input : constant Name_Id := N + 408;
! Name_Machine : constant Name_Id := N + 409;
! Name_Max : constant Name_Id := N + 410;
! Name_Min : constant Name_Id := N + 411;
! Name_Model : constant Name_Id := N + 412;
! Name_Pred : constant Name_Id := N + 413;
! Name_Remainder : constant Name_Id := N + 414;
! Name_Rounding : constant Name_Id := N + 415;
! Name_Succ : constant Name_Id := N + 416;
! Name_Truncation : constant Name_Id := N + 417;
! Name_Value : constant Name_Id := N + 418;
! Name_Wide_Image : constant Name_Id := N + 419;
! Name_Wide_Value : constant Name_Id := N + 420;
! Last_Renamable_Function_Attribute : constant Name_Id := N + 420;
-- Attributes that designate procedures
! First_Procedure_Attribute : constant Name_Id := N + 421;
! Name_Output : constant Name_Id := N + 421;
! Name_Read : constant Name_Id := N + 422;
! Name_Write : constant Name_Id := N + 423;
! Last_Procedure_Attribute : constant Name_Id := N + 423;
-- Remaining attributes are ones that return entities
! First_Entity_Attribute_Name : constant Name_Id := N + 424;
! Name_Elab_Body : constant Name_Id := N + 424; -- GNAT
! Name_Elab_Spec : constant Name_Id := N + 425; -- GNAT
! Name_Storage_Pool : constant Name_Id := N + 426;
-- These attributes are the ones that return types
! First_Type_Attribute_Name : constant Name_Id := N + 427;
! Name_Base : constant Name_Id := N + 427;
! Name_Class : constant Name_Id := N + 428;
! Last_Type_Attribute_Name : constant Name_Id := N + 428;
! Last_Entity_Attribute_Name : constant Name_Id := N + 428;
! Last_Attribute_Name : constant Name_Id := N + 428;
-- Names of recognized locking policy identifiers
--- 563,720 ----
-- 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
-- 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;
-- 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;
-- 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;
-- 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;
-- Names of recognized locking policy identifiers
*************** package Snames is
*** 718,727 ****
-- 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 + 429;
! Name_Ceiling_Locking : constant Name_Id := N + 429;
! Name_Inheritance_Locking : constant Name_Id := N + 430;
! Last_Locking_Policy_Name : constant Name_Id := N + 430;
-- Names of recognized queuing policy identifiers.
--- 722,731 ----
-- 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;
-- Names of recognized queuing policy identifiers.
*************** package Snames is
*** 729,738 ****
-- 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 + 431;
! Name_FIFO_Queuing : constant Name_Id := N + 431;
! Name_Priority_Queuing : constant Name_Id := N + 432;
! Last_Queuing_Policy_Name : constant Name_Id := N + 432;
-- Names of recognized task dispatching policy identifiers
--- 733,742 ----
-- 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;
-- Names of recognized task dispatching policy identifiers
*************** package Snames is
*** 740,930 ****
-- 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 + 433;
! Name_Fifo_Within_Priorities : constant Name_Id := N + 433;
! Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 433;
-- Names of recognized checks for pragma Suppress
! First_Check_Name : constant Name_Id := N + 434;
! Name_Access_Check : constant Name_Id := N + 434;
! Name_Accessibility_Check : constant Name_Id := N + 435;
! Name_Discriminant_Check : constant Name_Id := N + 436;
! Name_Division_Check : constant Name_Id := N + 437;
! Name_Elaboration_Check : constant Name_Id := N + 438;
! Name_Index_Check : constant Name_Id := N + 439;
! Name_Length_Check : constant Name_Id := N + 440;
! Name_Overflow_Check : constant Name_Id := N + 441;
! Name_Range_Check : constant Name_Id := N + 442;
! Name_Storage_Check : constant Name_Id := N + 443;
! Name_Tag_Check : constant Name_Id := N + 444;
! Name_All_Checks : constant Name_Id := N + 445;
! Last_Check_Name : constant Name_Id := N + 445;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
! Name_Abort : constant Name_Id := N + 446;
! Name_Abs : constant Name_Id := N + 447;
! Name_Accept : constant Name_Id := N + 448;
! Name_And : constant Name_Id := N + 449;
! Name_All : constant Name_Id := N + 450;
! Name_Array : constant Name_Id := N + 451;
! Name_At : constant Name_Id := N + 452;
! Name_Begin : constant Name_Id := N + 453;
! Name_Body : constant Name_Id := N + 454;
! Name_Case : constant Name_Id := N + 455;
! Name_Constant : constant Name_Id := N + 456;
! Name_Declare : constant Name_Id := N + 457;
! Name_Delay : constant Name_Id := N + 458;
! Name_Do : constant Name_Id := N + 459;
! Name_Else : constant Name_Id := N + 460;
! Name_Elsif : constant Name_Id := N + 461;
! Name_End : constant Name_Id := N + 462;
! Name_Entry : constant Name_Id := N + 463;
! Name_Exception : constant Name_Id := N + 464;
! Name_Exit : constant Name_Id := N + 465;
! Name_For : constant Name_Id := N + 466;
! Name_Function : constant Name_Id := N + 467;
! Name_Generic : constant Name_Id := N + 468;
! Name_Goto : constant Name_Id := N + 469;
! Name_If : constant Name_Id := N + 470;
! Name_In : constant Name_Id := N + 471;
! Name_Is : constant Name_Id := N + 472;
! Name_Limited : constant Name_Id := N + 473;
! Name_Loop : constant Name_Id := N + 474;
! Name_Mod : constant Name_Id := N + 475;
! Name_New : constant Name_Id := N + 476;
! Name_Not : constant Name_Id := N + 477;
! Name_Null : constant Name_Id := N + 478;
! Name_Of : constant Name_Id := N + 479;
! Name_Or : constant Name_Id := N + 480;
! Name_Others : constant Name_Id := N + 481;
! Name_Out : constant Name_Id := N + 482;
! Name_Package : constant Name_Id := N + 483;
! Name_Pragma : constant Name_Id := N + 484;
! Name_Private : constant Name_Id := N + 485;
! Name_Procedure : constant Name_Id := N + 486;
! Name_Raise : constant Name_Id := N + 487;
! Name_Record : constant Name_Id := N + 488;
! Name_Rem : constant Name_Id := N + 489;
! Name_Renames : constant Name_Id := N + 490;
! Name_Return : constant Name_Id := N + 491;
! Name_Reverse : constant Name_Id := N + 492;
! Name_Select : constant Name_Id := N + 493;
! Name_Separate : constant Name_Id := N + 494;
! Name_Subtype : constant Name_Id := N + 495;
! Name_Task : constant Name_Id := N + 496;
! Name_Terminate : constant Name_Id := N + 497;
! Name_Then : constant Name_Id := N + 498;
! Name_Type : constant Name_Id := N + 499;
! Name_Use : constant Name_Id := N + 500;
! Name_When : constant Name_Id := N + 501;
! Name_While : constant Name_Id := N + 502;
! Name_With : constant Name_Id := N + 503;
! Name_Xor : constant Name_Id := N + 504;
-- 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 + 505;
! Name_Divide : constant Name_Id := N + 505;
! Name_Enclosing_Entity : constant Name_Id := N + 506;
! Name_Exception_Information : constant Name_Id := N + 507;
! Name_Exception_Message : constant Name_Id := N + 508;
! Name_Exception_Name : constant Name_Id := N + 509;
! Name_File : constant Name_Id := N + 510;
! Name_Import_Address : constant Name_Id := N + 511;
! Name_Import_Largest_Value : constant Name_Id := N + 512;
! Name_Import_Value : constant Name_Id := N + 513;
! Name_Is_Negative : constant Name_Id := N + 514;
! Name_Line : constant Name_Id := N + 515;
! Name_Rotate_Left : constant Name_Id := N + 516;
! Name_Rotate_Right : constant Name_Id := N + 517;
! Name_Shift_Left : constant Name_Id := N + 518;
! Name_Shift_Right : constant Name_Id := N + 519;
! Name_Shift_Right_Arithmetic : constant Name_Id := N + 520;
! Name_Source_Location : constant Name_Id := N + 521;
! Name_Unchecked_Conversion : constant Name_Id := N + 522;
! Name_Unchecked_Deallocation : constant Name_Id := N + 523;
! Name_To_Pointer : constant Name_Id := N + 524;
! Last_Intrinsic_Name : constant Name_Id := N + 524;
-- Reserved words used only in Ada 95
! First_95_Reserved_Word : constant Name_Id := N + 525;
! Name_Abstract : constant Name_Id := N + 525;
! Name_Aliased : constant Name_Id := N + 526;
! Name_Protected : constant Name_Id := N + 527;
! Name_Until : constant Name_Id := N + 528;
! Name_Requeue : constant Name_Id := N + 529;
! Name_Tagged : constant Name_Id := N + 530;
! Last_95_Reserved_Word : constant Name_Id := N + 530;
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 + 531;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
! Name_Binder : constant Name_Id := N + 532;
! Name_Body_Suffix : constant Name_Id := N + 533;
! Name_Builder : constant Name_Id := N + 534;
! Name_Compiler : constant Name_Id := N + 535;
! Name_Cross_Reference : constant Name_Id := N + 536;
! Name_Default_Switches : constant Name_Id := N + 537;
! Name_Exec_Dir : constant Name_Id := N + 538;
! Name_Executable : constant Name_Id := N + 539;
! Name_Executable_Suffix : constant Name_Id := N + 540;
! Name_Extends : constant Name_Id := N + 541;
! Name_Finder : constant Name_Id := N + 542;
! Name_Global_Configuration_Pragmas : constant Name_Id := N + 543;
! Name_Gnatls : constant Name_Id := N + 544;
! Name_Gnatstub : constant Name_Id := N + 545;
! Name_Implementation : constant Name_Id := N + 546;
! Name_Implementation_Exceptions : constant Name_Id := N + 547;
! Name_Implementation_Suffix : constant Name_Id := N + 548;
! Name_Languages : constant Name_Id := N + 549;
! Name_Library_Dir : constant Name_Id := N + 550;
! Name_Library_Auto_Init : constant Name_Id := N + 551;
! Name_Library_GCC : constant Name_Id := N + 552;
! Name_Library_Interface : constant Name_Id := N + 553;
! Name_Library_Kind : constant Name_Id := N + 554;
! Name_Library_Name : constant Name_Id := N + 555;
! Name_Library_Options : constant Name_Id := N + 556;
! Name_Library_Src_Dir : constant Name_Id := N + 557;
! Name_Library_Symbol_File : constant Name_Id := N + 558;
! Name_Library_Version : constant Name_Id := N + 559;
! Name_Linker : constant Name_Id := N + 560;
! Name_Local_Configuration_Pragmas : constant Name_Id := N + 561;
! Name_Locally_Removed_Files : constant Name_Id := N + 562;
! Name_Naming : constant Name_Id := N + 563;
! Name_Object_Dir : constant Name_Id := N + 564;
! Name_Pretty_Printer : constant Name_Id := N + 565;
! Name_Project : constant Name_Id := N + 566;
! Name_Separate_Suffix : constant Name_Id := N + 567;
! Name_Source_Dirs : constant Name_Id := N + 568;
! Name_Source_Files : constant Name_Id := N + 569;
! Name_Source_List_File : constant Name_Id := N + 570;
! Name_Spec : constant Name_Id := N + 571;
! Name_Spec_Suffix : constant Name_Id := N + 572;
! Name_Specification : constant Name_Id := N + 573;
! Name_Specification_Exceptions : constant Name_Id := N + 574;
! Name_Specification_Suffix : constant Name_Id := N + 575;
! Name_Switches : constant Name_Id := N + 576;
-- Other miscellaneous names used in front end
! Name_Unaligned_Valid : constant Name_Id := N + 577;
-- Mark last defined name for consistency check in Snames body
! Last_Predefined_Name : constant Name_Id := N + 577;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
--- 744,934 ----
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
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;
-- 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_Src_Dir : constant Name_Id := N + 561;
! Name_Library_Symbol_File : constant Name_Id := N + 562;
! Name_Library_Version : constant Name_Id := N + 563;
! Name_Linker : constant Name_Id := N + 564;
! Name_Local_Configuration_Pragmas : constant Name_Id := N + 565;
! Name_Locally_Removed_Files : constant Name_Id := N + 566;
! Name_Naming : constant Name_Id := N + 567;
! Name_Object_Dir : constant Name_Id := N + 568;
! Name_Pretty_Printer : constant Name_Id := N + 569;
! Name_Project : constant Name_Id := N + 570;
! Name_Separate_Suffix : constant Name_Id := N + 571;
! Name_Source_Dirs : constant Name_Id := N + 572;
! Name_Source_Files : constant Name_Id := N + 573;
! Name_Source_List_File : constant Name_Id := N + 574;
! Name_Spec : constant Name_Id := N + 575;
! Name_Spec_Suffix : constant Name_Id := N + 576;
! Name_Specification : constant Name_Id := N + 577;
! Name_Specification_Exceptions : constant Name_Id := N + 578;
! Name_Specification_Suffix : constant Name_Id := N + 579;
! Name_Switches : constant Name_Id := N + 580;
-- Other miscellaneous names used in front end
! Name_Unaligned_Valid : constant Name_Id := N + 581;
-- Mark last defined name for consistency check in Snames body
! Last_Predefined_Name : constant Name_Id := N + 581;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
*************** package Snames is
*** 1257,1262 ****
--- 1261,1267 ----
Pragma_Task_Info,
Pragma_Task_Name,
Pragma_Task_Storage,
+ Pragma_Thread_Body,
Pragma_Time_Slice,
Pragma_Title,
Pragma_Unchecked_Union,
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.11
retrieving revision 1.13
diff -u -c -3 -p -r1.11 -r1.13
*** snames.adb 21 Oct 2003 13:42:22 -0000 1.11
--- snames.adb 4 Nov 2003 12:56:59 -0000 1.13
*************** package body Snames is
*** 62,69 ****
"off#" &
"space#" &
"time#" &
- "_alignment#" &
"_abort_signal#" &
"_assign#" &
"_chain#" &
"_clean#" &
--- 62,69 ----
"off#" &
"space#" &
"time#" &
"_abort_signal#" &
+ "_alignment#" &
"_assign#" &
"_chain#" &
"_clean#" &
*************** package body Snames is
*** 77,82 ****
--- 77,84 ----
"_master#" &
"_object#" &
"_priority#" &
+ "_process_atsd#" &
+ "_secondary_stack#" &
"_service#" &
"_size#" &
"_tags#" &
*************** package body Snames is
*** 274,279 ****
--- 276,282 ----
"task_info#" &
"task_name#" &
"task_storage#" &
+ "thread_body#" &
"time_slice#" &
"title#" &
"unchecked_union#" &
*************** package body Snames is
*** 336,341 ****
--- 339,345 ----
"result_type#" &
"runtime#" &
"sb#" &
+ "secondary_stack_size#" &
"section#" &
"semaphore#" &
"spec_file_name#" &
^ permalink raw reply [flat|nested] 178+ messages in thread
* Re: committed: ada updates
2003-10-29 12:25 Arnaud Charlet
@ 2003-10-30 16:14 ` Joseph S. Myers
0 siblings, 0 replies; 178+ messages in thread
From: Joseph S. Myers @ 2003-10-30 16:14 UTC (permalink / raw)
To: Arnaud Charlet; +Cc: gcc-patches
On Wed, 29 Oct 2003, Arnaud Charlet wrote:
> * Makefile.generic: Remove duplicated setting of CC.
>
> * Makefile.prolog: Set CC to gcc by default, to override make's
> default (cc).
What is the function of these files?
(a) They need licence notices, not just copyright notices.
(b) They get installed in $(prefix)/share/make. There are two problems
with this. First, the names of the files and the directory seem rather
too generic for that; $(prefix)/share/gnat or $(prefix)/share/ada might be
better to make clear where they come from. Second, --datadir is a
supported configure option, so $(datadir) should be used instead of
$(prefix)/share.
--
Joseph S. Myers
jsm@polyomino.org.uk
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: ada updates
@ 2003-10-30 11:54 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-10-30 11:54 UTC (permalink / raw)
To: gcc-patches
Parser improvements and new package.
--
2003-10-30 Vasiliy Fofanov <fofanov@act-europe.fr>
* 3vtrasym.adb:
Demangle Ada symbols returned by TBK$SYMBOLIZE. Correctly align line
numbers when symbol name is too long.
2003-10-30 Ed Falis <falis@gnat.com>
* g-signal.ads, g-signal.adb: New files
* impunit.adb: (Non_Imp_File_Names): Added "g-signal"
* Makefile.rtl: Introduce GNAT.Signals
2003-10-30 Robert Dewar <dewar@gnat.com>
* freeze.adb: Minor reformatting
* lib-writ.adb (Write_ALI): Never write ali file if -gnats is specified
* par.adb, par-ch12.adb, par-ch13.adb, par-ch2.adb, par-ch3.adb,
par-ch5.adb, par-ch6.adb, par-ch9.adb, par-util.adb:
New handling of Id_Check parameter to improve recognition of keywords
used as identifiers.
Update copyright notice to include 2003
--
Index: 3vtrasym.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vtrasym.adb,v
retrieving revision 1.2
diff -u -c -3 -p -r1.2 3vtrasym.adb
*** 3vtrasym.adb 29 Oct 2003 10:26:12 -0000 1.2
--- 3vtrasym.adb 30 Oct 2003 11:49:50 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1999-2003 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1999-2003 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,32 ****
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
! -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
--- 26,33 ----
-- 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 GNAT.Traceback.Symbolic is
*** 96,107 ****
Value, Value),
User_Act_Proc);
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
! Status : Cond_Value_Type;
Image_Name : ASCIC;
Image_Name_Addr : Address;
Module_Name : ASCIC;
--- 97,179 ----
Value, Value),
User_Act_Proc);
+ function Demangle_Ada (Mangled : String) return String;
+ -- Demangles an Ada symbol. Removes leading "_ada_" and trailing
+ -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
+
+
+ ------------------
+ -- Demangle_Ada --
+ ------------------
+
+ function Demangle_Ada (Mangled : String) return String is
+ Demangled : String (1 .. Mangled'Length);
+ Pos : Integer := Mangled'First;
+ Last : Integer := Mangled'Last;
+ DPos : Integer := 1;
+ begin
+
+ if Pos > Last then
+ return "";
+ end if;
+
+ -- Skip leading _ada_
+
+ if Mangled'Length > 4 and then Mangled (Pos .. Pos + 4) = "_ada_" then
+ Pos := Pos + 5;
+ end if;
+
+ -- Skip trailing __{DIGIT}+ or ${DIGIT}+
+
+ if Mangled (Last) in '0' .. '9' then
+
+ for J in reverse Pos + 2 .. Last - 1 loop
+
+ case Mangled (J) is
+ when '0' .. '9' =>
+ null;
+ when '$' =>
+ Last := J - 1;
+ exit;
+ when '_' =>
+ if Mangled (J - 1) = '_' then
+ Last := J - 2;
+ end if;
+ exit;
+ when others =>
+ exit;
+ end case;
+
+ end loop;
+
+ end if;
+
+ -- Now just copy Mangled to Demangled, converting "__" to '.' on the fly
+
+ while Pos <= Last loop
+
+ if Mangled (Pos) = '_' and then Mangled (Pos + 1) = '_'
+ and then Pos /= Mangled'First then
+ Demangled (DPos) := '.';
+ Pos := Pos + 2;
+ else
+ Demangled (DPos) := Mangled (Pos);
+ Pos := Pos + 1;
+ end if;
+
+ DPos := DPos + 1;
+
+ end loop;
+
+ return Demangled (1 .. DPos - 1);
+ end Demangle_Ada;
+
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
! Status : Cond_Value_Type;
Image_Name : ASCIC;
Image_Name_Addr : Address;
Module_Name : ASCIC;
*************** package body GNAT.Traceback.Symbolic is
*** 152,157 ****
--- 224,234 ----
declare
First : Integer := Len + 1;
Last : Integer := First + 80 - 1;
+ Pos : Integer;
+ Routine_Name_D : String := Demangle_Ada
+ (To_Ada
+ (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
+ False));
begin
Res (First .. Last) := (others => ' ');
*************** package body GNAT.Traceback.Symbolic is
*** 168,180 ****
False);
Res (First + 30 ..
! First + 30 + Integer (Routine_Name.Count) - 1) :=
! To_Ada
! (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
! False);
! Res (First + 50 ..
! First + 50 + Integer'Image (Line_Number)'Length - 1) :=
Integer'Image (Line_Number);
Res (Last) := ASCII.LF;
--- 245,267 ----
False);
Res (First + 30 ..
! First + 30 + Routine_Name_D'Length - 1) :=
! Routine_Name_D;
!
! -- If routine name doesn't fit 20 characters, output
! -- the line number on next line at 50th position
!
! if Routine_Name_D'Length > 20 then
! Pos := First + 30 + Routine_Name_D'Length;
! Res (Pos) := ASCII.LF;
! Last := Pos + 80;
! Res (Pos + 1 .. Last) := (others => ' ');
! Pos := Pos + 51;
! else
! Pos := First + 50;
! end if;
! Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) :=
Integer'Image (Line_Number);
Res (Last) := ASCII.LF;
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 freeze.adb
*** freeze.adb 29 Oct 2003 10:26:14 -0000 1.8
--- freeze.adb 30 Oct 2003 11:49:50 -0000
*************** package body Freeze is
*** 124,130 ****
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
! -- true if T is not private and has no private components, or has a full
-- view. Used to determine whether the designated type of an access type
-- should be frozen when the access type is frozen. This is done when an
-- allocator is frozen, or an expression that may involve attributes of
--- 124,130 ----
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
! -- True if T is not private and has no private components, or has a full
-- view. Used to determine whether the designated type of an access type
-- should be frozen when the access type is frozen. This is done when an
-- allocator is frozen, or an expression that may involve attributes of
*************** package body Freeze is
*** 4262,4273 ****
elsif Is_Record_Type (T)
and not Is_Private_Type (T)
then
-
-- Verify that the record type has no components with
-- private types without completion.
declare
Comp : Entity_Id;
begin
Comp := First_Component (T);
--- 4262,4273 ----
elsif Is_Record_Type (T)
and not Is_Private_Type (T)
then
-- Verify that the record type has no components with
-- private types without completion.
declare
Comp : Entity_Id;
+
begin
Comp := First_Component (T);
Index: impunit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/impunit.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 impunit.adb
*** impunit.adb 21 Oct 2003 13:42:09 -0000 1.8
--- impunit.adb 30 Oct 2003 11:49:50 -0000
*************** package body Impunit is
*** 229,234 ****
--- 229,235 ----
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
"g-semaph", -- GNAT.Semaphores
+ "g-signal", -- GNAT.Signals
"g-socket", -- GNAT.Sockets
"g-souinf", -- GNAT.Source_Info
"g-speche", -- GNAT.Spell_Checker
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 lib-writ.adb
*** lib-writ.adb 21 Oct 2003 13:42:09 -0000 1.7
--- lib-writ.adb 30 Oct 2003 11:49:50 -0000
*************** package body Lib.Writ is
*** 680,685 ****
--- 680,692 ----
-- Start of processing for Writ_ALI
begin
+ -- We never write an ALI file if the original operating mode was
+ -- syntax-only (-gnats switch used in compiler invocation line)
+
+ if Original_Operating_Mode = Check_Syntax then
+ return;
+ end if;
+
-- Build sorted source dependency table. We do this right away,
-- because it is referenced by Up_To_Date_ALI_File_Exists.
Index: Makefile.rtl
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.rtl,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 Makefile.rtl
*** Makefile.rtl 21 Oct 2003 13:41:53 -0000 1.1
--- Makefile.rtl 30 Oct 2003 11:49:50 -0000
*************** GNATRTL_TASKING_OBJS= \
*** 38,43 ****
--- 38,44 ----
g-boubuf$(objext) \
g-boumai$(objext) \
g-semaph$(objext) \
+ g-signal$(objext) \
g-thread$(objext) \
s-asthan$(objext) \
s-inmaop$(objext) \
Index: par.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 par.adb
*** par.adb 21 Oct 2003 13:42:12 -0000 1.8
--- par.adb 30 Oct 2003 11:49:50 -0000
***************
*** 26,32 ****
with Atree; use Atree;
with Casing; use Casing;
- with Csets; use Csets;
with Debug; use Debug;
with Elists; use Elists;
with Errout; use Errout;
--- 26,31 ----
*************** function Par (Configuration_Pragmas : Bo
*** 189,194 ****
--- 188,260 ----
-- that there is a missing body, but it seems more reasonable to let the
-- later semantic checking discover this.
+ ----------------------------------------------------
+ -- Handling of Reserved Words Used as Identifiers --
+ ----------------------------------------------------
+
+ -- Note: throughout the parser, the terms reserved word and keyword
+ -- are used interchangably to refer to the same set of reserved
+ -- keywords (including until, protected, etc).
+
+ -- If a reserved word is used in place of an identifier, the parser
+ -- where possible tries to recover gracefully. In particular, if the
+ -- keyword is clearly spelled using identifier casing, e.g. Until in
+ -- a source program using mixed case identifiers and lower case keywords,
+ -- then the keyword is treated as an identifier if it appears in a place
+ -- where an identifier is required.
+
+ -- The situation is more complex if the keyword is spelled with normal
+ -- keyword casing. In this case, the parser is more reluctant to
+ -- consider it to be intended as an identifier, unless it has some
+ -- further confirmation.
+
+ -- In the case of an identifier appearing in the identifier list of a
+ -- declaration, the appearence of a comma or colon right after the
+ -- keyword on the same line is taken as confirmation. For an enumeration
+ -- literal, a comma or right paren right after the identifier is also
+ -- treated as adequate confirmation.
+
+ -- The following type is used in calls to Is_Reserved_Identifier and
+ -- also to P_Defining_Identifier and P_Identifier. The default for all
+ -- these functins is that reserved words in reserved word case are not
+ -- considered to be reserved identifiers. The Id_Check value indicates
+ -- tokens, which if they appear immediately after the identifier, are
+ -- taken as confirming that the use of an identifier was expected
+
+ type Id_Check is
+ (None,
+ -- Default, no special token test
+
+ C_Comma_Right_Paren,
+ -- Consider as identifier if followed by comma or right paren
+
+ C_Comma_Colon,
+ -- Consider as identifier if followed by comma or colon
+
+ C_Do,
+ -- Consider as identifier if followed by DO
+
+ C_Dot,
+ -- Consider as identifier if followed by period
+
+ C_Greater_Greater,
+ -- Consider as identifier if followed by >>
+
+ C_In,
+ -- Consider as identifier if followed by IN
+
+ C_Is,
+ -- Consider as identifier if followed by IS
+
+ C_Left_Paren_Semicolon,
+ -- Consider as identifier if followed by left paren or semicolon
+
+ C_Use,
+ -- Consider as identifier if followed by USE
+
+ C_Vertical_Bar_Arrow);
+ -- Consider as identifier if followed by | or =>
+
--------------------------------------------
-- Handling IS Used in Place of Semicolon --
--------------------------------------------
*************** function Par (Configuration_Pragmas : Bo
*** 450,458 ****
-- List that is created.
package Ch2 is
- function P_Identifier return Node_Id;
function P_Pragma return Node_Id;
function P_Pragmas_Opt return List_Id;
-- This function scans for a sequence of pragmas in other than a
-- declaration sequence or statement sequence context. All pragmas
--- 516,527 ----
-- List that is created.
package Ch2 is
function P_Pragma return Node_Id;
+ function P_Identifier (C : Id_Check := None) return Node_Id;
+ -- Scans out an identifier. The parameter C determines the treatment
+ -- of reserved identifiers. See declaration of Id_Check for details.
+
function P_Pragmas_Opt return List_Id;
-- This function scans for a sequence of pragmas in other than a
-- declaration sequence or statement sequence context. All pragmas
*************** function Par (Configuration_Pragmas : Bo
*** 482,488 ****
function P_Basic_Declarative_Items return List_Id;
function P_Constraint_Opt return Node_Id;
function P_Declarative_Part return List_Id;
- function P_Defining_Identifier return Node_Id;
function P_Discrete_Choice_List return List_Id;
function P_Discrete_Range return Node_Id;
function P_Discrete_Subtype_Definition return Node_Id;
--- 551,556 ----
*************** function Par (Configuration_Pragmas : Bo
*** 503,508 ****
--- 571,581 ----
-- case where the source has a single declaration with multiple
-- defining identifiers.
+ function P_Defining_Identifier (C : Id_Check := None) return Node_Id;
+ -- Scan out a defining identifier. The parameter C controls the
+ -- treatment of errors in case a reserved word is scanned. See the
+ -- declaration of this type for details.
+
function Init_Expr_Opt (P : Boolean := False) return Node_Id;
-- If an initialization expression is present (:= expression), then
-- it is scanned out and returned, otherwise Empty is returned if no
*************** function Par (Configuration_Pragmas : Bo
*** 908,917 ****
-- past it, otherwise the call has no effect at all. T may be any
-- reserved word token, or comma, left or right paren, or semicolon.
! function Is_Reserved_Identifier return Boolean;
-- Test if current token is a reserved identifier. This test is based
-- on the token being a keyword and being spelled in typical identifier
! -- style (i.e. starting with an upper case letter).
procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type);
-- Called when the previous token is an identifier (whose Token_Node
--- 981,992 ----
-- past it, otherwise the call has no effect at all. T may be any
-- reserved word token, or comma, left or right paren, or semicolon.
! function Is_Reserved_Identifier (C : Id_Check := None) return Boolean;
-- Test if current token is a reserved identifier. This test is based
-- on the token being a keyword and being spelled in typical identifier
! -- style (i.e. starting with an upper case letter). The parameter C
! -- determines the special treatment if a reserved word is encountered
! -- that has the normal casing of a reserved word.
procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type);
-- Called when the previous token is an identifier (whose Token_Node
Index: par-ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch12.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 par-ch12.adb
*** par-ch12.adb 24 Apr 2003 17:54:07 -0000 1.7
--- par-ch12.adb 30 Oct 2003 11:49:50 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2001 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2003 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- --
*************** package body Ch12 is
*** 367,378 ****
-- bother to check for it being exceeded.
begin
! Idents (1) := P_Defining_Identifier;
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier;
end loop;
T_Colon;
--- 367,378 ----
-- bother to check for it being exceeded.
begin
! Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
*************** package body Ch12 is
*** 873,879 ****
begin
Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr);
Scan; -- past PACKAGE
! Set_Defining_Identifier (Def_Node, P_Defining_Identifier);
T_Is;
T_New;
Set_Name (Def_Node, P_Qualified_Simple_Name);
--- 873,879 ----
begin
Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr);
Scan; -- past PACKAGE
! Set_Defining_Identifier (Def_Node, P_Defining_Identifier (C_Is));
T_Is;
T_New;
Set_Name (Def_Node, P_Qualified_Simple_Name);
Index: par-ch13.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch13.adb,v
retrieving revision 1.4
diff -u -c -3 -p -r1.4 par-ch13.adb
*** par-ch13.adb 24 Apr 2003 17:54:07 -0000 1.4
--- par-ch13.adb 30 Oct 2003 11:49:50 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2001 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2003 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- --
*************** package body Ch13 is
*** 92,98 ****
-- Note that the name in a representation clause is always a simple
-- name, even in the attribute case, see AI-300 which made this so!
! Identifier_Node := P_Identifier;
-- Check case of qualified name to give good error message
--- 92,98 ----
-- Note that the name in a representation clause is always a simple
-- name, even in the attribute case, see AI-300 which made this so!
! Identifier_Node := P_Identifier (C_Use);
-- Check case of qualified name to give good error message
Index: par-ch2.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch2.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 par-ch2.adb
*** par-ch2.adb 21 Oct 2003 13:42:10 -0000 1.6
--- par-ch2.adb 30 Oct 2003 11:49:50 -0000
*************** package body Ch2 is
*** 47,53 ****
-- Error recovery: can raise Error_Resync (cannot return Error)
! function P_Identifier return Node_Id is
Ident_Node : Node_Id;
begin
--- 47,53 ----
-- Error recovery: can raise Error_Resync (cannot return Error)
! function P_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id;
begin
*************** package body Ch2 is
*** 61,67 ****
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
! elsif Is_Reserved_Identifier then
Scan_Reserved_Identifier (Force_Msg => False);
Ident_Node := Token_Node;
Scan; -- past the node
--- 61,67 ----
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
! elsif Is_Reserved_Identifier (C) then
Scan_Reserved_Identifier (Force_Msg => False);
Ident_Node := Token_Node;
Scan; -- past the node
Index: par-ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch3.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 par-ch3.adb
*** par-ch3.adb 21 Oct 2003 13:42:10 -0000 1.8
--- par-ch3.adb 30 Oct 2003 11:49:51 -0000
*************** package body Ch3 is
*** 164,170 ****
-- Error recovery: can raise Error_Resync
! function P_Defining_Identifier return Node_Id is
Ident_Node : Node_Id;
begin
--- 164,170 ----
-- Error recovery: can raise Error_Resync
! function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id;
begin
*************** package body Ch3 is
*** 179,185 ****
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
! elsif Is_Reserved_Identifier then
Scan_Reserved_Identifier (Force_Msg => True);
-- Otherwise we have junk that cannot be interpreted as an identifier
--- 179,185 ----
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
! elsif Is_Reserved_Identifier (C) then
Scan_Reserved_Identifier (Force_Msg => True);
-- Otherwise we have junk that cannot be interpreted as an identifier
*************** package body Ch3 is
*** 262,268 ****
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
T_Type;
! Ident_Node := P_Defining_Identifier;
Discr_Sloc := Token_Ptr;
if P_Unknown_Discriminant_Part_Opt then
--- 262,268 ----
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
T_Type;
! Ident_Node := P_Defining_Identifier (C_Is);
Discr_Sloc := Token_Ptr;
if P_Unknown_Discriminant_Part_Opt then
*************** package body Ch3 is
*** 732,738 ****
begin
Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
Scan; -- past SUBTYPE
! Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
TF_Is;
if Token = Tok_New then
--- 732,738 ----
begin
Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
Scan; -- past SUBTYPE
! Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
TF_Is;
if Token = Tok_New then
*************** package body Ch3 is
*** 1090,1096 ****
begin
Ident_Sloc := Token_Ptr;
Save_Scan_State (Scan_State); -- at first identifier
! Idents (1) := P_Defining_Identifier;
-- If we have a colon after the identifier, then we can assume that
-- this is in fact a valid identifier declaration and can steam ahead.
--- 1090,1096 ----
begin
Ident_Sloc := Token_Ptr;
Save_Scan_State (Scan_State); -- at first identifier
! Idents (1) := P_Defining_Identifier (C_Comma_Colon);
-- If we have a colon after the identifier, then we can assume that
-- this is in fact a valid identifier declaration and can steam ahead.
*************** package body Ch3 is
*** 1104,1110 ****
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier;
end loop;
Save_Scan_State (Scan_State); -- at colon
--- 1104,1110 ----
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
Save_Scan_State (Scan_State); -- at colon
*************** package body Ch3 is
*** 1685,1691 ****
if Token = Tok_Char_Literal then
return P_Defining_Character_Literal;
else
! return P_Defining_Identifier;
end if;
end P_Enumeration_Literal_Specification;
--- 1685,1691 ----
if Token = Tok_Char_Literal then
return P_Defining_Character_Literal;
else
! return P_Defining_Identifier (C_Comma_Right_Paren);
end if;
end P_Enumeration_Literal_Specification;
*************** package body Ch3 is
*** 2278,2289 ****
Specification_Loop : loop
Ident_Sloc := Token_Ptr;
! Idents (1) := P_Defining_Identifier;
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier;
end loop;
T_Colon;
--- 2278,2289 ----
Specification_Loop : loop
Ident_Sloc := Token_Ptr;
! Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
*************** package body Ch3 is
*** 2518,2524 ****
Names_List := New_List;
loop
! Append (P_Identifier, Names_List);
exit when Token /= Tok_Vertical_Bar;
Scan; -- past |
end loop;
--- 2518,2524 ----
Names_List := New_List;
loop
! Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
exit when Token /= Tok_Vertical_Bar;
Scan; -- past |
end loop;
*************** package body Ch3 is
*** 2747,2758 ****
end if;
Ident_Sloc := Token_Ptr;
! Idents (1) := P_Defining_Identifier;
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier;
end loop;
T_Colon;
--- 2747,2758 ----
end if;
Ident_Sloc := Token_Ptr;
! Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
Index: par-ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch5.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 par-ch5.adb
*** par-ch5.adb 21 Oct 2003 13:42:10 -0000 1.7
--- par-ch5.adb 30 Oct 2003 11:49:51 -0000
*************** package body Ch5 is
*** 1004,1010 ****
begin
Label_Node := New_Node (N_Label, Token_Ptr);
Scan; -- past <<
! Set_Identifier (Label_Node, P_Identifier);
T_Greater_Greater;
Append_Elmt (Label_Node, Label_List);
return Label_Node;
--- 1004,1010 ----
begin
Label_Node := New_Node (N_Label, Token_Ptr);
Scan; -- past <<
! Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
T_Greater_Greater;
Append_Elmt (Label_Node, Label_List);
return Label_Node;
*************** package body Ch5 is
*** 1621,1627 ****
New_Node (N_Loop_Parameter_Specification, Token_Ptr);
Save_Scan_State (Scan_State);
! ID_Node := P_Defining_Identifier;
Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
if Token = Tok_Left_Paren then
--- 1621,1627 ----
New_Node (N_Loop_Parameter_Specification, Token_Ptr);
Save_Scan_State (Scan_State);
! ID_Node := P_Defining_Identifier (C_In);
Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
if Token = Tok_Left_Paren then
Index: par-ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch6.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 par-ch6.adb
*** par-ch6.adb 21 Oct 2003 13:42:10 -0000 1.6
--- par-ch6.adb 30 Oct 2003 11:49:51 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2002 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2003 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- --
*************** package body Ch6 is
*** 593,598 ****
--- 593,602 ----
-- True, a real dot has been scanned and we are positioned past it,
-- if the result is False, the scan position is unchanged.
+ --------------
+ -- Real_Dot --
+ --------------
+
function Real_Dot return Boolean is
Scan_State : Saved_Scan_State;
*************** package body Ch6 is
*** 715,721 ****
Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
end if;
! Ident_Node := P_Identifier;
Merge_Identifier (Ident_Node, Tok_Return);
-- Normal case (not child library unit name)
--- 719,725 ----
Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
end if;
! Ident_Node := P_Identifier (C_Dot);
Merge_Identifier (Ident_Node, Tok_Return);
-- Normal case (not child library unit name)
*************** package body Ch6 is
*** 746,752 ****
Name_Node := New_Node (N_Selected_Component, Token_Ptr);
Scan; -- past period
Set_Prefix (Name_Node, Prefix_Node);
! Ident_Node := P_Identifier;
Set_Selector_Name (Name_Node, Ident_Node);
Prefix_Node := Name_Node;
end loop;
--- 750,756 ----
Name_Node := New_Node (N_Selected_Component, Token_Ptr);
Scan; -- past period
Set_Prefix (Name_Node, Prefix_Node);
! Ident_Node := P_Identifier (C_Dot);
Set_Selector_Name (Name_Node, Ident_Node);
Prefix_Node := Name_Node;
end loop;
*************** package body Ch6 is
*** 870,876 ****
Ignore (Tok_Left_Paren);
Ident_Sloc := Token_Ptr;
! Idents (1) := P_Defining_Identifier;
Num_Idents := 1;
Ident_Loop : loop
--- 874,880 ----
Ignore (Tok_Left_Paren);
Ident_Sloc := Token_Ptr;
! Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
Ident_Loop : loop
*************** package body Ch6 is
*** 924,930 ****
T_Comma;
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier;
end loop Ident_Loop;
-- Fall through the loop on encountering a colon, or deciding
--- 928,934 ----
T_Comma;
Num_Idents := Num_Idents + 1;
! Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop Ident_Loop;
-- Fall through the loop on encountering a colon, or deciding
Index: par-ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch9.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 par-ch9.adb
*** par-ch9.adb 21 Oct 2003 13:42:10 -0000 1.5
--- par-ch9.adb 30 Oct 2003 11:49:51 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2002 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2003 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- --
*************** package body Ch9 is
*** 90,96 ****
if Token = Tok_Body then
Scan; -- past BODY
! Name_Node := P_Defining_Identifier;
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Left_Paren then
--- 90,96 ----
if Token = Tok_Body then
Scan; -- past BODY
! Name_Node := P_Defining_Identifier (C_Is);
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Left_Paren then
*************** package body Ch9 is
*** 133,139 ****
else
Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
! Name_Node := P_Defining_Identifier;
Set_Defining_Identifier (Task_Node, Name_Node);
Scope.Table (Scope.Last).Labl := Name_Node;
--- 133,139 ----
else
Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
! Name_Node := P_Defining_Identifier (C_Is);
Set_Defining_Identifier (Task_Node, Name_Node);
Scope.Table (Scope.Last).Labl := Name_Node;
*************** package body Ch9 is
*** 141,147 ****
Error_Msg_SC ("discriminant part not allowed for single task");
Discard_Junk_List (P_Known_Discriminant_Part_Opt);
end if;
-
end if;
-- Parse optional task definition. Note that P_Task_Definition scans
--- 141,146 ----
*************** package body Ch9 is
*** 344,350 ****
if Token = Tok_Body then
Scan; -- past BODY
! Name_Node := P_Defining_Identifier;
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Left_Paren then
--- 343,349 ----
if Token = Tok_Body then
Scan; -- past BODY
! Name_Node := P_Defining_Identifier (C_Is);
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Left_Paren then
*************** package body Ch9 is
*** 381,387 ****
Scan; -- past TYPE
Protected_Node :=
New_Node (N_Protected_Type_Declaration, Protected_Sloc);
! Name_Node := P_Defining_Identifier;
Set_Defining_Identifier (Protected_Node, Name_Node);
Scope.Table (Scope.Last).Labl := Name_Node;
Set_Discriminant_Specifications
--- 380,386 ----
Scan; -- past TYPE
Protected_Node :=
New_Node (N_Protected_Type_Declaration, Protected_Sloc);
! Name_Node := P_Defining_Identifier (C_Is);
Set_Defining_Identifier (Protected_Node, Name_Node);
Scope.Table (Scope.Last).Labl := Name_Node;
Set_Discriminant_Specifications
*************** package body Ch9 is
*** 390,396 ****
else
Protected_Node :=
New_Node (N_Single_Protected_Declaration, Protected_Sloc);
! Name_Node := P_Defining_Identifier;
Set_Defining_Identifier (Protected_Node, Name_Node);
if Token = Tok_Left_Paren then
--- 389,395 ----
else
Protected_Node :=
New_Node (N_Single_Protected_Declaration, Protected_Sloc);
! Name_Node := P_Defining_Identifier (C_Is);
Set_Defining_Identifier (Protected_Node, Name_Node);
if Token = Tok_Left_Paren then
*************** package body Ch9 is
*** 631,637 ****
Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
Scan; -- past ENTRY
! Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
-- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
--- 630,637 ----
Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
Scan; -- past ENTRY
! Set_Defining_Identifier
! (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon));
-- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
*************** package body Ch9 is
*** 719,725 ****
Scan; -- past ACCEPT
Scope.Table (Scope.Last).Labl := Token_Node;
! Set_Entry_Direct_Name (Accept_Node, P_Identifier);
-- Left paren could be (Entry_Index) or Formal_Part, determine which
--- 719,725 ----
Scan; -- past ACCEPT
Scope.Table (Scope.Last).Labl := Token_Node;
! Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do));
-- Left paren could be (Entry_Index) or Formal_Part, determine which
*************** package body Ch9 is
*** 932,938 ****
begin
Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
T_For; -- past FOR
! Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier);
T_In;
Set_Discrete_Subtype_Definition
(Iterator_Node, P_Discrete_Subtype_Definition);
--- 932,938 ----
begin
Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
T_For; -- past FOR
! Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In));
T_In;
Set_Discrete_Subtype_Definition
(Iterator_Node, P_Discrete_Subtype_Definition);
Index: par-util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-util.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 par-util.adb
*** par-util.adb 21 Oct 2003 13:42:12 -0000 1.6
--- par-util.adb 30 Oct 2003 11:49:51 -0000
***************
*** 24,29 ****
--- 24,30 ----
-- --
------------------------------------------------------------------------------
+ with Csets; use Csets;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
*************** package body Util is
*** 419,425 ****
-- Is_Reserved_Identifier --
----------------------------
! function Is_Reserved_Identifier return Boolean is
begin
if not Is_Reserved_Keyword (Token) then
return False;
--- 420,426 ----
-- Is_Reserved_Identifier --
----------------------------
! function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is
begin
if not Is_Reserved_Keyword (Token) then
return False;
*************** package body Util is
*** 438,457 ****
-- keyword casing, then we return False, since it is pretty
-- clearly intended to be a keyword.
! if Ident_Casing /= Unknown
! and then Key_Casing /= Unknown
! and then Ident_Casing /= Key_Casing
! and then Determine_Token_Casing = Key_Casing
then
- return False;
-
- -- Otherwise assume that an identifier was intended
-
- else
return True;
end if;
end;
end if;
end Is_Reserved_Identifier;
----------------------
--- 439,526 ----
-- keyword casing, then we return False, since it is pretty
-- clearly intended to be a keyword.
! if Ident_Casing = Unknown
! or else Key_Casing = Unknown
! or else Ident_Casing = Key_Casing
! or else Determine_Token_Casing /= Key_Casing
then
return True;
+
+ -- Here we have a keyword written clearly with keyword casing.
+ -- In default mode, we would not be willing to consider this as
+ -- a reserved identifier, but if C is set, we may still accept it
+
+ elsif C /= None then
+ declare
+ Scan_State : Saved_Scan_State;
+ OK_Next_Tok : Boolean;
+
+ begin
+ Save_Scan_State (Scan_State);
+ Scan;
+
+ if Token_Is_At_Start_Of_Line then
+ return False;
+ end if;
+
+ case C is
+ when None =>
+ raise Program_Error;
+
+ when C_Comma_Right_Paren =>
+ OK_Next_Tok :=
+ Token = Tok_Comma or else Token = Tok_Right_Paren;
+
+ when C_Comma_Colon =>
+ OK_Next_Tok :=
+ Token = Tok_Comma or else Token = Tok_Colon;
+
+ when C_Do =>
+ OK_Next_Tok :=
+ Token = Tok_Do;
+
+ when C_Dot =>
+ OK_Next_Tok :=
+ Token = Tok_Dot;
+
+ when C_Greater_Greater =>
+ OK_Next_Tok :=
+ Token = Tok_Greater_Greater;
+
+ when C_In =>
+ OK_Next_Tok :=
+ Token = Tok_In;
+
+ when C_Is =>
+ OK_Next_Tok :=
+ Token = Tok_Is;
+
+ when C_Left_Paren_Semicolon =>
+ OK_Next_Tok :=
+ Token = Tok_Left_Paren or else Token = Tok_Semicolon;
+
+ when C_Use =>
+ OK_Next_Tok :=
+ Token = Tok_Use;
+
+ when C_Vertical_Bar_Arrow =>
+ OK_Next_Tok :=
+ Token = Tok_Vertical_Bar or else Token = Tok_Arrow;
+ end case;
+
+ Restore_Scan_State (Scan_State);
+
+ if OK_Next_Tok then
+ return True;
+ end if;
+ end;
end if;
end;
end if;
+
+ -- If we fall through it is not a reserved identifier
+
+ return False;
end Is_Reserved_Identifier;
----------------------
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: ada updates
@ 2003-10-29 12:25 Arnaud Charlet
2003-10-30 16:14 ` Joseph S. Myers
0 siblings, 1 reply; 178+ messages in thread
From: Arnaud Charlet @ 2003-10-29 12:25 UTC (permalink / raw)
To: gcc-patches
Various improvements and fixes.
In particular, a bunch of ACATS tests are fixed by these changes.
--
2003-10-29 Robert Dewar <dewar@gnat.com>
* 3vtrasym.adb, 5vtraent.ads, sprint.adb,
sem_ch10.adb: Minor reformatting
* exp_ch5.adb (Expand_Assign_Array): Test for bit unaligned operands
(Expand_Assign_Record): Test right hand side for bit unaligned as well
2003-10-29 Vasiliy Fofanov <fofanov@act-europe.fr>
* 3vtrasym.adb, 5vtraent.adb, 5vtraent.ads,
tb-alvms.c: Support for TBK$SYMBOLIZE-based symbolic traceback.
2003-10-29 Jose Ruiz <ruiz@act-europe.fr>
* exp_disp.adb:
Revert previous change, that did not work well when pragma No_Run_Time
was used in conjunction with a run-time other than ZFP.
2003-10-29 Vincent Celier <celier@gnat.com>
* make.adb:
(Gnatmake): When there are no Ada mains in attribute Main, disable the
bind and link steps only is switch -z is not used.
2003-10-29 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic: Remove duplicated setting of CC.
* Makefile.prolog: Set CC to gcc by default, to override make's
default (cc).
* einfo.h: Regenerated.
2003-10-29 Ed Schonberg <schonberg@gnat.com>
* sem_ch10.adb (Analyze_Subunit): Restore state of suppress flags for
current body, after compiling subunit.
* itypes.adb (Create_Itype): In ASIS_Mode, do not freeze the itype
when in deleted code, because gigi needs properly ordered freeze
actions to annotate types.
* freeze.adb (Is_Fully_Defined): Predicate must be recursive, to
prevent the premature freezing of record type that contains
subcomponents with a private type that does not yet have a completion.
2003-10-29 Javier Miranda <miranda@gnat.com>
* sem_ch12.adb:
(Analyze_Package_Instantiation): Check that instances can not be used in
limited with_clauses.
* sem_ch8.adb:
(Analyze_Package_Renaming): Check that limited withed packages cannot
be renamed. Improve text on error messages related to limited
with_clauses.
* einfo.adb, einfo.ads: Remove Non_Limited_Views attribute.
* sprint.adb: (Sprint_Node_Actual): Print limited with_clauses.
Update copyright notice.
* sem_ch10.adb: (Build_Limited_Views): Complete its documentation.
(Install_Limited_Context_Clauses): New subprogram that isolates all the
checks required for limited context_clauses and installs the limited
view.
(Install_Limited_Withed_Unit): Complete its documentation.
(Analyze_Context): Check that limited with_clauses are only allowed in
package specs.
(Install_Context): Call Install_Limited_Context_Clauses after the
parents have been installed.
(Install_Limited_Withed_Unit): Add documentation. Mark the installed
package as 'From_With_Type'; this mark indicates that the limited view
is installed. Used to check bad usages of limited with_clauses.
(Build_Limited_Views): Do not add shadow entities to the scope's list
of entities. Do not add real entities to the Non_Limited_Views chain.
Improve error notification.
(Remove_Context_Clauses): Remove context clauses in two phases:
limited views first and regular views later (to maintain the
stack model).
(Remove_Limited_With_Clause): If the package is analyzed then reinstall
its visible entities.
2003-10-29 Thomas Quinot <quinot@act-europe.fr>
* sem_type.adb (Specific_Type): Type Universal_Fixed is compatible
with any type that Is_Fixed_Point_Type.
* sinfo.ads: Fix documentation for Associated_Node attribute.
2003-10-29 Sergey Rybin <rybin@act-europe.fr>
* switch-c.adb (Scan_Front_End_Switches): ASIS_Mode is set now when
both '-gnatc' and '-gnatt' are specified.
* atree.adb (Initialize): Add initialization for Node_Count (set to
zero).
2003-10-29 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, case E_Subprogram): If no return value,
do not consider as Pure.
Part of implementation of function-at-a-time:
* trans.c (gnat_to_gnu_code): If IS_STMT, call expand_expr_stmt.
(tree_transform): Add new argument to build_component_ref.
(tree_transform, case N_Assignment_Statement): Make and return an
EXPR_STMT.
(tree_transform): If result IS_STMT, set flags and return it.
(gnat_expand_stmt, set_lineno_from_sloc): New functions.
* utils2.c (build_simple_component_ref, build_component_ref): Add new
arg, NO_FOLD_P.
(build_binary_op, case EQ_EXPR): Pass additional arg to it.
(build_allocator): Likewise.
* utils.c (convert_to_fat_pointer, convert_to_thin_pointer, convert):
Add new arg to build_component_ref.
(maybe_unconstrained_array, unchecked_convert): Likewise.
* ada-tree.def (EXPR_STMT): New code.
* ada-tree.h (IS_STMT, TREE_SLOC, EXPR_STMT_EXPR): New macros.
* decl.c (gnat_to_gnu_entity, case object): Add extra arg to
build_component_ref calls.
* misc.c (gnat_expand_expr): If IS_STMT, call gnat_expand_stmt.
* gigi.h (gnat_expand_stmt, set_lineno_from_sloc): New functions.
(build_component_ref): Add new argument, NO_FOLD_P.
--
Index: 3vtrasym.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vtrasym.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 3vtrasym.adb
*** 3vtrasym.adb 21 Oct 2003 13:41:51 -0000 1.1
--- 3vtrasym.adb 29 Oct 2003 09:27:51 -0000
***************
*** 34,40 ****
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with Interfaces.C;
- with Interfaces.C.Strings;
with System;
with System.Aux_DEC;
with System.Soft_Links;
--- 34,39 ----
*************** package body GNAT.Traceback.Symbolic is
*** 45,177 ****
pragma Warnings (Off);
pragma Linker_Options ("--for-linker=sys$library:trace.exe");
! use Interfaces.C.Strings;
use System;
use System.Aux_DEC;
use System.Traceback_Entries;
! type Dscdef1_Type is record
! Maxstrlen : Unsigned_Word;
! Dtype : Unsigned_Byte;
! Class : Unsigned_Byte;
! Pointer : chars_ptr;
! end record;
! for Dscdef1_Type use record
! Maxstrlen at 0 range 0 .. 15;
! Dtype at 2 range 0 .. 7;
! Class at 3 range 0 .. 7;
! Pointer at 4 range 0 .. 31;
end record;
! for Dscdef1_Type'Size use 64;
!
! Image_Buf : String (1 .. 10240);
! Image_Len : Integer;
! Image_Need_Hdr : Boolean := True;
! Image_Do_Another_Line : Boolean;
! Image_Xtra_Msg : Boolean;
!
! procedure Traceback_Image (Out_Desc : access Dscdef1_Type);
!
! procedure Traceback_Image (Out_Desc : access Dscdef1_Type) is
! Image : String (1 .. Integer (Out_Desc.Maxstrlen));
! begin
! Image := Value (Out_Desc.Pointer,
! Interfaces.C.size_t (Out_Desc.Maxstrlen));
! if Image_Do_Another_Line and then
! (Image_Need_Hdr or else
! Image (Image'First .. Image'First + 27) /=
! " image module routine")
! then
! declare
! First : Integer := Image_Len + 1;
! Last : Integer := First + Image'Length - 1;
! begin
! Image_Buf (First .. Last + 1) := Image & ASCII.LF;
! Image_Len := Last + 1;
! end;
!
! Image_Need_Hdr := False;
!
! if Image (Image'First .. Image'First + 3) = "----" then
! if Image_Xtra_Msg = False then
! Image_Xtra_Msg := True;
! else
! Image_Xtra_Msg := False;
! end if;
! end if;
!
! if Out_Desc.Maxstrlen = 79 and then not Image_Xtra_Msg then
! Image_Len := Image_Len - 1;
! Image_Do_Another_Line := False;
! end if;
! end if;
! end Traceback_Image;
! subtype User_Arg_Type is Unsigned_Longword;
! subtype Cond_Value_Type is Unsigned_Longword;
! procedure Show_Traceback
(Status : out Cond_Value_Type;
! Faulting_FP : Address;
! Faulting_SP : Address;
! Faulting_PC : Address;
! Detail_Level : Integer := Integer'Null_Parameter;
User_Act_Proc : Address := Address'Null_Parameter;
! User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter;
! Exceptionn : Unsigned_Longword := Unsigned_Longword'Null_Parameter);
! pragma Interface (External, Show_Traceback);
pragma Import_Valued_Procedure
! (Show_Traceback, "TBK$SHOW_TRACEBACK",
! (Cond_Value_Type, Address, Address, Address, Integer, Address,
! User_Arg_Type, Unsigned_Longword),
! (Value, Value, Value, Value, Reference, Value, Value, Reference),
! Detail_Level);
!
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
! Res : String (1 .. 256 * Traceback'Length);
! Len : Integer;
! Status : Cond_Value_Type;
begin
if Traceback'Length > 0 then
-
Len := 0;
-- Since image computation is not thread-safe we need task lockout
System.Soft_Links.Lock_Task.all;
- for I in Traceback'Range loop
- Image_Len := 0;
- Image_Do_Another_Line := True;
- Image_Xtra_Msg := False;
! Show_Traceback
(Status,
! FP_For (Traceback (I)),
! SP_For (Traceback (I)),
! PC_For (Traceback (I)),
! 0,
! Traceback_Image'Address);
declare
First : Integer := Len + 1;
! Last : Integer := First + Image_Len - 1;
begin
! Res (First .. Last + 1) := Image_Buf & ASCII.LF;
! Len := Last + 1;
end;
end loop;
- System.Soft_Links.Unlock_Task.all;
return Res (1 .. Len);
else
return "";
end if;
--- 44,190 ----
pragma Warnings (Off);
pragma Linker_Options ("--for-linker=sys$library:trace.exe");
! use Interfaces.C;
use System;
use System.Aux_DEC;
use System.Traceback_Entries;
! subtype User_Arg_Type is Unsigned_Longword;
! subtype Cond_Value_Type is Unsigned_Longword;
! type ASCIC is record
! Count : unsigned_char;
! Data : char_array (1 .. 255);
end record;
! pragma Convention (C, ASCIC);
! for ASCIC use record
! Count at 0 range 0 .. 7;
! Data at 1 range 0 .. 8 * 255 - 1;
! end record;
! for ASCIC'Size use 8 * 256;
! function Fetch_ASCIC is new Fetch_From_Address (ASCIC);
! procedure Symbolize
(Status : out Cond_Value_Type;
! Current_PC : in Address;
! Adjusted_PC : in Address;
! Current_FP : in Address;
! Current_R26 : in Address;
! Image_Name : out Address;
! Module_Name : out Address;
! Routine_Name : out Address;
! Line_Number : out Integer;
! Relative_PC : out Address;
! Absolute_PC : out Address;
! PC_Is_Valid : out Long_Integer;
User_Act_Proc : Address := Address'Null_Parameter;
! User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter);
! pragma Interface (External, Symbolize);
pragma Import_Valued_Procedure
! (Symbolize, "TBK$SYMBOLIZE",
! (Cond_Value_Type, Address, Address, Address, Address,
! Address, Address, Address, Integer,
! Address, Address, Long_Integer,
! Address, User_Arg_Type),
! (Value, Value, Value, Value, Value,
! Reference, Reference, Reference, Reference,
! Reference, Reference, Reference,
! Value, Value),
! User_Act_Proc);
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
! Status : Cond_Value_Type;
! Image_Name : ASCIC;
! Image_Name_Addr : Address;
! Module_Name : ASCIC;
! Module_Name_Addr : Address;
! Routine_Name : ASCIC;
! Routine_Name_Addr : Address;
! Line_Number : Integer;
! Relative_PC : Address;
! Absolute_PC : Address;
! PC_Is_Valid : Long_Integer;
! Return_Address : Address;
! Res : String (1 .. 256 * Traceback'Length);
! Len : Integer;
begin
if Traceback'Length > 0 then
Len := 0;
-- Since image computation is not thread-safe we need task lockout
+
System.Soft_Links.Lock_Task.all;
! for J in Traceback'Range loop
! if J = Traceback'Last then
! Return_Address := Address_Zero;
! else
! Return_Address := PC_For (Traceback (J + 1));
! end if;
!
! Symbolize
(Status,
! PC_For (Traceback (J)),
! PC_For (Traceback (J)),
! PV_For (Traceback (J)),
! Return_Address,
! Image_Name_Addr,
! Module_Name_Addr,
! Routine_Name_Addr,
! Line_Number,
! Relative_PC,
! Absolute_PC,
! PC_Is_Valid);
!
! Image_Name := Fetch_ASCIC (Image_Name_Addr);
! Module_Name := Fetch_ASCIC (Module_Name_Addr);
! Routine_Name := Fetch_ASCIC (Routine_Name_Addr);
declare
First : Integer := Len + 1;
! Last : Integer := First + 80 - 1;
!
begin
! Res (First .. Last) := (others => ' ');
!
! Res (First .. First + Integer (Image_Name.Count) - 1) :=
! To_Ada
! (Image_Name.Data (1 .. size_t (Image_Name.Count)),
! False);
!
! Res (First + 10 ..
! First + 10 + Integer (Module_Name.Count) - 1) :=
! To_Ada
! (Module_Name.Data (1 .. size_t (Module_Name.Count)),
! False);
!
! Res (First + 30 ..
! First + 30 + Integer (Routine_Name.Count) - 1) :=
! To_Ada
! (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
! False);
!
! Res (First + 50 ..
! First + 50 + Integer'Image (Line_Number)'Length - 1) :=
! Integer'Image (Line_Number);
!
! Res (Last) := ASCII.LF;
! Len := Last;
end;
end loop;
+ System.Soft_Links.Unlock_Task.all;
return Res (1 .. Len);
+
else
return "";
end if;
Index: 5vtraent.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vtraent.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5vtraent.adb
*** 5vtraent.adb 21 Oct 2003 13:41:52 -0000 1.1
--- 5vtraent.adb 29 Oct 2003 09:27:51 -0000
*************** package body System.Traceback_Entries is
*** 47,68 ****
end PC_For;
------------
! -- SP_For --
------------
! function SP_For (TB_Entry : Traceback_Entry) return System.Address is
begin
! return TB_Entry.SP;
! end SP_For;
!
! ------------
! -- FP_For --
! ------------
!
! function FP_For (TB_Entry : Traceback_Entry) return System.Address is
! begin
! return TB_Entry.FP;
! end FP_For;
------------------
-- TB_Entry_For --
--- 47,59 ----
end PC_For;
------------
! -- PV_For --
------------
! function PV_For (TB_Entry : Traceback_Entry) return System.Address is
begin
! return TB_Entry.PV;
! end PV_For;
------------------
-- TB_Entry_For --
*************** package body System.Traceback_Entries is
*** 70,76 ****
function TB_Entry_For (PC : System.Address) return Traceback_Entry is
begin
! return (PC => PC, SP => System.Null_Address, FP => System.Null_Address);
end TB_Entry_For;
end System.Traceback_Entries;
--- 61,67 ----
function TB_Entry_For (PC : System.Address) return Traceback_Entry is
begin
! return (PC => PC, PV => System.Null_Address);
end TB_Entry_For;
end System.Traceback_Entries;
Index: 5vtraent.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vtraent.ads,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5vtraent.ads
*** 5vtraent.ads 21 Oct 2003 13:41:52 -0000 1.1
--- 5vtraent.ads 29 Oct 2003 09:27:51 -0000
***************
*** 35,68 ****
-- --
------------------------------------------------------------------------------
! -- This is the Alpha/OpenVMS version of this package.
package System.Traceback_Entries is
- type Traceback_Entry is private;
-
- Null_TB_Entry : constant Traceback_Entry;
-
- function PC_For (TB_Entry : Traceback_Entry) return System.Address;
- function SP_For (TB_Entry : Traceback_Entry) return System.Address;
- function FP_For (TB_Entry : Traceback_Entry) return System.Address;
-
- function TB_Entry_For (PC : System.Address) return Traceback_Entry;
-
- private
-
type Traceback_Entry is record
PC : System.Address;
! SP : System.Address;
! FP : System.Address;
end record;
pragma Suppress_Initialization (Traceback_Entry);
! Null_TB_Entry : constant Traceback_Entry
! := (PC => System.Null_Address,
! SP => System.Null_Address,
! FP => System.Null_Address);
end System.Traceback_Entries;
--- 35,59 ----
-- --
------------------------------------------------------------------------------
! -- This is the Alpha/OpenVMS version of this package
package System.Traceback_Entries is
type Traceback_Entry is record
PC : System.Address;
! PV : System.Address;
end record;
pragma Suppress_Initialization (Traceback_Entry);
! Null_TB_Entry : constant Traceback_Entry :=
! (PC => System.Null_Address,
! PV => System.Null_Address);
!
! function PC_For (TB_Entry : Traceback_Entry) return System.Address;
! function PV_For (TB_Entry : Traceback_Entry) return System.Address;
!
! function TB_Entry_For (PC : System.Address) return Traceback_Entry;
end System.Traceback_Entries;
Index: ada-tree.def
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.def,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 ada-tree.def
*** ada-tree.def 21 Oct 2003 13:41:57 -0000 1.6
--- ada-tree.def 29 Oct 2003 09:27:51 -0000
*************** DEFTREECODE (GNAT_NOP_EXPR, "gnat_nop_ex
*** 77,79 ****
--- 77,87 ----
??? This should be redone at some point. */
DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 0)
+
+ /* Here are the tree codes for the statement types known to Ada. These
+ must be at the end of this file to allow IS_STMT to work.
+
+ We start with an expression statement, whose only operand is an
+ expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of
+ the expression (such as a MODIFY_EXPR) and discarding its result. */
+ DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1)
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 ada-tree.h
*** ada-tree.h 24 Apr 2003 17:53:57 -0000 1.8
--- ada-tree.h 29 Oct 2003 09:27:51 -0000
*************** struct lang_type GTY(())
*** 275,277 ****
--- 275,288 ----
node. We need to find some other place to store it! */
#define TREE_LOOP_ID(NODE) \
(((union lang_tree_node *)TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id)
+
+ /* Define fields and macros for statements.
+
+ Start by defining which tree codes are used for statements. */
+ #define IS_STMT(NODE) (TREE_CODE_CLASS (TREE_CODE (NODE)) == 's')
+
+ /* We store the Sloc in statement nodes. */
+ #define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE))
+
+ /* There is just one field in an EXPR_STMT: the expression. */
+ #define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 atree.adb
*** atree.adb 21 Oct 2003 13:41:58 -0000 1.7
--- atree.adb 29 Oct 2003 09:27:52 -0000
*************** package body Atree is
*** 838,843 ****
--- 838,844 ----
pragma Warnings (Off, Dummy);
begin
+ Node_Count := 0;
Atree_Private_Part.Nodes.Init;
Orig_Nodes.Init;
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.18
diff -u -c -3 -p -r1.18 decl.c
*** decl.c 22 Oct 2003 21:34:51 -0000 1.18
--- decl.c 29 Oct 2003 09:27:54 -0000
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 946,952 ****
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))));
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
--- 946,952 ----
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0);
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 990,996 ****
(build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type)),
gnu_expr));
gnu_type = build_reference_type (gnu_type);
--- 990,996 ----
(build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type), 0),
gnu_expr));
gnu_type = build_reference_type (gnu_type);
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 998,1004 ****
= build_unary_op
(ADDR_EXPR, gnu_type,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type)));
gnu_size = 0;
used_by_ref = 1;
--- 998,1004 ----
= build_unary_op
(ADDR_EXPR, gnu_type,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type), 0));
gnu_size = 0;
used_by_ref = 1;
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 3534,3539 ****
--- 3534,3546 ----
/* ??? For now, don't consider nested functions pure. */
if (! global_bindings_p ())
+ pure_flag = 0;
+
+ /* A subprogram (something that doesn't return anything) shouldn't
+ be considered Pure since there would be no reason for such a
+ subprogram. Note that procedures with Out (or In Out) parameters
+ have already been converted into a function with a return type. */
+ if (TREE_CODE (gnu_return_type) == VOID_TYPE)
pure_flag = 0;
gnu_type
Index: einfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 einfo.adb
*** einfo.adb 21 Oct 2003 13:41:58 -0000 1.9
--- einfo.adb 29 Oct 2003 09:27:55 -0000
*************** package body Einfo is
*** 80,86 ****
-- Hiding_Loop_Variable Node8
-- Mechanism Uint8 (but returns Mechanism_Type)
-- Normalized_First_Bit Uint8
- -- Non_Limited_Views Elist8
-- Class_Wide_Type Node9
-- Current_Value Node9
--- 80,85 ----
*************** package body Einfo is
*** 1798,1814 ****
function Non_Limited_View (Id : E) return E is
begin
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type
! or else Ekind (Id) = E_Package);
return Node17 (Id);
end Non_Limited_View;
- function Non_Limited_Views (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Elist8 (Id);
- end Non_Limited_Views;
-
function Nonzero_Is_True (Id : E) return B is
begin
pragma Assert (Root_Type (Id) = Standard_Boolean);
--- 1797,1806 ----
function Non_Limited_View (Id : E) return E is
begin
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type);
return Node17 (Id);
end Non_Limited_View;
function Nonzero_Is_True (Id : E) return B is
begin
pragma Assert (Root_Type (Id) = Standard_Boolean);
*************** package body Einfo is
*** 2845,2851 ****
begin
pragma Assert
(Is_Type (Id)
! or else Ekind (Id) = E_Package);
Set_Flag159 (Id, V);
end Set_From_With_Type;
--- 2837,2843 ----
begin
pragma Assert
(Is_Type (Id)
! or else Ekind (Id) = E_Package);
Set_Flag159 (Id, V);
end Set_From_With_Type;
*************** package body Einfo is
*** 3741,3757 ****
procedure Set_Non_Limited_View (Id : E; V : E) is
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type
! or else Ekind (Id) = E_Package);
begin
Set_Node17 (Id, V);
end Set_Non_Limited_View;
-
- procedure Set_Non_Limited_Views (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Elist8 (Id, V);
- end Set_Non_Limited_Views;
procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
begin
--- 3733,3742 ----
procedure Set_Non_Limited_View (Id : E; V : E) is
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type);
begin
Set_Node17 (Id, V);
end Set_Non_Limited_View;
procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
begin
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.12
diff -u -c -3 -p -r1.12 einfo.ads
*** einfo.ads 21 Oct 2003 13:41:58 -0000 1.12
--- einfo.ads 29 Oct 2003 09:27:57 -0000
*************** package Einfo is
*** 2381,2388 ****
-- Present in non-generic package entities that are not instances.
-- The elements of this list are the shadow entities created for the
-- types and local packages that are declared in a package that appears
! -- in a limited_with clause. This list and Non_Limited_Views are built
! -- at the same time, and their elements are in one-one correspondence.
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
--- 2381,2387 ----
-- Present in non-generic package entities that are not instances.
-- The elements of this list are the shadow entities created for the
-- types and local packages that are declared in a package that appears
! -- in a limited_with clause.
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
*************** package Einfo is
*** 2551,2564 ****
-- is other than a power of 2.
-- Non_Limited_View (Node17)
! -- Present in incomplete types, and local packages that are the
! -- shadow entities created when analyzing a limited_with_clause.
! -- Points to the definining entity in the original declaration.
!
! -- Non_Limited_Views (Elist8)
! -- Present in non-generic packages that are not instances. The elements
! -- of this list are defining identifiers for types and local packages
! -- declared within a package that appears in a limited_with clause.
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
--- 2550,2558 ----
-- is other than a power of 2.
-- Non_Limited_View (Node17)
! -- Present in incomplete types that are the shadow entities
! -- created when analyzing a limited_with_clause. Points to the
! -- definining entity in the original declaration.
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
*************** package Einfo is
*** 4388,4394 ****
-- E_Package
-- E_Generic_Package
-- Dependent_Instances (Elist8) (for an instance)
- -- Non_Limited_Views (Elist8) (non-generic, not instance)
-- Renaming_Map (Uint9)
-- Handler_Records (List10) (non-generic case only)
-- Generic_Homonym (Node11) (generic case only)
--- 4382,4387 ----
*************** package Einfo is
*** 5152,5158 ****
function No_Return (Id : E) return B;
function Non_Binary_Modulus (Id : E) return B;
function Non_Limited_View (Id : E) return E;
- function Non_Limited_Views (Id : E) return L;
function Nonzero_Is_True (Id : E) return B;
function Normalized_First_Bit (Id : E) return U;
function Normalized_Position (Id : E) return U;
--- 5145,5150 ----
*************** package Einfo is
*** 5624,5630 ****
procedure Set_No_Return (Id : E; V : B := True);
procedure Set_Non_Binary_Modulus (Id : E; V : B := True);
procedure Set_Non_Limited_View (Id : E; V : E);
- procedure Set_Non_Limited_Views (Id : E; V : L);
procedure Set_Nonzero_Is_True (Id : E; V : B := True);
procedure Set_Normalized_First_Bit (Id : E; V : U);
procedure Set_Normalized_Position (Id : E; V : U);
--- 5616,5621 ----
*************** package Einfo is
*** 6150,6156 ****
pragma Inline (No_Return);
pragma Inline (Non_Binary_Modulus);
pragma Inline (Non_Limited_View);
- pragma Inline (Non_Limited_Views);
pragma Inline (Nonzero_Is_True);
pragma Inline (Normalized_First_Bit);
pragma Inline (Normalized_Position);
--- 6141,6146 ----
*************** package Einfo is
*** 6455,6461 ****
pragma Inline (Set_No_Return);
pragma Inline (Set_Non_Binary_Modulus);
pragma Inline (Set_Non_Limited_View);
- pragma Inline (Set_Non_Limited_Views);
pragma Inline (Set_Nonzero_Is_True);
pragma Inline (Set_Normalized_First_Bit);
pragma Inline (Set_Normalized_Position);
--- 6445,6450 ----
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 exp_ch5.adb
*** exp_ch5.adb 27 Oct 2003 14:27:17 -0000 1.10
--- exp_ch5.adb 29 Oct 2003 09:27:58 -0000
*************** package body Exp_Ch5 is
*** 98,112 ****
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
! -- if the object involved is small (64-bits) or if it is aligned on
-- a byte boundary (starts on a byte, and ends on a byte). However,
-- problems arise for large components that are not byte aligned,
! -- since the assignment may clobber other components that share
! -- bit positions in the starting or ending bytes. This function is
! -- used to detect such situations, so that the assignment can be
! -- handled component-wise. A value of False means that either the
! -- object is known to be greater than 64 bits, or that it is known
! -- to be byte aligned. True is returned if the object is known to
-- be greater than 64 bits, and is known to be unaligned. As implied
-- by the name, the result is conservative, in that if the compiler
-- cannot determine these conditions at compile time, True is returned.
--- 98,114 ----
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
! -- if the objects involved are small (64-bits) or are both aligned on
-- a byte boundary (starts on a byte, and ends on a byte). However,
-- problems arise for large components that are not byte aligned,
! -- since the assignment may clobber other components that share bit
! -- positions in the starting or ending bytes, and in the case of
! -- components not starting on a byte boundary, the back end cannot
! -- even manage to extract the value. This function is used to detect
! -- such situations, so that the assignment can be handled component-wise.
! -- A value of False means that either the object is known to be greater
! -- than 64 bits, or that it is known to be byte aligned (and occupy an
! -- integral number of bytes. True is returned if the object is known to
-- be greater than 64 bits, and is known to be unaligned. As implied
-- by the name, the result is conservative, in that if the compiler
-- cannot determine these conditions at compile time, True is returned.
*************** package body Exp_Ch5 is
*** 368,373 ****
--- 370,383 ----
R_Type := Get_Actual_Subtype (Act_Rhs);
Loop_Required := True;
+ -- We require a loop if the left side is possibly bit unaligned
+
+ elsif Maybe_Bit_Aligned_Large_Component (Lhs)
+ or else
+ Maybe_Bit_Aligned_Large_Component (Rhs)
+ then
+ Loop_Required := True;
+
-- Arrays with controlled components are expanded into a loop
-- to force calls to adjust at the component level.
*************** package body Exp_Ch5 is
*** 1016,1022 ****
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
! elsif Maybe_Bit_Aligned_Large_Component (Lhs) then
null;
-- If neither condition met, then nothing special to do, the back end
--- 1026,1035 ----
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
! elsif Maybe_Bit_Aligned_Large_Component (Lhs)
! or
! Maybe_Bit_Aligned_Large_Component (Rhs)
! then
null;
-- If neither condition met, then nothing special to do, the back end
Index: exp_disp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_disp.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 exp_disp.adb
*** exp_disp.adb 24 Oct 2003 13:02:41 -0000 1.6
--- exp_disp.adb 29 Oct 2003 09:27:58 -0000
*************** package body Exp_Disp is
*** 922,931 ****
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
--- 922,932 ----
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available, or in No_Run_Time mode
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
+ and then not No_Run_Time_Mode
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 freeze.adb
*** freeze.adb 21 Oct 2003 13:42:00 -0000 1.7
--- freeze.adb 29 Oct 2003 09:28:00 -0000
*************** package body Freeze is
*** 124,130 ****
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
! -- true if T is not private, or has a full view.
procedure Process_Default_Expressions
(E : Entity_Id;
--- 124,135 ----
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
! -- true if T is not private and has no private components, or has a full
! -- view. Used to determine whether the designated type of an access type
! -- should be frozen when the access type is frozen. This is done when an
! -- allocator is frozen, or an expression that may involve attributes of
! -- the designated type. Otherwise freezing the access type does not freeze
! -- the designated type.
procedure Process_Default_Expressions
(E : Entity_Id;
*************** package body Freeze is
*** 4246,4260 ****
-- Is_Fully_Defined --
-----------------------
- -- Should this be in Sem_Util ???
-
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin
if Ekind (T) = E_Class_Wide_Type then
return Is_Fully_Defined (Etype (T));
! else
! return not Is_Private_Type (T)
! or else Present (Full_View (Base_Type (T)));
end if;
end Is_Fully_Defined;
--- 4251,4288 ----
-- Is_Fully_Defined --
-----------------------
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin
if Ekind (T) = E_Class_Wide_Type then
return Is_Fully_Defined (Etype (T));
!
! elsif Is_Array_Type (T) then
! return Is_Fully_Defined (Component_Type (T));
!
! elsif Is_Record_Type (T)
! and not Is_Private_Type (T)
! then
!
! -- Verify that the record type has no components with
! -- private types without completion.
!
! declare
! Comp : Entity_Id;
! begin
! Comp := First_Component (T);
!
! while Present (Comp) loop
! if not Is_Fully_Defined (Etype (Comp)) then
! return False;
! end if;
!
! Next_Component (Comp);
! end loop;
! return True;
! end;
!
! else return not Is_Private_Type (T)
! or else Present (Full_View (Base_Type (T)));
end if;
end Is_Fully_Defined;
Index: gigi.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gigi.h,v
retrieving revision 1.17
diff -u -c -3 -p -r1.17 gigi.h
*** gigi.h 21 Oct 2003 13:42:05 -0000 1.17
--- gigi.h 29 Oct 2003 09:28:00 -0000
*************** extern void gnat_to_code PARAMS ((Node_I
*** 190,195 ****
--- 190,198 ----
code. */
extern tree gnat_to_gnu PARAMS ((Node_Id));
+ /* GNU_STMT is a statement. We generate code for that statement. */
+ extern void gnat_expand_stmt PARAMS ((tree));
+
/* Do the processing for the declaration of a GNAT_ENTITY, a type. If
a separate Freeze node exists, delay the bulk of the processing. Otherwise
make a GCC type for GNAT_ENTITY and set up the correspondance. */
*************** extern void process_type PARAMS ((Entity
*** 201,206 ****
--- 204,212 ----
input_line. If WRITE_NOTE_P is true, emit a line number note. */
extern void set_lineno PARAMS ((Node_Id, int));
+ /* Likewise, but passed a Sloc. */
+ extern void set_lineno_from_sloc PARAMS ((Source_Ptr, int));
+
/* Post an error message. MSG is the error message, properly annotated.
NODE is the node at which to post the error and the node to use for the
"&" substitution. */
*************** extern tree gnat_build_constructor PARAM
*** 699,706 ****
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
! for the field, or both. */
! extern tree build_component_ref PARAMS((tree, tree, tree));
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
--- 705,712 ----
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
! for the field, or both. Don't fold the result if NO_FOLD_P. */
! extern tree build_component_ref PARAMS((tree, tree, tree, int));
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
Index: itypes.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/itypes.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 itypes.adb
*** itypes.adb 21 Oct 2003 13:42:09 -0000 1.5
--- itypes.adb 29 Oct 2003 09:28:00 -0000
***************
*** 26,31 ****
--- 26,32 ----
with Atree; use Atree;
with Einfo; use Einfo;
+ with Opt; use Opt;
with Sem; use Sem;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
*************** package body Itypes is
*** 64,70 ****
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, Related_Nod);
! if In_Deleted_Code then
Set_Is_Frozen (Typ);
end if;
--- 65,73 ----
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, Related_Nod);
! if In_Deleted_Code
! and then not ASIS_Mode
! then
Set_Is_Frozen (Typ);
end if;
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 make.adb
*** make.adb 27 Oct 2003 14:27:17 -0000 1.19
--- make.adb 29 Oct 2003 09:28:02 -0000
*************** package body Make is
*** 3623,3632 ****
if not At_Least_One_Main then
-- First make sure that the binder and the linker
! -- will not be invoked.
! Do_Bind_Step := False;
! Do_Link_Step := False;
-- Put all the sources in the queue
--- 3623,3634 ----
if not At_Least_One_Main then
-- First make sure that the binder and the linker
! -- will not be invoked if -z is not used.
! if not No_Main_Subprogram then
! Do_Bind_Step := False;
! Do_Link_Step := False;
! end if;
-- Put all the sources in the queue
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.3
diff -u -c -3 -p -r1.3 Makefile.generic
*** Makefile.generic 27 Oct 2003 14:27:17 -0000 1.3
--- Makefile.generic 29 Oct 2003 09:28:02 -0000
*************** ifndef MAIN
*** 67,76 ****
MAIN=ada
endif
- ifndef CC
- CC=gcc
- endif
-
ifndef ADA_SPEC
ADA_SPEC=.ads
endif
--- 67,72 ----
Index: Makefile.prolog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.prolog,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 Makefile.prolog
*** Makefile.prolog 21 Oct 2003 13:41:53 -0000 1.1
--- Makefile.prolog 29 Oct 2003 09:28:02 -0000
*************** C_EXT:=.c
*** 39,44 ****
--- 39,45 ----
CXX_EXT:=.cc
AR_EXT=.a
OBJ_EXT=.o
+ CC=gcc
# Default target is to build (compile/bind/link)
# Target build is defined in Makefile.generic
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/misc.c,v
retrieving revision 1.66
diff -u -c -3 -p -r1.66 misc.c
*** misc.c 21 Oct 2003 13:42:09 -0000 1.66
--- misc.c 29 Oct 2003 09:28:03 -0000
*************** gnat_expand_expr (tree exp, rtx target,
*** 544,549 ****
--- 544,556 ----
tree new;
rtx result;
+ /* If this is a statement, call the expansion routine for statements. */
+ if (IS_STMT (exp))
+ {
+ gnat_expand_stmt (exp);
+ return const0_rtx;
+ }
+
/* Update EXP to be the new expression to expand. */
switch (TREE_CODE (exp))
{
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 sem_ch10.adb
*** sem_ch10.adb 21 Oct 2003 13:42:19 -0000 1.9
--- sem_ch10.adb 29 Oct 2003 09:28:04 -0000
*************** package body Sem_Ch10 is
*** 73,80 ****
-- Analyzes items in the context clause of compilation unit
procedure Build_Limited_Views (N : Node_Id);
! -- Build list of shadow entities for a package mentioned in a
! -- limited_with clause.
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
--- 73,82 ----
-- Analyzes items in the context clause of compilation unit
procedure Build_Limited_Views (N : Node_Id);
! -- Build and decorate the list of shadow entities for a package mentioned
! -- in a limited_with clause. If the package was not previously analyzed
! -- then it also performs a basic decoration of the real entities; this
! -- is required to do not pass non-decorated entities to the back-end.
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
*************** package body Sem_Ch10 is
*** 123,132 ****
-- Subsidiary to previous one. Process only with_ and use_clauses for
-- current unit and its library unit if any.
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
! -- structures for the current compilation. Verify that there is no
! -- regular with_clause in the context.
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
--- 125,137 ----
-- Subsidiary to previous one. Process only with_ and use_clauses for
-- current unit and its library unit if any.
+ procedure Install_Limited_Context_Clauses (N : Node_Id);
+ -- Subsidiary to Install_Context. Process only limited with_clauses
+ -- for current unit.
+
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
! -- structures for the current compilation.
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
*************** package body Sem_Ch10 is
*** 782,788 ****
begin
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
! -- b) The second pass add implicit limited_with clauses for the
-- the parents of child units.
-- c) The third pass analyzes limited_with clauses.
--- 787,793 ----
begin
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
! -- b) The second pass add implicit limited_with clauses for
-- the parents of child units.
-- c) The third pass analyzes limited_with clauses.
*************** package body Sem_Ch10 is
*** 792,798 ****
-- For with clause, analyze the with clause, and then update
-- the version, since we are dependent on a unit that we with.
! if Nkind (Item) = N_With_Clause then
-- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existant unit)
--- 797,805 ----
-- For with clause, analyze the with clause, and then update
-- the version, since we are dependent on a unit that we with.
! if Nkind (Item) = N_With_Clause
! and then not Limited_Present (Item)
! then
-- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existant unit)
*************** package body Sem_Ch10 is
*** 845,850 ****
--- 852,862 ----
and then Limited_Present (Item)
then
+ if Nkind (Unit (N)) /= N_Package_Declaration then
+ Error_Msg_N ("limited with_clause only allowed in"
+ & " package specification", Item);
+ end if;
+
-- Skip analyzing with clause if no unit, see above.
if Present (Library_Unit (Item)) then
*************** package body Sem_Ch10 is
*** 1239,1244 ****
--- 1251,1257 ----
Num_Scopes : Int := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Enclosing_Child : Entity_Id := Empty;
+ Svg : constant Suppress_Array := Scope_Suppress;
procedure Analyze_Subunit_Context;
-- Capture names in use clauses of the subunit. This must be done
*************** package body Sem_Ch10 is
*** 1482,1487 ****
--- 1495,1504 ----
Re_Install_Use_Clauses;
Install_Context (N);
+ -- Restore state of suppress flags for current body.
+
+ Scope_Suppress := Svg;
+
-- If the subunit is within a child unit, then siblings of any
-- parent unit that appear in the context clause of the subunit
-- must also be made immediately visible.
*************** package body Sem_Ch10 is
*** 2534,2539 ****
--- 2551,2558 ----
Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
end if;
+ Install_Limited_Context_Clauses (N);
+
Check_With_Type_Clauses (N);
end Install_Context;
*************** package body Sem_Ch10 is
*** 2548,2554 ****
Check_Private : Boolean := False;
Decl_Node : Node_Id;
Lib_Parent : Entity_Id;
- Lim_Present : Boolean := False;
begin
-- Loop through context clauses to find the with/use clauses.
--- 2567,2572 ----
*************** package body Sem_Ch10 is
*** 2565,2573 ****
then
if Limited_Present (Item) then
! -- Second pass will be necessary
- Lim_Present := True;
goto Continue;
-- If Name (Item) is not an entity name, something is wrong, and
--- 2583,2590 ----
then
if Limited_Present (Item) then
! -- Limited withed units will be installed later.
goto Continue;
-- If Name (Item) is not an entity name, something is wrong, and
*************** package body Sem_Ch10 is
*** 2703,2709 ****
if Is_Child_Spec (Lib_Unit) then
! -- The unit also has implicit withs on its own parents.
if No (Context_Items (N)) then
Set_Context_Items (N, New_List);
--- 2720,2726 ----
if Is_Child_Spec (Lib_Unit) then
! -- The unit also has implicit withs on its own parents
if No (Context_Items (N)) then
Set_Context_Items (N, New_List);
*************** package body Sem_Ch10 is
*** 2778,2800 ****
if Check_Private then
Check_Private_Child_Unit (N);
end if;
! -- Second pass: install limited_with clauses
! if Lim_Present then
! Item := First (Context_Items (N));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
! and then Limited_Present (Item)
then
! Install_Limited_Withed_Unit (Item);
end if;
Next (Item);
end loop;
! end if;
! end Install_Context_Clauses;
---------------------
-- Install_Parents --
--- 2795,3018 ----
if Check_Private then
Check_Private_Child_Unit (N);
end if;
+ end Install_Context_Clauses;
! -------------------------------------
! -- Install_Limited_Context_Clauses --
! -------------------------------------
! procedure Install_Limited_Context_Clauses (N : Node_Id) is
! Item : Node_Id;
!
! procedure Check_Parent (P : Node_Id; W : Node_Id);
! -- Check that the unlimited view of a given compilation_unit is not
! -- already visible in the parents (neither immediately through the
! -- context clauses, nor indirectly through "use + renamings").
!
! procedure Check_Private_Limited_Withed_Unit (N : Node_Id);
! -- Check that if a limited_with clause of a given compilation_unit
! -- mentions a private child of some library unit, then the given
! -- compilation_unit shall be the declaration of a private descendant
! -- of that library unit.
!
! procedure Check_Withed_Unit (W : Node_Id);
! -- Check that a limited with_clause does not appear in the same
! -- context_clause as a nonlimited with_clause that mentions
! -- the same library.
!
! --------------------
! -- Check_Parent --
! --------------------
!
! procedure Check_Parent (P : Node_Id; W : Node_Id) is
! Item : Node_Id;
! Spec : Node_Id;
! WEnt : Entity_Id;
! Nam : Node_Id;
! E : Entity_Id;
! E2 : Entity_Id;
+ begin
+ pragma Assert (Nkind (W) = N_With_Clause);
+
+ -- Step 1: Check if the unlimited view is installed in the parent
+
+ Item := First (Context_Items (P));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
! and then not Limited_Present (Item)
! and then not Implicit_With (Item)
! and then Library_Unit (Item) = Library_Unit (W)
then
! Error_Msg_N ("unlimited view visible in ancestor", W);
! return;
end if;
Next (Item);
end loop;
!
! -- Step 2: Check "use + renamings"
!
! WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
! Spec := Specification (Unit (P));
!
! -- We tried to traverse the list of entities corresponding to the
! -- defining entity of the package spec. However, first_entity was
! -- found to be 'empty'. Don't know why???
!
! -- Def := Defining_Unit_Name (Spec);
! -- Ent := First_Entity (Def);
!
! -- As a workaround we traverse the list of visible declarations ???
!
! Item := First (Visible_Declarations (Spec));
! while Present (Item) loop
!
! if Nkind (Item) = N_Use_Package_Clause then
!
! -- Traverse the list of packages
!
! Nam := First (Names (Item));
!
! while Present (Nam) loop
! E := Entity (Nam);
!
! pragma Assert (Present (Parent (E)));
!
! if Nkind (Parent (E))
! = N_Package_Renaming_Declaration
! and then Renamed_Entity (E) = WEnt
! then
! Error_Msg_N ("unlimited view visible through "
! & "use_clause + renamings", W);
! return;
!
! elsif Nkind (Parent (E)) = N_Package_Specification then
!
! -- The use clause may refer to a local package.
! -- Check all the enclosing scopes.
!
! E2 := E;
! while E2 /= Standard_Standard
! and then E2 /= WEnt loop
! E2 := Scope (E2);
! end loop;
!
! if E2 = WEnt then
! Error_Msg_N ("unlimited view visible through "
! & "use_clause ", W);
! return;
! end if;
!
! end if;
! Next (Nam);
! end loop;
!
! end if;
!
! Next (Item);
! end loop;
!
! -- Recursive call to check all the ancestors
!
! if Is_Child_Spec (Unit (P)) then
! Check_Parent (P => Parent_Spec (Unit (P)), W => W);
! end if;
! end Check_Parent;
!
! ---------------------------------------
! -- Check_Private_Limited_Withed_Unit --
! ---------------------------------------
!
! procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is
! C : Node_Id;
! P : Node_Id;
! Found : Boolean := False;
!
! begin
! -- If the current compilation unit is not private we don't
! -- need to check anything else.
!
! if not Private_Present (Parent (N)) then
! Found := False;
!
! else
! -- Compilation unit of the parent of the withed library unit
!
! P := Parent_Spec (Unit (Library_Unit (N)));
!
! -- Traverse all the ancestors of the current compilation
! -- unit to check if it is a descendant of named library unit.
!
! C := Parent (N);
! while Present (Parent_Spec (Unit (C))) loop
! C := Parent_Spec (Unit (C));
!
! if C = P then
! Found := True;
! exit;
! end if;
! end loop;
! end if;
!
! if not Found then
! Error_Msg_N ("current unit is not a private descendant"
! & " of the withed unit ('R'M 10.1.2(8)", N);
! end if;
! end Check_Private_Limited_Withed_Unit;
!
! -----------------------
! -- Check_Withed_Unit --
! -----------------------
!
! procedure Check_Withed_Unit (W : Node_Id) is
! Item : Node_Id;
!
! begin
! -- A limited with_clause can not appear in the same context_clause
! -- as a nonlimited with_clause which mentions the same library.
!
! Item := First (Context_Items (N));
! while Present (Item) loop
! if Nkind (Item) = N_With_Clause
! and then not Limited_Present (Item)
! and then not Implicit_With (Item)
! and then Library_Unit (Item) = Library_Unit (W)
! then
! Error_Msg_N ("limited and unlimited view "
! & "not allowed in the same context clauses", W);
! return;
! end if;
!
! Next (Item);
! end loop;
! end Check_Withed_Unit;
!
! -- Start of processing for Install_Limited_Context_Clauses
!
! begin
! Item := First (Context_Items (N));
! while Present (Item) loop
! if Nkind (Item) = N_With_Clause
! and then Limited_Present (Item)
! then
!
! Check_Withed_Unit (Item);
!
! if Private_Present (Library_Unit (Item)) then
! Check_Private_Limited_Withed_Unit (Item);
! end if;
!
! if Is_Child_Spec (Unit (N)) then
! Check_Parent (Parent_Spec (Unit (N)), Item);
! end if;
!
! Install_Limited_Withed_Unit (Item);
! end if;
!
! Next (Item);
! end loop;
! end Install_Limited_Context_Clauses;
---------------------
-- Install_Parents --
*************** package body Sem_Ch10 is
*** 2917,2922 ****
--- 3135,3144 ----
-- the current unit.
-- Shouldn't this be somewhere more general ???
+ -----------------
+ -- Is_Ancestor --
+ -----------------
+
function Is_Ancestor (E : Entity_Id) return Boolean is
Par : Entity_Id;
*************** package body Sem_Ch10 is
*** 3047,3062 ****
P := Defining_Identifier (P);
end if;
if Analyzed (Cunit (Unum))
and then Is_Immediately_Visible (P)
then
- -- disallow naming in a limited with clause a unit (or renaming
- -- thereof) that is mentioned in an enclosing normal with clause.
- Error_Msg_N ("limited_with not allowed on unit already withed", N);
-
return;
end if;
if not Analyzed (Cunit (Unum)) then
Set_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
--- 3269,3305 ----
P := Defining_Identifier (P);
end if;
+ -- A common usage of the limited-with is to have a limited-with
+ -- in the package spec, and a normal with in its package body.
+ -- For example:
+
+ -- limited with X; -- [1]
+ -- package A is ...
+
+ -- with X; -- [2]
+ -- package body A is ...
+
+ -- The compilation of A's body installs the entities of its
+ -- withed packages (the context clauses found at [2]) and
+ -- then the context clauses of its specification (found at [1]).
+
+ -- As a consequence, at point [1] the specification of X has been
+ -- analyzed and it is immediately visible. According to the semantics
+ -- of the limited-with context clauses we don't install the limited
+ -- view because the full view of X supersedes its limited view.
+
if Analyzed (Cunit (Unum))
and then Is_Immediately_Visible (P)
then
return;
end if;
+ if Debug_Flag_I then
+ Write_Str ("install limited view of ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
+
if not Analyzed (Cunit (Unum)) then
Set_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
*************** package body Sem_Ch10 is
*** 3067,3072 ****
--- 3310,3322 ----
if Current_Entity (P) /= P then
Set_Homonym (P, Current_Entity (P));
Set_Current_Entity (P);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
+
end if;
if Is_Child_Package then
*************** package body Sem_Ch10 is
*** 3084,3090 ****
--- 3334,3342 ----
Set_Scope (P, Parent_Id);
end;
end if;
+
else
+
-- If the unit appears in a previous regular with_clause, the
-- regular entities must be unchained before the shadow ones
-- are made accessible.
*************** package body Sem_Ch10 is
*** 3099,3104 ****
--- 3351,3357 ----
Next_Entity (Ent);
end loop;
end;
+
end if;
-- The package must be visible while the with_type clause is active,
*************** package body Sem_Ch10 is
*** 3116,3121 ****
--- 3369,3381 ----
if not In_Chain (Lim_Typ) then
Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
Set_Current_Entity (Lim_Typ);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (Lim_Typ));
+ Write_Eol;
+ end if;
+
end if;
Next_Elmt (Lim_Elmt);
*************** package body Sem_Ch10 is
*** 3125,3130 ****
--- 3385,3391 ----
-- accordingly, to uninstall it when the context is removed.
Set_Limited_View_Installed (N);
+ Set_From_With_Type (P);
end Install_Limited_Withed_Unit;
-------------------------
*************** package body Sem_Ch10 is
*** 3136,3141 ****
--- 3397,3409 ----
P : constant Entity_Id := Scope (Uname);
begin
+
+ if Debug_Flag_I then
+ Write_Str ("install withed unit ");
+ Write_Name (Chars (Uname));
+ Write_Eol;
+ end if;
+
-- We do not apply the restrictions to an internal unit unless
-- we are compiling the internal unit as a main unit. This check
-- is also skipped for dummy units (for missing packages).
*************** package body Sem_Ch10 is
*** 3308,3313 ****
--- 3576,3588 ----
-- Construct list of shadow entities and attach it to entity of
-- package that is mentioned in a limited_with clause.
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id;
+ -- This function is similar to New_Internal_Entity, except that the
+ -- entity is not added to the scope's list of entities.
+
------------------------------
-- Decorate_Incomplete_Type --
------------------------------
*************** package body Sem_Ch10 is
*** 3324,3330 ****
Set_Stored_Constraint (E, No_Elist);
Set_Full_View (E, Empty);
Init_Size_Align (E);
- Set_Has_Unknown_Discriminants (E);
end Decorate_Incomplete_Type;
--------------------------
--- 3599,3604 ----
*************** package body Sem_Ch10 is
*** 3374,3395 ****
Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification;
-----------------
-- Build_Chain --
-----------------
procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
! Decl : Node_Id;
begin
Decl := First (Visible_Declarations (Spec));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration then
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed (Cunit (Unum)) then
! if Tagged_Present (Type_Definition (Decl)) then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
--- 3648,3701 ----
Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification;
+ -------------------------
+ -- New_Internal_Entity --
+ -------------------------
+
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id
+ is
+ N : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc_Value,
+ Chars => New_Internal_Name (Id_Char));
+
+ begin
+ Set_Ekind (N, Kind);
+ Set_Is_Internal (N, True);
+
+ if Kind in Type_Kind then
+ Init_Size_Align (N);
+ end if;
+
+ return N;
+ end New_Internal_Shadow_Entity;
+
-----------------
-- Build_Chain --
-----------------
+ -- Could use more comments below ???
+
procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
! Decl : Node_Id;
! Analyzed_Unit : Boolean := Analyzed (Cunit (Unum));
! Is_Tagged : Boolean;
begin
Decl := First (Visible_Declarations (Spec));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration then
+ Is_Tagged :=
+ Nkind (Type_Definition (Decl)) = N_Record_Definition
+ and then Tagged_Present (Type_Definition (Decl));
+
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed_Unit then
! if Is_Tagged then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
*************** package body Sem_Ch10 is
*** 3398,3406 ****
-- Create shadow entity for type
! Lim_Typ := New_Internal_Entity
(Kind => Ekind (Comp_Typ),
- Scope_Id => Scope,
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
--- 3704,3711 ----
-- Create shadow entity for type
! Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
*************** package body Sem_Ch10 is
*** 3408,3424 ****
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
! if Tagged_Present (Type_Definition (Decl)) then
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
else
Decorate_Incomplete_Type (Lim_Typ, Scope);
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
-
- -- Add each entity to the proper list
-
- Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Private_Type_Declaration
--- 3713,3725 ----
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
! if Is_Tagged then
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
else
Decorate_Incomplete_Type (Lim_Typ, Scope);
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Private_Type_Declaration
*************** package body Sem_Ch10 is
*** 3426,3438 ****
then
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed (Cunit (Unum)) then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Entity
(Kind => Ekind (Comp_Typ),
- Scope_Id => Scope,
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
--- 3727,3738 ----
then
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed_Unit then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
*************** package body Sem_Ch10 is
*** 3443,3452 ****
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
-
- -- Add the entities to the proper list
-
- Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Package_Declaration then
--- 3743,3748 ----
*************** package body Sem_Ch10 is
*** 3464,3472 ****
Set_Scope (Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Entity
(Kind => Ekind (Comp_Typ),
- Scope_Id => Scope,
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
--- 3760,3767 ----
Set_Scope (Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
*************** package body Sem_Ch10 is
*** 3480,3487 ****
-- Note: The non_limited_view attribute is not used
-- for local packages.
- -- Add the entities to the proper list.
- Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
Append_Elmt (Lim_Typ, To => Limited_Views (P));
Build_Chain (Spec, Scope => Lim_Typ);
--- 3775,3780 ----
*************** package body Sem_Ch10 is
*** 3497,3510 ****
begin
pragma Assert (Limited_Present (N));
! -- Limited withed subprograms are not allowed. Therefore, we
! -- don't need to build the limited-view auxiliary chain.
! if Nkind (Parent (P)) = N_Function_Specification
! or else Nkind (Parent (P)) = N_Procedure_Specification
! then
! return;
! end if;
-- Check if the chain is already built
--- 3790,3830 ----
begin
pragma Assert (Limited_Present (N));
! -- A library_item mentioned in a limited_with_clause shall be
! -- a package_declaration, not a subprogram_declaration,
! -- generic_declaration, generic_instantiation, or
! -- package_renaming_declaration
! case Nkind (Unit (Library_Unit (N))) is
!
! when N_Package_Declaration =>
! null;
!
! when N_Subprogram_Declaration =>
! Error_Msg_N ("subprograms not allowed in "
! & "limited with_clauses", N);
!
! when N_Generic_Package_Declaration |
! N_Generic_Subprogram_Declaration =>
! Error_Msg_N ("generics not allowed in "
! & "limited with_clauses", N);
!
! when N_Package_Instantiation |
! N_Function_Instantiation |
! N_Procedure_Instantiation =>
! Error_Msg_N ("generic instantiations not allowed in "
! & "limited with_clauses", N);
!
! when N_Generic_Package_Renaming_Declaration |
! N_Generic_Procedure_Renaming_Declaration |
! N_Generic_Function_Renaming_Declaration =>
! Error_Msg_N ("generic renamings not allowed in "
! & "limited with_clauses", N);
!
! when others =>
! pragma Assert (False);
! null;
! end case;
-- Check if the chain is already built
*************** package body Sem_Ch10 is
*** 3516,3522 ****
Set_Ekind (P, E_Package);
Set_Limited_Views (P, New_Elmt_List);
- Set_Non_Limited_Views (P, New_Elmt_List);
-- Set_Entity (Name (N), P);
-- Create the auxiliary chain
--- 3836,3841 ----
*************** package body Sem_Ch10 is
*** 3650,3660 ****
Unit_Name : Entity_Id;
begin
! -- Loop through context items and undo with_clauses and use_clauses.
Item := First (Context_Items (N));
while Present (Item) loop
-- We are interested only in with clauses which got installed
--- 3969,4000 ----
Unit_Name : Entity_Id;
begin
+ -- We remove the context clauses in two phases: limited-views first
+ -- and regular-views later (to maintain the stack model).
! -- First Phase: Remove limited_with context clauses
Item := First (Context_Items (N));
+ while Present (Item) loop
+ -- We are interested only in with clauses which got installed
+ -- on entry.
+
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Limited_View_Installed (Item)
+ then
+ Remove_Limited_With_Clause (Item);
+
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- Second Phase: Loop through context items and undo regular
+ -- with_clauses and use_clauses.
+
+ Item := First (Context_Items (N));
while Present (Item) loop
-- We are interested only in with clauses which got installed
*************** package body Sem_Ch10 is
*** 3664,3670 ****
and then Limited_Present (Item)
and then Limited_View_Installed (Item)
then
! Remove_Limited_With_Clause (Item);
elsif Nkind (Item) = N_With_Clause
and then Context_Installed (Item)
--- 4004,4010 ----
and then Limited_Present (Item)
and then Limited_View_Installed (Item)
then
! null;
elsif Nkind (Item) = N_With_Clause
and then Context_Installed (Item)
*************** package body Sem_Ch10 is
*** 3687,3693 ****
Next (Item);
end loop;
-
end Remove_Context_Clauses;
--------------------------------
--- 4027,4032 ----
*************** package body Sem_Ch10 is
*** 3697,3703 ****
procedure Remove_Limited_With_Clause (N : Node_Id) is
P_Unit : Entity_Id := Unit (Library_Unit (N));
P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
-
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
--- 4036,4041 ----
*************** package body Sem_Ch10 is
*** 3709,3714 ****
--- 4047,4059 ----
P := Defining_Identifier (P);
end if;
+ if Debug_Flag_I then
+ Write_Str ("remove limited view of ");
+ Write_Name (Chars (P));
+ Write_Str (" from visibility");
+ Write_Eol;
+ end if;
+
-- Remove all shadow entities from visibility
Lim_Elmt := First_Elmt (Limited_Views (P));
*************** package body Sem_Ch10 is
*** 3720,3725 ****
--- 4065,4075 ----
Next_Elmt (Lim_Elmt);
end loop;
+ -- Indicate that the limited view of the package is not installed
+
+ Set_From_With_Type (P, False);
+ Set_Limited_View_Installed (N, False);
+
-- If the exporting package has previously been analyzed, it
-- has appeared in the closure already and should be left alone.
-- Otherwise, remove package itself from visibility.
*************** package body Sem_Ch10 is
*** 3731,3739 ****
Set_Ekind (P, E_Void);
Set_Scope (P, Empty);
Set_Is_Immediately_Visible (P, False);
- end if;
! Set_Limited_View_Installed (N, False);
end Remove_Limited_With_Clause;
--------------------
--- 4081,4120 ----
Set_Ekind (P, E_Void);
Set_Scope (P, Empty);
Set_Is_Immediately_Visible (P, False);
! else
!
! -- Reinstall visible entities (entities removed from visibility in
! -- Install_Limited_Withed to install the shadow entities).
!
! declare
! Ent : Entity_Id;
!
! begin
! Ent := First_Entity (P);
! while Present (Ent) and then Ent /= First_Private_Entity (P) loop
!
! -- Shadow entities have not been added to the list of
! -- entities associated to the package spec. Therefore we
! -- just have to re-chain all its visible entities.
!
! if not Is_Class_Wide_Type (Ent) then
!
! Set_Homonym (Ent, Current_Entity (Ent));
! Set_Current_Entity (Ent);
!
! if Debug_Flag_I then
! Write_Str (" (homonym) chain ");
! Write_Name (Chars (Ent));
! Write_Eol;
! end if;
!
! end if;
!
! Next_Entity (Ent);
! end loop;
! end;
! end if;
end Remove_Limited_With_Clause;
--------------------
*************** package body Sem_Ch10 is
*** 3819,3824 ****
--- 4200,4207 ----
end if;
end Unchain;
+ -- Start of Remove_With_Type_Clause
+
begin
if Nkind (Name) = N_Selected_Component then
Typ := Entity (Selector_Name (Name));
*************** package body Sem_Ch10 is
*** 3882,3889 ****
begin
if Debug_Flag_I then
! Write_Str ("remove withed unit ");
Write_Name (Chars (Unit_Name));
Write_Eol;
end if;
--- 4265,4273 ----
begin
if Debug_Flag_I then
! Write_Str ("remove unit ");
Write_Name (Chars (Unit_Name));
+ Write_Str (" from visibility");
Write_Eol;
end if;
*************** package body Sem_Ch10 is
*** 3923,3927 ****
--- 4307,4318 ----
Set_Homonym (Prev, Homonym (E));
end if;
end if;
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) unchain ");
+ Write_Name (Chars (E));
+ Write_Eol;
+ end if;
+
end Unchain;
end Sem_Ch10;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.24
diff -u -c -3 -p -r1.24 sem_ch12.adb
*** sem_ch12.adb 27 Oct 2003 14:27:17 -0000 1.24
--- sem_ch12.adb 29 Oct 2003 09:28:08 -0000
*************** package body Sem_Ch12 is
*** 2332,2339 ****
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
! Error_Msg_N
! ("expect name of generic package in instantiation", Gen_Id);
Restore_Env;
return;
end if;
--- 2332,2346 ----
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
!
! if From_With_Type (Gen_Unit) then
! Error_Msg_N
! ("cannot instantiate a limited withed package", Gen_Id);
! else
! Error_Msg_N
! ("expect name of generic package in instantiation", Gen_Id);
! end if;
!
Restore_Env;
return;
end if;
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 sem_ch8.adb
*** sem_ch8.adb 27 Oct 2003 14:27:17 -0000 1.10
--- sem_ch8.adb 29 Oct 2003 09:28:10 -0000
*************** package body Sem_Ch8 is
*** 789,796 ****
end if;
if Etype (Old_P) = Any_Type then
! Error_Msg_N
! ("expect package name in renaming", Name (N));
elsif Ekind (Old_P) /= E_Package
and then not (Ekind (Old_P) = E_Generic_Package
--- 789,802 ----
end if;
if Etype (Old_P) = Any_Type then
! Error_Msg_N
! ("expect package name in renaming", Name (N));
!
! elsif Ekind (Old_P) = E_Package
! and then From_With_Type (Old_P)
! then
! Error_Msg_N
! ("limited withed package cannot be renamed", Name (N));
elsif Ekind (Old_P) /= E_Package
and then not (Ekind (Old_P) = E_Generic_Package
*************** package body Sem_Ch8 is
*** 811,821 ****
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
- elsif Ekind (Old_P) = E_Package
- and then From_With_Type (Old_P)
- then
- Error_Msg_N ("imported package cannot be renamed", Name (N));
-
else
-- Entities in the old package are accessible through the
-- renaming entity. The simplest implementation is to have
--- 817,822 ----
*************** package body Sem_Ch8 is
*** 3397,3403 ****
null;
else
Error_Msg_N
! ("imported package can only be used to access imported type",
N);
end if;
end if;
--- 3398,3405 ----
null;
else
Error_Msg_N
! ("limited withed package can only be used to access "
! & " incomplete types",
N);
end if;
end if;
*************** package body Sem_Ch8 is
*** 5285,5291 ****
Set_In_Use (P);
if From_With_Type (P) then
! Error_Msg_N ("imported package cannot appear in use clause", N);
end if;
-- Find enclosing instance, if any.
--- 5287,5293 ----
Set_In_Use (P);
if From_With_Type (P) then
! Error_Msg_N ("limited withed package cannot appear in use clause", N);
end if;
-- Find enclosing instance, if any.
Index: sem_type.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_type.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 sem_type.adb
*** sem_type.adb 21 Oct 2003 13:42:22 -0000 1.8
--- sem_type.adb 29 Oct 2003 09:28:10 -0000
*************** package body Sem_Type is
*** 2134,2148 ****
if B1 = B2 then
return B1;
! elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
! or else (T1 = Universal_Real and then Is_Real_Type (T2))
! or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
then
return B2;
! elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
! or else (T2 = Universal_Real and then Is_Real_Type (T1))
! or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
then
return B1;
--- 2134,2152 ----
if B1 = B2 then
return B1;
! elsif False
! or else (T1 = Universal_Integer and then Is_Integer_Type (T2))
! or else (T1 = Universal_Real and then Is_Real_Type (T2))
! or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
! or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
then
return B2;
! elsif False
! or else (T2 = Universal_Integer and then Is_Integer_Type (T1))
! or else (T2 = Universal_Real and then Is_Real_Type (T1))
! or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
! or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
then
return B1;
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 sinfo.ads
*** sinfo.ads 21 Oct 2003 13:42:22 -0000 1.11
--- sinfo.ads 29 Oct 2003 09:28:13 -0000
*************** package Sinfo is
*** 573,579 ****
-- and N_Extension_Aggregate nodes. This field is used during generic
-- processing to relate nodes in the original template to nodes in the
-- generic copy. It overlaps the Entity field, and is used to capture
! -- global references in the analyzed copy and place them in the template.
-- See description in Sem_Ch12 for further details on this usage.
-- At_End_Proc (Node1)
--- 573,579 ----
-- and N_Extension_Aggregate nodes. This field is used during generic
-- processing to relate nodes in the original template to nodes in the
-- generic copy. It overlaps the Entity field, and is used to capture
! -- global references in the analyzed copy and place them in the instance.
-- See description in Sem_Ch12 for further details on this usage.
-- At_End_Proc (Node1)
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 sprint.adb
*** sprint.adb 21 Oct 2003 13:42:22 -0000 1.7
--- sprint.adb 29 Oct 2003 09:28:14 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2002, 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2003, 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- --
*************** package body Sprint is
*** 2490,2496 ****
else
if First_Name (Node) or else not Dump_Original_Only then
! Write_Indent_Str ("with ");
else
Write_Str (", ");
end if;
--- 2490,2501 ----
else
if First_Name (Node) or else not Dump_Original_Only then
! if Limited_Present (Node) then
! Write_Indent_Str ("limited with ");
! else
! Write_Indent_Str ("with ");
! end if;
!
else
Write_Str (", ");
end if;
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 switch-c.adb
*** switch-c.adb 21 Oct 2003 13:42:22 -0000 1.5
--- switch-c.adb 29 Oct 2003 09:28:14 -0000
*************** package body Switch.C is
*** 216,221 ****
--- 216,225 ----
Ptr := Ptr + 1;
Operating_Mode := Check_Semantics;
+ if Tree_Output then
+ ASIS_Mode := True;
+ end if;
+
-- Processing for d switch
when 'd' =>
*************** package body Switch.C is
*** 638,644 ****
when 't' =>
Ptr := Ptr + 1;
Tree_Output := True;
! ASIS_Mode := True;
Back_Annotate_Rep_Info := True;
-- Processing for T switch
--- 642,652 ----
when 't' =>
Ptr := Ptr + 1;
Tree_Output := True;
!
! if Operating_Mode = Check_Semantics then
! ASIS_Mode := True;
! end if;
!
Back_Annotate_Rep_Info := True;
-- Processing for T switch
Index: tb-alvms.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/tb-alvms.c,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 tb-alvms.c
*** tb-alvms.c 21 Oct 2003 13:42:23 -0000 1.1
--- tb-alvms.c 29 Oct 2003 09:28:14 -0000
*************** typedef struct
*** 89,94 ****
--- 89,98 ----
#define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((REG)0)
+ /* Compute Procedure Value from a live Frame Pointer value. */
+ #define PV_FOR(FP) \
+ ((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP);
+
/**********
* unwind *
**********/
*************** unwind (frame_state_t * fs)
*** 127,136 ****
if (fs->fp == 0)
return;
! if ((REG_AT (fs->fp) & 0x7) == 0)
! pv = *(PDSCDEF **)fs->fp;
! else
! pv = (PDSCDEF *) fs->fp;
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
--- 131,137 ----
if (fs->fp == 0)
return;
! pv = PV_FOR (fs->fp);
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
*************** unwind (frame_state_t * fs)
*** 190,207 ****
}
/* Structure representing a traceback entry in the tracebacks array to be
! filled by __gnat_backtrace below. This should match the declaration of
! Traceback_Entry in System.Traceback_Entries.
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
-
typedef struct {
! void * pc; /* Address of the call instruction in the chain. */
! void * sp; /* Stack Pointer value at the point of this call. */
! void * fp; /* Frame Pointer value at the point of this call. */
} tb_entry_t;
/********************
--- 191,205 ----
}
/* Structure representing a traceback entry in the tracebacks array to be
! filled by __gnat_backtrace below.
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
typedef struct {
! void * pc;
! void * pv;
} tb_entry_t;
/********************
*************** __gnat_backtrace (array, size, exclude_m
*** 249,256 ****
|| frame_state.pc > exclude_max)
{
tbe->pc = frame_state.pc;
! tbe->sp = frame_state.sp;
! tbe->fp = frame_state.fp;
cnt ++;
tbe ++;
--- 247,253 ----
|| frame_state.pc > exclude_max)
{
tbe->pc = frame_state.pc;
! tbe->pv = PV_FOR (frame_state.fp);
cnt ++;
tbe ++;
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.36
diff -u -c -3 -p -r1.36 trans.c
*** trans.c 23 Oct 2003 11:57:52 -0000 1.36
--- trans.c 29 Oct 2003 09:28:17 -0000
*************** gnat_to_code (gnat_node)
*** 243,251 ****
gnu_root = tree_transform (gnat_node);
/* This should just generate code, not return a value. If it returns
a value, something is wrong. */
! if (gnu_root != error_mark_node)
gigi_abort (302);
}
--- 243,255 ----
gnu_root = tree_transform (gnat_node);
+ /* If we return a statement, generate code for it. */
+ if (IS_STMT (gnu_root))
+ expand_expr_stmt (gnu_root);
+
/* This should just generate code, not return a value. If it returns
a value, something is wrong. */
! else if (gnu_root != error_mark_node)
gigi_abort (302);
}
*************** tree_transform (gnat_node)
*** 997,1003 ****
gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
gnu_result
! = build_component_ref (gnu_prefix, NULL_TREE, gnu_field);
}
if (gnu_result == 0)
--- 1001,1009 ----
gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
gnu_result
! = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
! (Nkind (Parent (gnat_node))
! == N_Attribute_Reference));
}
if (gnu_result == 0)
*************** tree_transform (gnat_node)
*** 2058,2065 ****
gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
- set_lineno (gnat_node, 1);
-
/* If range check is needed, emit code to generate it */
if (Do_Range_Check (Expression (gnat_node)))
gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
--- 2064,2069 ----
*************** tree_transform (gnat_node)
*** 2071,2080 ****
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
|| (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
! expand_expr_stmt (build_call_raise (SE_Object_Too_Large));
else
! expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
! gnu_lhs, gnu_rhs));
break;
case N_If_Statement:
--- 2075,2086 ----
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
|| (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
! gnu_result = build_call_raise (SE_Object_Too_Large);
else
! gnu_result
! = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
!
! gnu_result = build_nt (EXPR_STMT, gnu_result);
break;
case N_If_Statement:
*************** tree_transform (gnat_node)
*** 3168,3174 ****
= length == 1 ? gnu_subprog_call
: build_component_ref
(gnu_subprog_call, NULL_TREE,
! TREE_PURPOSE (scalar_return_list));
int unchecked_conversion
= Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
/* If the actual is a conversion, get the inner expression,
--- 3174,3180 ----
= length == 1 ? gnu_subprog_call
: build_component_ref
(gnu_subprog_call, NULL_TREE,
! TREE_PURPOSE (scalar_return_list), 0);
int unchecked_conversion
= Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
/* If the actual is a conversion, get the inner expression,
*************** tree_transform (gnat_node)
*** 3614,3620 ****
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("not_handled_by_others"), NULL_TREE)),
integer_zero_node);
}
--- 3620,3627 ----
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("not_handled_by_others"), NULL_TREE,
! 0)),
integer_zero_node);
}
*************** tree_transform (gnat_node)
*** 3643,3649 ****
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("import_code"), NULL_TREE),
gnu_expr);
else
this_choice
--- 3650,3656 ----
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("import_code"), NULL_TREE, 0),
gnu_expr);
else
this_choice
*************** tree_transform (gnat_node)
*** 3664,3670 ****
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("lang"), NULL_TREE);
this_choice
= build_binary_op
--- 3671,3677 ----
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("lang"), NULL_TREE, 0);
this_choice
= build_binary_op
*************** tree_transform (gnat_node)
*** 4024,4031 ****
gigi_abort (321);
}
/* If the result is a constant that overflows, raise constraint error. */
! if (TREE_CODE (gnu_result) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_result))
{
post_error ("Constraint_Error will be raised at run-time?", gnat_node);
--- 4031,4047 ----
gigi_abort (321);
}
+ /* If the result is a statement, set needed flags and return it. */
+ if (IS_STMT (gnu_result))
+ {
+ TREE_TYPE (gnu_result) = void_type_node;
+ TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
+ TREE_SLOC (gnu_result) = Sloc (gnat_node);
+ return gnu_result;
+ }
+
/* If the result is a constant that overflows, raise constraint error. */
! else if (TREE_CODE (gnu_result) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_result))
{
post_error ("Constraint_Error will be raised at run-time?", gnat_node);
*************** tree_transform (gnat_node)
*** 4137,4142 ****
--- 4153,4177 ----
return gnu_result;
}
\f
+ /* GNU_STMT is a statement. We generate code for that statement. */
+
+ void
+ gnat_expand_stmt (gnu_stmt)
+ tree gnu_stmt;
+ {
+ set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
+
+ switch (TREE_CODE (gnu_stmt))
+ {
+ case EXPR_STMT:
+ expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
+ break;
+
+ default:
+ abort ();
+ }
+ }
+ \f
/* Force references to each of the entities in packages GNAT_NODE with's
so that the debugging information for all of them are identical
in all clients. Operate recursively on anything it with's, but check
*************** set_lineno (gnat_node, write_note_p)
*** 5407,5412 ****
--- 5442,5457 ----
{
Source_Ptr source_location = Sloc (gnat_node);
+ set_lineno_from_sloc (source_location, write_note_p);
+ }
+
+ /* Likewise, but passed a Sloc. */
+
+ void
+ set_lineno_from_sloc (source_location, write_note_p)
+ Source_Ptr source_location;
+ int write_note_p;
+ {
/* If node not from source code, ignore. */
if (source_location < 0)
return;
Index: utils2.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils2.c,v
retrieving revision 1.17
diff -u -c -3 -p -r1.17 utils2.c
*** utils2.c 21 Oct 2003 13:42:23 -0000 1.17
--- utils2.c 29 Oct 2003 09:28:18 -0000
*************** static tree contains_null_expr PARAMS (
*** 50,56 ****
static tree compare_arrays PARAMS ((tree, tree, tree));
static tree nonbinary_modular_operation PARAMS ((enum tree_code, tree,
tree, tree));
! static tree build_simple_component_ref PARAMS ((tree, tree, tree));
\f
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
--- 50,56 ----
static tree compare_arrays PARAMS ((tree, tree, tree));
static tree nonbinary_modular_operation PARAMS ((enum tree_code, tree,
tree, tree));
! static tree build_simple_component_ref PARAMS ((tree, tree, tree, int));
\f
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
*************** build_binary_op (op_code, result_type, l
*** 955,961 ****
&& integer_zerop (TREE_VALUE (CONSTRUCTOR_ELTS (right_operand))))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
! TYPE_FIELDS (left_base_type));
left_operand = convert (TREE_TYPE (right_operand),
integer_zero_node);
}
--- 955,962 ----
&& integer_zerop (TREE_VALUE (CONSTRUCTOR_ELTS (right_operand))))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
! TYPE_FIELDS (left_base_type),
! 0);
left_operand = convert (TREE_TYPE (right_operand),
integer_zero_node);
}
*************** gnat_build_constructor (type, list)
*** 1609,1624 ****
\f
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
! for the field.
We also handle the fact that we might have been passed a pointer to the
actual record and know how to look for fields in variant parts. */
static tree
! build_simple_component_ref (record_variable, component, field)
tree record_variable;
tree component;
tree field;
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref;
--- 1610,1626 ----
\f
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
! for the field. Don't fold the result if NO_FOLD_P is nonzero.
We also handle the fact that we might have been passed a pointer to the
actual record and know how to look for fields in variant parts. */
static tree
! build_simple_component_ref (record_variable, component, field, no_fold_p)
tree record_variable;
tree component;
tree field;
+ int no_fold_p;
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref;
*************** build_simple_component_ref (record_varia
*** 1674,1681 ****
{
tree field_ref
= build_simple_component_ref (record_variable,
! NULL_TREE, new_field);
! ref = build_simple_component_ref (field_ref, NULL_TREE, field);
if (ref != 0)
return ref;
--- 1676,1684 ----
{
tree field_ref
= build_simple_component_ref (record_variable,
! NULL_TREE, new_field, no_fold_p);
! ref = build_simple_component_ref (field_ref, NULL_TREE, field,
! no_fold_p);
if (ref != 0)
return ref;
*************** build_simple_component_ref (record_varia
*** 1697,1715 ****
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
! return fold (ref);
}
\f
/* Like build_simple_component_ref, except that we give an error if the
reference could not be found. */
tree
! build_component_ref (record_variable, component, field)
tree record_variable;
tree component;
tree field;
{
! tree ref = build_simple_component_ref (record_variable, component, field);
if (ref != 0)
return ref;
--- 1700,1720 ----
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
! return no_fold_p ? ref : fold (ref);
}
\f
/* Like build_simple_component_ref, except that we give an error if the
reference could not be found. */
tree
! build_component_ref (record_variable, component, field, no_fold_p)
tree record_variable;
tree component;
tree field;
+ int no_fold_p;
{
! tree ref = build_simple_component_ref (record_variable, component, field,
! no_fold_p);
if (ref != 0)
return ref;
*************** build_allocator (type, init, result_type
*** 1945,1951 ****
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
! NULL_TREE, TYPE_FIELDS (storage_type)),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
--- 1950,1956 ----
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
! NULL_TREE, TYPE_FIELDS (storage_type), 0),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
*************** build_allocator (type, init, result_type
*** 1990,1996 ****
result = convert (build_pointer_type (new_type), result);
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
result = build_component_ref (result, NULL_TREE,
! TYPE_FIELDS (new_type));
result = convert (result_type,
build_unary_op (ADDR_EXPR, NULL_TREE, result));
}
--- 1995,2001 ----
result = convert (build_pointer_type (new_type), result);
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
result = build_component_ref (result, NULL_TREE,
! TYPE_FIELDS (new_type), 0);
result = convert (result_type,
build_unary_op (ADDR_EXPR, NULL_TREE, result));
}
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.34
diff -u -c -3 -p -r1.34 utils.c
*** utils.c 21 Oct 2003 13:42:23 -0000 1.34
--- utils.c 29 Oct 2003 09:28:19 -0000
*************** convert_to_fat_pointer (type, expr)
*** 2825,2834 ****
else
expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
! template = build_component_ref (expr, NULL_TREE, fields);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
! TREE_CHAIN (fields)));
}
else
/* Otherwise, build the constructor for the template. */
--- 2825,2834 ----
else
expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
! template = build_component_ref (expr, NULL_TREE, fields, 0);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
! TREE_CHAIN (fields), 0));
}
else
/* Otherwise, build the constructor for the template. */
*************** convert_to_thin_pointer (type, expr)
*** 2872,2878 ****
/* We get the pointer to the data and use a NOP_EXPR to make it the
proper GCC type. */
! expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)));
expr = build1 (NOP_EXPR, type, expr);
return expr;
--- 2872,2879 ----
/* We get the pointer to the data and use a NOP_EXPR to make it the
proper GCC type. */
! expr
! = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), 0);
expr = build1 (NOP_EXPR, type, expr);
return expr;
*************** convert (type, expr)
*** 2927,2933 ****
return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
else
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype)));
}
else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
--- 2928,2934 ----
return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
else
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype), 0));
}
else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
*************** convert (type, expr)
*** 2977,2983 ****
if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype)));
/* If converting to a type that contains a template, convert to the data
type and then build the template. */
--- 2978,2984 ----
if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype), 0));
/* If converting to a type that contains a template, convert to the data
type and then build the template. */
*************** convert (type, expr)
*** 3051,3057 ****
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (expr, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
--- 3052,3058 ----
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (expr, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE, 0));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
*************** convert (type, expr)
*** 3146,3152 ****
array and then convert it. */
else if (TYPE_FAT_POINTER_P (etype))
expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
! NULL_TREE);
return fold (convert_to_pointer (type, expr));
--- 3147,3153 ----
array and then convert it. */
else if (TYPE_FAT_POINTER_P (etype))
expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
! NULL_TREE, 0);
return fold (convert_to_pointer (type, expr));
*************** maybe_unconstrained_array (exp)
*** 3278,3284 ****
= build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (exp, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE));
TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
return new;
}
--- 3279,3285 ----
= build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (exp, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE, 0));
TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
return new;
}
*************** maybe_unconstrained_array (exp)
*** 3306,3317 ****
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
return
build_component_ref (new, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))));
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
break;
default:
--- 3307,3319 ----
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
return
build_component_ref (new, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
! 0);
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
break;
default:
*************** unchecked_convert (type, expr, notrunc_p
*** 3399,3405 ****
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
! expr = build_component_ref (expr, NULL_TREE, field);
}
/* Similarly for integral input type whose precision is not equal to its
--- 3401,3407 ----
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
! expr = build_component_ref (expr, NULL_TREE, field, 0);
}
/* Similarly for integral input type whose precision is not equal to its
Index: einfo.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.h,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 einfo.h
*** einfo.h 21 Oct 2003 13:41:58 -0000 1.9
--- einfo.h 29 Oct 2003 09:42:26 -0000
***************
*** 483,489 ****
INLINE B No_Return (E Id);
INLINE B Non_Binary_Modulus (E Id);
INLINE E Non_Limited_View (E Id);
- INLINE L Non_Limited_Views (E Id);
INLINE B Nonzero_Is_True (E Id);
INLINE U Normalized_First_Bit (E Id);
INLINE U Normalized_Position (E Id);
--- 483,488 ----
***************
*** 1516,1524 ****
INLINE E Non_Limited_View (E Id)
{ return Node17 (Id); }
-
- INLINE L Non_Limited_Views (E Id)
- { return Elist8 (Id); }
INLINE B Nonzero_Is_True (E Id)
{ return Flag162 (Base_Type (Id)); }
--- 1515,1520 ----
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: ada updates
@ 2003-10-27 14:56 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-10-27 14:56 UTC (permalink / raw)
To: gcc-patches
I've enabled make check-ada from ada/Make-lang.in, as suggested on
this list.
Plus various fixes and improvements.
--
2003-10-27 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic: Add missing substitution on object_deps handling.
PR ada/5909:
* Make-lang.in (check-ada): Enable ACATS test suite.
2003-10-27 Robert Dewar <dewar@gnat.com>
* exp_ch3.adb:
(Freeze_Array_Type): We do not need an initialization routine for types
derived from String or Wide_String. They should be treated the same
as String and Wide_String themselves. This caused problems with the
use of Initialize_Scalars.
* exp_ch5.adb:
(Expand_Assign_Record): Do component-wise assignment of non-byte aligned
composites. This allows use of component clauses that are not byte
aligned.
* sem_prag.adb:
(Analyze_Pragma, case Pack): Generate warning and ignore pack if there
is an attempt to pack an array of atomic objects.
* make.adb, prj-env.adb, prj-env.ads: Minor reformatting
2003-10-27 Pascal Obry <obry@gnat.com>
* g-dirope.adb:
(Basename): Check for drive letters in a pathname only on DOS based OS.
2003-10-27 Vincent Celier <celier@gnat.com>
* make.adb:
(Gnatmake): When unable to change dir to the object dir, display the
content of the parent dir of the obj dir, to try to understand why this
happens.
2003-10-27 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2003-10-27 Ed Schonberg <schonberg@gnat.com>
* sem_ch12.adb:
(Inline_Instance_Body): Indicate that the save/restore of use_clauses
should not be done in Save/Restore_Scope_Stack, because it is performed
locally.
* sem_ch8.adb:
(Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate
whether use clauses should be removed/restored.
* sem_ch8.ads:
(Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate
whether use clauses should be removed/restored.
--
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 exp_ch3.adb
*** exp_ch3.adb 22 Oct 2003 09:28:08 -0000 1.9
--- exp_ch3.adb 27 Oct 2003 13:42:58 -0000
*************** package body Exp_Ch3 is
*** 3428,3435 ****
-- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures.
! elsif Base = Standard_String
! or else Base = Standard_Wide_String
then
null;
--- 3428,3435 ----
-- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures.
! elsif Root_Type (Base) = Standard_String
! or else Root_Type (Base) = Standard_Wide_String
then
null;
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 exp_ch5.adb
*** exp_ch5.adb 21 Oct 2003 13:41:59 -0000 1.9
--- exp_ch5.adb 27 Oct 2003 13:42:58 -0000
*************** package body Exp_Ch5 is
*** 91,98 ****
procedure Expand_Assign_Record (N : Node_Id);
-- N is an assignment of a non-tagged record value. This routine handles
! -- the special cases and checks required for such assignments, including
! -- change of representation.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
--- 91,115 ----
procedure Expand_Assign_Record (N : Node_Id);
-- N is an assignment of a non-tagged record value. This routine handles
! -- the case where the assignment must be made component by component,
! -- either because the target is not byte aligned, or there is a change
! -- of representation.
!
! function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
! -- This function is used in processing the assignment of a record or
! -- indexed component. The back end can handle such assignments fine
! -- if the object involved is small (64-bits) or if it is aligned on
! -- a byte boundary (starts on a byte, and ends on a byte). However,
! -- problems arise for large components that are not byte aligned,
! -- since the assignment may clobber other components that share
! -- bit positions in the starting or ending bytes. This function is
! -- used to detect such situations, so that the assignment can be
! -- handled component-wise. A value of False means that either the
! -- object is known to be greater than 64 bits, or that it is known
! -- to be byte aligned. True is returned if the object is known to
! -- be greater than 64 bits, and is known to be unaligned. As implied
! -- by the name, the result is conservative, in that if the compiler
! -- cannot determine these conditions at compile time, True is returned.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
*************** package body Exp_Ch5 is
*** 982,1000 ****
-- by field assignments.
procedure Expand_Assign_Record (N : Node_Id) is
begin
! if not Change_Of_Representation (N) then
return;
end if;
! -- At this stage we know that the right hand side is a conversion
declare
Loc : constant Source_Ptr := Sloc (N);
! Lhs : constant Node_Id := Name (N);
! Rhs : constant Node_Id := Expression (Expression (N));
! R_Rec : constant Node_Id := Expression (Expression (N));
! R_Typ : constant Entity_Id := Base_Type (Etype (R_Rec));
L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
Decl : constant Node_Id := Declaration_Node (R_Typ);
RDef : Node_Id;
--- 999,1036 ----
-- by field assignments.
procedure Expand_Assign_Record (N : Node_Id) is
+ Lhs : constant Node_Id := Name (N);
+ Rhs : Node_Id := Expression (N);
+
begin
! -- If change of representation, then extract the real right hand
! -- side from the type conversion, and proceed with component-wise
! -- assignment, since the two types are not the same as far as the
! -- back end is concerned.
!
! if Change_Of_Representation (N) then
! Rhs := Expression (Rhs);
!
! -- If this may be a case of a large bit aligned component, then
! -- proceed with component-wise assignment, to avoid possible
! -- clobbering of other components sharing bits in the first or
! -- last byte of the component to be assigned.
!
! elsif Maybe_Bit_Aligned_Large_Component (Lhs) then
! null;
!
! -- If neither condition met, then nothing special to do, the back end
! -- can handle assignment of the entire component as a single entity.
!
! else
return;
end if;
! -- At this stage we know that we must do a component wise assignment
declare
Loc : constant Source_Ptr := Sloc (N);
! R_Typ : constant Entity_Id := Base_Type (Etype (Rhs));
L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
Decl : constant Node_Id := Declaration_Node (R_Typ);
RDef : Node_Id;
*************** package body Exp_Ch5 is
*** 1002,1009 ****
function Find_Component
(Typ : Entity_Id;
! Comp : Entity_Id)
! return Entity_Id;
-- Find the component with the given name in the underlying record
-- declaration for Typ. We need to use the actual entity because
-- the type may be private and resolution by identifier alone would
--- 1038,1044 ----
function Find_Component
(Typ : Entity_Id;
! Comp : Entity_Id) return Entity_Id;
-- Find the component with the given name in the underlying record
-- declaration for Typ. We need to use the actual entity because
-- the type may be private and resolution by identifier alone would
*************** package body Exp_Ch5 is
*** 1027,1035 ****
function Find_Component
(Typ : Entity_Id;
! Comp : Entity_Id)
! return Entity_Id
!
is
Utyp : constant Entity_Id := Underlying_Type (Typ);
C : Entity_Id;
--- 1062,1068 ----
function Find_Component
(Typ : Entity_Id;
! Comp : Entity_Id) return Entity_Id
is
Utyp : constant Entity_Id := Underlying_Type (Typ);
C : Entity_Id;
*************** package body Exp_Ch5 is
*** 3174,3178 ****
--- 3207,3298 ----
when RE_Not_Available =>
return Empty_List;
end Make_Tag_Ctrl_Assignment;
+
+ ---------------------------------------
+ -- Maybe_Bit_Aligned_Large_Component --
+ ---------------------------------------
+
+ function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean is
+ begin
+ case Nkind (N) is
+
+ -- Case of indexed component
+
+ when N_Indexed_Component =>
+ declare
+ P : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (P);
+
+ begin
+ -- If we know the component size and it is less than 64, then
+ -- we are definitely OK. The back end always does assignment
+ -- of misaligned small objects correctly.
+
+ if Known_Static_Component_Size (Ptyp)
+ and then Component_Size (Ptyp) <= 64
+ then
+ return False;
+
+ -- Otherwise, we need to test the prefix, to see if we are
+ -- indexing from a possibly unaligned component.
+
+ else
+ return Maybe_Bit_Aligned_Large_Component (P);
+ end if;
+ end;
+
+ -- Case of selected component
+
+ when N_Selected_Component =>
+ declare
+ P : constant Node_Id := Prefix (N);
+ Comp : constant Entity_Id := Entity (Selector_Name (N));
+
+ begin
+ -- If there is no component clause, then we are in the clear
+ -- since the back end will never misalign a large component
+ -- unless it is forced to do so. In the clear means we need
+ -- only the recursive test on the prefix.
+
+ if No (Component_Clause (Comp)) then
+ return Maybe_Bit_Aligned_Large_Component (P);
+
+ -- Otherwise we have a component clause, which means that
+ -- the Esize and Normalized_First_Bit fields are set and
+ -- contain static values known at compile time.
+
+ else
+ -- If we know the size is 64 bits or less we are fine
+ -- since the back end always handles small fields right.
+
+ if Esize (Comp) <= 64 then
+ return False;
+
+ -- Otherwise if the component is not byte aligned, we
+ -- know we have the nasty unaligned case.
+
+ elsif Normalized_First_Bit (Comp) /= Uint_0
+ or else Esize (Comp) mod System_Storage_Unit /= Uint_0
+ then
+ return True;
+
+ -- If we are large and byte aligned, then OK at this level
+ -- but we still need to test our prefix recursively.
+
+ else
+ return Maybe_Bit_Aligned_Large_Component (P);
+ end if;
+ end if;
+ end;
+
+ -- If we have neither a record nor array component, it means that
+ -- we have fallen off the top testing prefixes recursively, and
+ -- we now have a stand alone object, where we don't have a problem
+
+ when others =>
+ return False;
+
+ end case;
+ end Maybe_Bit_Aligned_Large_Component;
end Exp_Ch5;
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 sem_prag.adb
*** sem_prag.adb 21 Oct 2003 13:42:20 -0000 1.10
--- sem_prag.adb 27 Oct 2003 13:42:59 -0000
*************** package body Sem_Prag is
*** 7477,7483 ****
Error_Pragma
("pragma% ignored, cannot pack aliased components?");
! elsif Has_Atomic_Components (Typ) then
Error_Pragma
("?pragma% ignored, cannot pack atomic components");
--- 7477,7485 ----
Error_Pragma
("pragma% ignored, cannot pack aliased components?");
! elsif Has_Atomic_Components (Typ)
! or else Is_Atomic (Component_Type (Typ))
! then
Error_Pragma
("?pragma% ignored, cannot pack atomic components");
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.18
diff -u -c -3 -p -r1.18 make.adb
*** make.adb 24 Oct 2003 13:02:41 -0000 1.18
--- make.adb 27 Oct 2003 13:42:59 -0000
*************** package body Make is
*** 3386,3392 ****
loop
declare
! Main : constant String := Mains.Next_Main;
-- The name specified on the command line may include
-- directory information.
--- 3386,3392 ----
loop
declare
! Main : constant String := Mains.Next_Main;
-- The name specified on the command line may include
-- directory information.
*************** package body Make is
*** 3416,3422 ****
if Main /= File_Name then
declare
Data : constant Project_Data :=
! Projects.Table (Main_Project);
Project_Path : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
--- 3416,3422 ----
if Main /= File_Name then
declare
Data : constant Project_Data :=
! Projects.Table (Main_Project);
Project_Path : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
*************** package body Make is
*** 3478,3489 ****
--- 3478,3491 ----
end if;
if not Unique_Compile then
+
-- Record the project, if it is the first main
if Real_Main_Project = No_Project then
Real_Main_Project := Proj;
elsif Proj /= Real_Main_Project then
+
-- Fail, as the current main is not a source
-- of the same project as the first main.
*************** package body Make is
*** 3557,3567 ****
declare
Data : Project_Data := Projects.Table (Main_Project);
Languages : Variable_Value :=
! Prj.Util.Value_Of
! (Name_Languages, Data.Decl.Attributes);
Current : String_List_Id;
Element : String_Element;
Foreign_Language : Boolean := False;
At_Least_One_Main : Boolean := False;
--- 3559,3572 ----
declare
Data : Project_Data := Projects.Table (Main_Project);
+
Languages : Variable_Value :=
! Prj.Util.Value_Of
! (Name_Languages, Data.Decl.Attributes);
!
Current : String_List_Id;
Element : String_Element;
+
Foreign_Language : Boolean := False;
At_Least_One_Main : Boolean := False;
*************** package body Make is
*** 3593,3600 ****
while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value);
! -- To know if a main is an Ada main, get its project;
! -- it should be the project specified on the command
-- line.
if (not Foreign_Language) or else
--- 3598,3605 ----
while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value);
! -- To know if a main is an Ada main, get its project.
! -- It should be the project specified on the command
-- line.
if (not Foreign_Language) or else
*************** package body Make is
*** 3616,3621 ****
--- 3621,3627 ----
-- we put all sources of the main project in the Q.
if not At_Least_One_Main then
+
-- First make sure that the binder and the linker
-- will not be invoked.
*************** package body Make is
*** 3739,3744 ****
--- 3745,3789 ----
exception
when Directory_Error =>
+
+ -- This should never happen. But, if it does, display the
+ -- content of the parent directory of the obj dir.
+
+ declare
+ Parent : constant Dir_Name_Str :=
+ Dir_Name
+ (Get_Name_String
+ (Projects.Table (Main_Project).Object_Directory));
+ Dir : Dir_Type;
+ Str : String (1 .. 200);
+ Last : Natural;
+
+ begin
+ Write_Str ("Contents of directory """);
+ Write_Str (Parent);
+ Write_Line (""":");
+
+ Open (Dir, Parent);
+
+ loop
+ Read (Dir, Str, Last);
+ exit when Last = 0;
+ Write_Str (" ");
+ Write_Line (Str (1 .. Last));
+ end loop;
+
+ Close (Dir);
+
+ exception
+ when X : others =>
+ Write_Line ("(unexpected exception)");
+ Write_Line (Exception_Information (X));
+
+ if Is_Open (Dir) then
+ Close (Dir);
+ end if;
+ end;
+
Make_Failed ("unable to change working directory to """,
Get_Name_String
(Projects.Table (Main_Project).Object_Directory),
Index: prj-env.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-env.adb,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 prj-env.adb
*** prj-env.adb 24 Oct 2003 13:02:42 -0000 1.11
--- prj-env.adb 27 Oct 2003 13:42:59 -0000
*************** package body Prj.Env is
*** 203,212 ****
return Projects.Table (Project).Ada_Include_Path;
end Ada_Include_Path;
function Ada_Include_Path
(Project : Project_Id;
! Recursive : Boolean)
! return String
is
begin
if Recursive then
--- 203,215 ----
return Projects.Table (Project).Ada_Include_Path;
end Ada_Include_Path;
+ ----------------------
+ -- Ada_Include_Path --
+ ----------------------
+
function Ada_Include_Path
(Project : Project_Id;
! Recursive : Boolean) return String
is
begin
if Recursive then
*************** package body Prj.Env is
*** 224,231 ****
function Ada_Objects_Path
(Project : Project_Id;
! Including_Libraries : Boolean := True)
! return String_Access
is
procedure Add (Project : Project_Id);
-- Add all the object directories of a project to the path only if
--- 227,233 ----
function Ada_Objects_Path
(Project : Project_Id;
! Including_Libraries : Boolean := True) return String_Access
is
procedure Add (Project : Project_Id);
-- Add all the object directories of a project to the path only if
*************** package body Prj.Env is
*** 1061,1068 ****
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False)
! return String
is
The_Project : Project_Id := Project;
Data : Project_Data := Projects.Table (Project);
--- 1063,1069 ----
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False) return String
is
The_Project : Project_Id := Project;
Data : Project_Data := Projects.Table (Project);
*************** package body Prj.Env is
*** 1547,1554 ****
function Path_Name_Of_Library_Unit_Body
(Name : String;
! Project : Project_Id)
! return String
is
Data : constant Project_Data := Projects.Table (Project);
Original_Name : String := Name;
--- 1548,1554 ----
function Path_Name_Of_Library_Unit_Body
(Name : String;
! Project : Project_Id) return String
is
Data : constant Project_Data := Projects.Table (Project);
Original_Name : String := Name;
*************** package body Prj.Env is
*** 1733,1740 ****
function Project_Of
(Name : String;
! Main_Project : Project_Id)
! return Project_Id
is
Result : Project_Id := No_Project;
--- 1733,1739 ----
function Project_Of
(Name : String;
! Main_Project : Project_Id) return Project_Id
is
Result : Project_Id := No_Project;
*************** package body Prj.Env is
*** 1777,1786 ****
--- 1776,1788 ----
Unit := Units.Table (Current);
-- Check for body
+
Current_Name := Unit.File_Names (Body_Part).Name;
+
-- Case of a body present
if Current_Name /= No_Name then
+
-- If it has the name of the original name or the body name,
-- we have found the project.
*************** package body Prj.Env is
*** 1798,1803 ****
--- 1800,1806 ----
Current_Name := Unit.File_Names (Specification).Name;
if Current_Name /= No_Name then
+
-- If name same as the original name, or the spec name, we have
-- found the project.
Index: prj-env.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-env.ads,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 prj-env.ads
*** prj-env.ads 24 Oct 2003 13:02:42 -0000 1.9
--- prj-env.ads 27 Oct 2003 13:42:59 -0000
*************** package Prj.Env is
*** 66,73 ****
function Ada_Include_Path
(Project : Project_Id;
! Recursive : Boolean)
! return String;
-- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True,
-- get all the source directories of the imported and modified project
-- files (recursively). If Recursive is False, just get the path for the
--- 66,72 ----
function Ada_Include_Path
(Project : Project_Id;
! Recursive : Boolean) return String;
-- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True,
-- get all the source directories of the imported and modified project
-- files (recursively). If Recursive is False, just get the path for the
*************** package Prj.Env is
*** 76,83 ****
function Ada_Objects_Path
(Project : Project_Id;
! Including_Libraries : Boolean := True)
! return String_Access;
-- Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute
-- it and cache it. When Including_Libraries is False, do not include the
-- object directories of the library projects, and do not cache the result.
--- 75,81 ----
function Ada_Objects_Path
(Project : Project_Id;
! Including_Libraries : Boolean := True) return String_Access;
-- Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute
-- it and cache it. When Including_Libraries is False, do not include the
-- object directories of the library projects, and do not cache the result.
*************** package Prj.Env is
*** 86,92 ****
(Project : Project_Id;
Including_Libraries : Boolean);
-- Set the env vars for additional project path files, after
! -- creating if necessary the path files.
procedure Delete_All_Path_Files;
-- Delete all temporary path files that have been created by
--- 84,90 ----
(Project : Project_Id;
Including_Libraries : Boolean);
-- Set the env vars for additional project path files, after
! -- creating the path files if necessary.
procedure Delete_All_Path_Files;
-- Delete all temporary path files that have been created by
*************** package Prj.Env is
*** 94,115 ****
function Path_Name_Of_Library_Unit_Body
(Name : String;
! Project : Project_Id)
! return String;
! -- Returns the Path of a library unit.
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False)
! return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
-- name of the spec is returned.
-- If Full_Path is False (the default), the simple file name is returned.
-- If Full_Path is True, the absolute path name is returned.
-- If neither a body nor a spec can be found, an empty string is returned.
-- If Main_Project_Only is True, the unit must be an immediate source of
-- Project. If it is False, it may be a source of one of its imported
--- 92,114 ----
function Path_Name_Of_Library_Unit_Body
(Name : String;
! Project : Project_Id) return String;
! -- Returns the Path of a library unit
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False) return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
-- name of the spec is returned.
+ --
-- If Full_Path is False (the default), the simple file name is returned.
+ --
-- If Full_Path is True, the absolute path name is returned.
+ --
-- If neither a body nor a spec can be found, an empty string is returned.
-- If Main_Project_Only is True, the unit must be an immediate source of
-- Project. If it is False, it may be a source of one of its imported
*************** package Prj.Env is
*** 117,124 ****
function Project_Of
(Name : String;
! Main_Project : Project_Id)
! return Project_Id;
-- Get the project of a source. The source file name may be truncated
-- (".adb" or ".ads" may be missing). If the source is in a project being
-- extended, return the ultimate extending project. If it is not a source
--- 116,122 ----
function Project_Of
(Name : String;
! Main_Project : Project_Id) return Project_Id;
-- Get the project of a source. The source file name may be truncated
-- (".adb" or ".ads" may be missing). If the source is in a project being
-- extended, return the ultimate extending project. If it is not a source
Index: g-dirope.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-dirope.adb,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 g-dirope.adb
*** g-dirope.adb 21 Oct 2003 13:42:00 -0000 1.11
--- g-dirope.adb 27 Oct 2003 13:42:59 -0000
*************** package body GNAT.Directory_Operations i
*** 123,133 ****
Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
-- Here we use Base_Name.Path to keep the original casing
begin
if BN = "." or else BN = ".." then
return "";
! elsif BN'Length > 2
and then Characters.Handling.Is_Letter (BN (BN'First))
and then BN (BN'First + 1) = ':'
then
--- 123,139 ----
Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
-- Here we use Base_Name.Path to keep the original casing
+ Has_Drive_Letter : constant Boolean :=
+ OS_Lib.Path_Separator /= ':';
+ -- If Path separator is not ':' then we are on a DOS based OS
+ -- where this character is used as a drive letter separator.
+
begin
if BN = "." or else BN = ".." then
return "";
! elsif Has_Drive_Letter
! and then BN'Length > 2
and then Characters.Handling.Is_Letter (BN (BN'First))
and then BN (BN'First + 1) = ':'
then
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.2
diff -u -c -3 -p -r1.2 Makefile.generic
*** Makefile.generic 24 Oct 2003 13:02:42 -0000 1.2
--- Makefile.generic 27 Oct 2003 13:42:59 -0000
*************** $(compile_deps): force
*** 157,163 ****
@$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile
$(object_deps): force
! @$(MAKE) -C $(dir $(@:object_%=%)) -f Makefile.$(notdir $@) internal-archive-objects ARCHIVE=$(ARCHIVE)
$(ada_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada
--- 157,163 ----
@$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile
$(object_deps): force
! @$(MAKE) -C $(dir $(subst |,:,$(@:object_%=%))) -f Makefile.$(notdir $@) internal-archive-objects ARCHIVE=$(ARCHIVE)
$(ada_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.23
diff -u -c -3 -p -r1.23 sem_ch12.adb
*** sem_ch12.adb 24 Oct 2003 13:02:42 -0000 1.23
--- sem_ch12.adb 27 Oct 2003 13:42:59 -0000
*************** package body Sem_Ch12 is
*** 2887,2893 ****
-- Remove entities in current scopes from visibility, so
-- than instance body is compiled in a clean environment.
! Save_Scope_Stack;
if Is_Child_Unit (S) then
--- 2887,2893 ----
-- Remove entities in current scopes from visibility, so
-- than instance body is compiled in a clean environment.
! Save_Scope_Stack (Handle_Use => False);
if Is_Child_Unit (S) then
*************** package body Sem_Ch12 is
*** 2951,2957 ****
end loop;
end if;
! Restore_Scope_Stack;
end if;
-- Restore use clauses. For a child unit, use clauses in the
--- 2951,2957 ----
end loop;
end if;
! Restore_Scope_Stack (Handle_Use => False);
end if;
-- Restore use clauses. For a child unit, use clauses in the
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 sem_ch8.adb
*** sem_ch8.adb 21 Oct 2003 13:42:20 -0000 1.9
--- sem_ch8.adb 27 Oct 2003 13:43:00 -0000
*************** package body Sem_Ch8 is
*** 5072,5078 ****
-- Restore_Scope_Stack --
-------------------------
! procedure Restore_Scope_Stack is
E : Entity_Id;
S : Entity_Id;
Comp_Unit : Node_Id;
--- 5072,5078 ----
-- Restore_Scope_Stack --
-------------------------
! procedure Restore_Scope_Stack (Handle_Use : Boolean := True) is
E : Entity_Id;
S : Entity_Id;
Comp_Unit : Node_Id;
*************** package body Sem_Ch8 is
*** 5174,5179 ****
--- 5174,5180 ----
if SS_Last >= Scope_Stack.First
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
+ and then Handle_Use
then
Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
end if;
*************** package body Sem_Ch8 is
*** 5183,5189 ****
-- Save_Scope_Stack --
----------------------
! procedure Save_Scope_Stack is
E : Entity_Id;
S : Entity_Id;
SS_Last : constant Int := Scope_Stack.Last;
--- 5184,5190 ----
-- Save_Scope_Stack --
----------------------
! procedure Save_Scope_Stack (Handle_Use : Boolean := True) is
E : Entity_Id;
S : Entity_Id;
SS_Last : constant Int := Scope_Stack.Last;
*************** package body Sem_Ch8 is
*** 5192,5199 ****
if SS_Last >= Scope_Stack.First
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
then
!
! End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
-- If the call is from within a compilation unit, as when
-- called from Rtsfind, make current entries in scope stack
--- 5193,5201 ----
if SS_Last >= Scope_Stack.First
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
then
! if Handle_Use then
! End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
! end if;
-- If the call is from within a compilation unit, as when
-- called from Rtsfind, make current entries in scope stack
Index: sem_ch8.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.ads,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 sem_ch8.ads
*** sem_ch8.ads 21 Oct 2003 13:42:20 -0000 1.7
--- sem_ch8.ads 27 Oct 2003 13:43:00 -0000
*************** package Sem_Ch8 is
*** 135,148 ****
-- or else a with-clause on system. N is absent when the function is
-- called to find the visibility of implicit operators.
! procedure Restore_Scope_Stack;
! procedure Save_Scope_Stack;
-- These two procedures are called from Semantics, when a unit U1 is
-- to be compiled in the course of the compilation of another unit U2.
-- This happens whenever Rtsfind is called. U1, the unit retrieved by
-- Rtsfind, must be compiled in its own context, and the current scope
-- stack containing U2 and local scopes must be made unreachable. On
-- return, the contents of the scope stack must be made accessible again.
procedure Set_Use (L : List_Id);
-- Find use clauses that are declarative items in a package declaration
--- 135,152 ----
-- or else a with-clause on system. N is absent when the function is
-- called to find the visibility of implicit operators.
! procedure Restore_Scope_Stack (Handle_Use : Boolean := True);
! procedure Save_Scope_Stack (Handle_Use : Boolean := True);
-- These two procedures are called from Semantics, when a unit U1 is
-- to be compiled in the course of the compilation of another unit U2.
-- This happens whenever Rtsfind is called. U1, the unit retrieved by
-- Rtsfind, must be compiled in its own context, and the current scope
-- stack containing U2 and local scopes must be made unreachable. On
-- return, the contents of the scope stack must be made accessible again.
+ -- The flag Handle_Use indicates whether local use clauses must be
+ -- removed/installed. In the case of inlining of instance bodies, the
+ -- visiblity handling is done fully in Inline_Instance_Body, and use
+ -- clauses are handled there.
procedure Set_Use (L : List_Id);
-- Find use clauses that are declarative items in a package declaration
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.44
diff -u -c -3 -p -r1.44 Make-lang.in
*** Make-lang.in 24 Oct 2003 13:02:42 -0000 1.44
--- Make-lang.in 27 Oct 2003 13:43:00 -0000
*************** ada.stagefeedback: stagefeedback-start
*** 969,975 ****
-$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stagefeedback/ada
-$(MV) ada/stamp-* stagefeedback/ada
! check-ada:
\f
# Bootstrapping targets for just GNAT - use the same stage directories
gnatboot: force
--- 969,985 ----
-$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stagefeedback/ada
-$(MV) ada/stamp-* stagefeedback/ada
! check-ada: check-gnat
!
! ACATSDIR = $(TESTSUITEDIR)/ada/acats
!
! check-gnat:
! test -d $(ACATSDIR) || mkdir -p $(ACATSDIR)
! testdir=`cd ${srcdir}/${ACATSDIR}; ${PWD_COMMAND}`; \
! export testdir; cd $(ACATSDIR); $${testdir}/run_acats $(CHAPTERS)
!
! .PHONY: check-gnat
!
\f
# Bootstrapping targets for just GNAT - use the same stage directories
gnatboot: force
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: ada updates
@ 2003-10-24 14:46 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-10-24 14:46 UTC (permalink / raw)
To: gcc-patches
These changes help reducing further the differences between ACT and
FSF trees by putting back pragmas that had been removed previousely.
Tested on x86-linux.
--
2003-10-24 Arnaud Charlet <charlet@act-europe.fr>
* gnatvsn.ads (Gnat_Static_Version_String): New constant, used to
minimize the differences with ACT tree.
* gnatkr.adb, gnatlink.adb, gnatls.adb, gnatmake.adb,
gnatprep.adb, gnatpsta.adb, gnatvsn.ads: Take advantage of
Gnatvsn.Gnat_Static_Version_String to reduce differences between
ACT and FSF trees.
--
Index: gnatkr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatkr.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 gnatkr.adb
*** gnatkr.adb 21 Oct 2003 13:42:08 -0000 1.6
--- gnatkr.adb 24 Oct 2003 14:38:44 -0000
***************
*** 26,35 ****
--- 26,38 ----
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
+ with Gnatvsn;
with Krunch;
with System.IO; use System.IO;
procedure Gnatkr is
+ pragma Ident (Gnatvsn.Gnat_Static_Version_String);
+
Count : Natural;
Maxlen : Integer;
Exit_Program : exception;
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 gnatlink.adb
*** gnatlink.adb 21 Oct 2003 13:42:08 -0000 1.8
--- gnatlink.adb 24 Oct 2003 14:38:44 -0000
*************** with GNAT.OS_Lib; use GNAT.OS_L
*** 44,49 ****
--- 44,50 ----
with Interfaces.C_Streams; use Interfaces.C_Streams;
procedure Gnatlink is
+ pragma Ident (Gnatvsn.Gnat_Static_Version_String);
package Gcc_Linker_Options is new Table.Table (
Table_Component_Type => String_Access,
Index: gnatls.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatls.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 gnatls.adb
*** gnatls.adb 21 Oct 2003 13:42:08 -0000 1.10
--- gnatls.adb 24 Oct 2003 14:38:44 -0000
*************** with Targparm; use Targparm;
*** 41,46 ****
--- 41,48 ----
with Types; use Types;
procedure Gnatls is
+ pragma Ident (Gnat_Static_Version_String);
+
Max_Column : constant := 80;
type File_Status is (
Index: gnatmake.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatmake.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 gnatmake.adb
*** gnatmake.adb 21 Oct 2003 13:42:08 -0000 1.6
--- gnatmake.adb 24 Oct 2003 14:38:44 -0000
***************
*** 26,34 ****
--- 26,36 ----
-- Gnatmake usage: please consult the gnat documentation
+ with Gnatvsn;
with Make;
procedure Gnatmake is
+ pragma Ident (Gnatvsn.Gnat_Static_Version_String);
begin
-- The real work is done in Package Make. Gnatmake used to be a standalone
-- routine. Now Gnatmake's facilities have been placed in a package
Index: gnatprep.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatprep.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 gnatprep.adb
*** gnatprep.adb 21 Oct 2003 13:42:08 -0000 1.7
--- gnatprep.adb 24 Oct 2003 14:38:44 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1996-2002, 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1996-2003, 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- --
***************
*** 24,32 ****
--- 24,34 ----
-- --
------------------------------------------------------------------------------
+ with Gnatvsn;
with GPrep;
procedure GNATprep is
+ pragma Ident (Gnatvsn.Gnat_Static_Version_String);
begin
-- Everything is done in GPrep
Index: gnatpsta.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatpsta.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 gnatpsta.adb
*** gnatpsta.adb 21 Oct 2003 13:42:08 -0000 1.6
--- gnatpsta.adb 24 Oct 2003 14:38:44 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1997-2001 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1997-2003 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- --
***************
*** 33,43 ****
--- 33,46 ----
-- integer and floating point sizes.
with Ada.Text_IO; use Ada.Text_IO;
+ with Gnatvsn;
with Ttypef; use Ttypef;
with Ttypes; use Ttypes;
with Types; use Types;
procedure GnatPsta is
+ pragma Ident (Gnatvsn.Gnat_Static_Version_String);
+
procedure P (Item : String) renames Ada.Text_IO.Put_Line;
procedure P_Int_Range (Size : Pos; Put_First : Boolean := True);
Index: gnatvsn.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatvsn.ads,v
retrieving revision 1.130
diff -u -c -3 -p -r1.130 gnatvsn.ads
*** gnatvsn.ads 21 Oct 2003 13:42:08 -0000 1.130
--- gnatvsn.ads 24 Oct 2003 14:38:44 -0000
*************** package Gnatvsn is
*** 41,46 ****
--- 41,50 ----
-- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run
-- (with appropriate verbose option switch set).
+ Gnat_Static_Version_String : constant String := "GNU Ada";
+ -- Static string identifying this version, that can be used as an argument
+ -- to e.g. pragma Ident.
+
Gnat_Version_Type : constant String := "FSF ";
-- GNAT FSF version. This version of GNAT is part of a Free Software
-- Foundation release of the GNU Compiler Collection (GCC). The binder
^ permalink raw reply [flat|nested] 178+ messages in thread
* committed: ada updates
@ 2003-10-24 13:22 Arnaud Charlet
0 siblings, 0 replies; 178+ messages in thread
From: Arnaud Charlet @ 2003-10-24 13:22 UTC (permalink / raw)
To: gcc-patches
PR fixes and improvements, described in log below.
diff against Make-lang.in not included since huge and mechanical.
2003-10-24 Pascal Obry <obry@gnat.com>
* adadecode.c (ostrcpy): New function.
(__gnat_decode): Use ostrcpy of strcpy.
(has_prefix): Set first parameter a const.
(has_suffix): Set first parameter a const.
Update copyright notice. Fix source name in header.
Removes a trailing space.
PR ada/12014.
2003-10-24 Jose Ruiz <ruiz@act-europe.fr>
* exp_disp.adb:
Remove the test against being in No_Run_Time_Mode before generating a
call to Register_Tag. It is redundant with the test against the
availability of the function Register_Tag.
2003-10-24 Vincent Celier <celier@gnat.com>
* g-catiio.adb: (Month_Name): Correct spelling of February
* make.adb: (Mains): New package
(Initialize): Call Mains.Delete
(Gnatmake): Check that each main on the command line is a source of a
project file and, if there are several mains, each of them is a source
of the same project file.
(Gnatmake): When a foreign language is specified in attribute Languages,
no main is specified on the command line and attribute Mains is not
empty, only build the Ada main. If there is no Ada main, just compile
the Ada sources and their closure.
(Gnatmake): If a main is specified on the command line with directory
information, check that the source exists and, if it does, that the path
is the actual path of a source of a project.
* prj-env.adb:
(File_Name_Of_Library_Unit_Body): New Boolean parameter Full_Path. When
Full_Path is True, return the full path instead of the simple file name.
(Project_Of): New function
* prj-env.ads:
(File_Name_Of_Library_Unit_Body): New Boolean parameter Full_Path,
defaulted to False.
(Project_Of): New function
2003-10-24 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic:
Ensure objects of main project are always checked and rebuilt if needed.
Set CC to gcc by default.
Prepare new handling of link by creating a global archive (not activated
yet).
* adadecode.h, atree.h, elists.h, nlists.h, raise.h,
stringt.h: Update copyright notice. Remove trailing blanks.
Fix source name in header.
2003-10-24 Robert Dewar <dewar@gnat.com>
* sem_ch12.adb: Minor reformatting
* sem_ch3.adb:
Minor reformatting (including new function return style throughout)
* sem_ch3.ads:
Minor reformatting (including new function return style throughout)
2003-10-24 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: adadecode.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adadecode.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 adadecode.c
*** adadecode.c 24 Apr 2003 17:53:57 -0000 1.5
--- adadecode.c 24 Oct 2003 12:12:38 -0000
***************
*** 2,12 ****
* *
* GNAT COMPILER COMPONENTS *
* *
! * G N A T D E C O *
* *
* C Implementation File *
* *
! * Copyright (C) 2001-2002, 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- *
--- 2,12 ----
* *
* GNAT COMPILER COMPONENTS *
* *
! * A D A D E C O D E *
* *
* C Implementation File *
* *
! * Copyright (C) 2001-2003, 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,49 ****
#include "adadecode.h"
static void add_verbose PARAMS ((const char *, char *));
! static int has_prefix PARAMS ((char *, const char *));
! static int has_suffix PARAMS ((char *, const char *));
/* Set to nonzero if we have written any verbose info. */
static int verbose_info;
--- 42,53 ----
#include "adadecode.h"
static void add_verbose PARAMS ((const char *, char *));
! static int has_prefix PARAMS ((const char *, const char *));
! static int has_suffix PARAMS ((const char *, const char *));
!
! /* This is a safe version of strcpy that can be used with overlapped
! pointers. Does nothing if s2 <= s1. */
! static void ostrcpy (char *s1, char *s2);
/* Set to nonzero if we have written any verbose info. */
static int verbose_info;
*************** static void add_verbose (text, ada_name)
*** 65,71 ****
static int
has_prefix (name, prefix)
! char *name;
const char *prefix;
{
return strncmp (name, prefix, strlen (prefix)) == 0;
--- 69,75 ----
static int
has_prefix (name, prefix)
! const char *name;
const char *prefix;
{
return strncmp (name, prefix, strlen (prefix)) == 0;
*************** has_prefix (name, prefix)
*** 75,81 ****
static int
has_suffix (name, suffix)
! char *name;
const char *suffix;
{
int nlen = strlen (name);
--- 79,85 ----
static int
has_suffix (name, suffix)
! const char *name;
const char *suffix;
{
int nlen = strlen (name);
*************** has_suffix (name, suffix)
*** 84,89 ****
--- 88,105 ----
return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0;
}
+ /* Safe overlapped pointers version of strcpy. */
+
+ static void
+ ostrcpy (char *s1, char *s2)
+ {
+ if (s2 > s1)
+ {
+ while (*s2) *s1++ = *s2++;
+ *s1 = '\0';
+ }
+ }
+
/* This function will return the Ada name from the encoded form.
The Ada coding is done in exp_dbug.ads and this is the inverse function.
see exp_dbug.ads for full encoding rules, a short description is added
*************** __gnat_decode (coded_name, ada_name, ver
*** 142,157 ****
int in_task = 0;
int body_nested = 0;
- /* Copy the coded name into the ada name string, the rest of the code will
- just replace or add characters into the ada_name. */
- strcpy (ada_name, coded_name);
-
/* Check for library level subprogram. */
! if (has_prefix (ada_name, "_ada_"))
{
! strcpy (ada_name, ada_name + 5);
lib_subprog = 1;
}
/* Check for task body. */
if (has_suffix (ada_name, "TKB"))
--- 158,171 ----
int in_task = 0;
int body_nested = 0;
/* Check for library level subprogram. */
! if (has_prefix (coded_name, "_ada_"))
{
! strcpy (ada_name, coded_name + 5);
lib_subprog = 1;
}
+ else
+ strcpy (ada_name, coded_name);
/* Check for task body. */
if (has_suffix (ada_name, "TKB"))
*************** __gnat_decode (coded_name, ada_name, ver
*** 191,197 ****
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
{
! strcpy (tktoken, tktoken + 2);
in_task = 1;
}
}
--- 205,211 ----
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
{
! ostrcpy (tktoken, tktoken + 2);
in_task = 1;
}
}
*************** __gnat_decode (coded_name, ada_name, ver
*** 229,235 ****
if (ada_name[k] == '_' && ada_name[k+1] == '_')
{
ada_name[k] = '.';
! strcpy (ada_name + k + 1, ada_name + k + 2);
len = len - 1;
}
k++;
--- 243,249 ----
if (ada_name[k] == '_' && ada_name[k+1] == '_')
{
ada_name[k] = '.';
! ostrcpy (ada_name + k + 1, ada_name + k + 2);
len = len - 1;
}
k++;
*************** __gnat_decode (coded_name, ada_name, ver
*** 259,265 ****
if (codedlen > oplen)
/* We shrink the space. */
! strcpy (optoken, optoken + codedlen - oplen);
else if (oplen > codedlen)
{
/* We need more space. */
--- 273,279 ----
if (codedlen > oplen)
/* We shrink the space. */
! ostrcpy (optoken, optoken + codedlen - oplen);
else if (oplen > codedlen)
{
/* We need more space. */
*************** __gnat_decode (coded_name, ada_name, ver
*** 285,291 ****
}
/* If verbose mode is on, we add some information to the Ada name. */
! if (verbose)
{
if (overloaded)
add_verbose ("overloaded", ada_name);
--- 299,305 ----
}
/* If verbose mode is on, we add some information to the Ada name. */
! if (verbose)
{
if (overloaded)
add_verbose ("overloaded", ada_name);
Index: exp_disp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_disp.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 exp_disp.adb
*** exp_disp.adb 21 Oct 2003 13:41:59 -0000 1.5
--- exp_disp.adb 24 Oct 2003 12:12:38 -0000
*************** package body Exp_Disp is
*** 922,932 ****
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available, or in No_Run_Time mode
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
- and then not No_Run_Time_Mode
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
--- 922,931 ----
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Index: g-catiio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-catiio.adb,v
retrieving revision 1.4
diff -u -c -3 -p -r1.4 g-catiio.adb
*** g-catiio.adb 21 Oct 2003 13:42:00 -0000 1.4
--- g-catiio.adb 24 Oct 2003 12:12:38 -0000
*************** package body GNAT.Calendar.Time_IO is
*** 44,50 ****
type Month_Name is
(January,
! Febuary,
March,
April,
May,
--- 44,50 ----
type Month_Name is
(January,
! February,
March,
April,
May,
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.17
diff -u -c -3 -p -r1.17 make.adb
*** make.adb 21 Oct 2003 13:42:09 -0000 1.17
--- make.adb 24 Oct 2003 12:12:39 -0000
*************** with Ada.Exceptions; use Ada.Exception
*** 28,33 ****
--- 28,34 ----
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+ with GNAT.Case_Util; use GNAT.Case_Util;
with ALI; use ALI;
with ALI.Util; use ALI.Util;
*************** package body Make is
*** 178,183 ****
--- 179,209 ----
Table_Name => "Make.Q");
-- This is the actual Q.
+
+ -- Package Mains is used to store the mains specified on the command line
+ -- and to retrieve them when a project file is used, to verify that the
+ -- files exist and that they belong to a project file.
+
+ package Mains is
+
+ -- Mains are stored in a table. An index is used to retrieve the mains
+ -- from the table.
+
+ procedure Add_Main (Name : String);
+ -- Add one main to the table
+
+ procedure Delete;
+ -- Empty the table
+
+ procedure Reset;
+ -- Reset the index to the beginning of the table
+
+ function Next_Main return String;
+ -- Increase the index and return the next main.
+ -- If table is exhausted, return an empty string.
+
+ end Mains;
+
-- The following instantiations and variables are necessary to save what
-- is found on the command line, in case there is a project file specified.
*************** package body Make is
*** 3340,3345 ****
--- 3366,3512 ----
if Projects.Table (Main_Project).Library then
Make_Failed ("cannot specify a main program " &
"on the command line for a library project file");
+
+ else
+ -- Check that each main on the command line is a source of a
+ -- project file and, if there are several mains, each of them
+ -- is a source of the same project file.
+
+ Mains.Reset;
+
+ declare
+ Real_Main_Project : Project_Id := No_Project;
+ -- The project of the first main
+
+ Proj : Project_Id := No_Project;
+ -- The project of the current main
+
+ begin
+ -- Check each main
+
+ loop
+ declare
+ Main : constant String := Mains.Next_Main;
+ -- The name specified on the command line may include
+ -- directory information.
+
+ File_Name : constant String := Base_Name (Main);
+ -- The simple file name of the current main main
+
+ begin
+ exit when Main = "";
+
+ -- Get the project of the current main
+
+ Proj := Prj.Env.Project_Of (File_Name, Main_Project);
+
+ -- Fail if the current main is not a source of a
+ -- project.
+
+ if Proj = No_Project then
+ Make_Failed
+ ("""" & Main &
+ """ is not a source of any project");
+
+ else
+ -- If there is directory information, check that
+ -- the source exists and, if it does, that the path
+ -- is the actual path of a source of a project.
+
+ if Main /= File_Name then
+ declare
+ Data : constant Project_Data :=
+ Projects.Table (Main_Project);
+
+ Project_Path : constant String :=
+ Prj.Env.File_Name_Of_Library_Unit_Body
+ (Name => File_Name,
+ Project => Main_Project,
+ Main_Project_Only => False,
+ Full_Path => True);
+ Real_Path : String_Access :=
+ Locate_Regular_File
+ (Main &
+ Get_Name_String
+ (Data.Naming.Current_Body_Suffix),
+ "");
+ begin
+ if Real_Path = null then
+ Real_Path :=
+ Locate_Regular_File
+ (Main &
+ Get_Name_String
+ (Data.Naming.Current_Spec_Suffix),
+ "");
+ end if;
+
+ if Real_Path = null then
+ Real_Path :=
+ Locate_Regular_File (Main, "");
+ end if;
+
+ -- Fail if the file cannot be found
+
+ if Real_Path = null then
+ Make_Failed
+ ("file """ & Main & """ does not exist");
+ end if;
+
+ declare
+ Normed_Path : constant String :=
+ Normalize_Pathname
+ (Real_Path.all,
+ Case_Sensitive => False);
+ begin
+ Free (Real_Path);
+
+ -- Fail if it is not the correct path
+
+ if Normed_Path /= Project_Path then
+ if Verbose_Mode then
+ Write_Str (Normed_Path);
+ Write_Str (" /= ");
+ Write_Line (Project_Path);
+ end if;
+
+ Make_Failed
+ ("""" & Main &
+ """ is not a source of any project");
+ end if;
+ end;
+ end;
+ end if;
+
+ if not Unique_Compile then
+ -- Record the project, if it is the first main
+
+ if Real_Main_Project = No_Project then
+ Real_Main_Project := Proj;
+
+ elsif Proj /= Real_Main_Project then
+ -- Fail, as the current main is not a source
+ -- of the same project as the first main.
+
+ Make_Failed
+ ("""" & Main &
+ """ is not a source of project " &
+ Get_Name_String
+ (Projects.Table
+ (Real_Main_Project).Name));
+ end if;
+ end if;
+ end if;
+
+ -- If -u and -U are not used, we may have mains that
+ -- are sources of a project that is not the one
+ -- specified with switch -P.
+
+ if not Unique_Compile then
+ Main_Project := Real_Main_Project;
+ end if;
+ end;
+ end loop;
+ end;
end if;
-- If no mains have been specified on the command line,
*************** package body Make is
*** 3383,3395 ****
else
-- The attribute Main is not an empty list.
-- Put all the main subprograms in the list as if there
! -- were specified on the command line.
! while Value /= Prj.Nil_String loop
! Get_Name_String (String_Elements.Table (Value).Value);
! Osint.Add_File (Name_Buffer (1 .. Name_Len));
! Value := String_Elements.Table (Value).Next;
! end loop;
end if;
end;
--- 3550,3641 ----
else
-- The attribute Main is not an empty list.
-- Put all the main subprograms in the list as if there
! -- were specified on the command line. However, if attribute
! -- Languages includes a language other than Ada, only
! -- include the Ada mains; if there is no Ada main, compile
! -- all the sources of the project.
! declare
! Data : Project_Data := Projects.Table (Main_Project);
! Languages : Variable_Value :=
! Prj.Util.Value_Of
! (Name_Languages, Data.Decl.Attributes);
! Current : String_List_Id;
! Element : String_Element;
! Foreign_Language : Boolean := False;
! At_Least_One_Main : Boolean := False;
!
! begin
! -- First, determine if there is a foreign language in
! -- attribute Languages.
!
! if not Languages.Default then
! Current := Languages.Values;
!
! Look_For_Foreign :
! while Current /= Nil_String loop
! Element := String_Elements.Table (Current);
! Get_Name_String (Element.Value);
! To_Lower (Name_Buffer (1 .. Name_Len));
!
! if Name_Buffer (1 .. Name_Len) /= "ada" then
! Foreign_Language := True;
! exit Look_For_Foreign;
! end if;
!
! Current := Element.Next;
! end loop Look_For_Foreign;
! end if;
!
! -- The, find all mains, or if there is a foreign
! -- language, all the Ada mains.
!
! while Value /= Prj.Nil_String loop
! Get_Name_String (String_Elements.Table (Value).Value);
!
! -- To know if a main is an Ada main, get its project;
! -- it should be the project specified on the command
! -- line.
!
! if (not Foreign_Language) or else
! Prj.Env.Project_Of
! (Name_Buffer (1 .. Name_Len), Main_Project) =
! Main_Project
! then
! At_Least_One_Main := True;
! Osint.Add_File
! (Get_Name_String
! (String_Elements.Table (Value).Value));
! end if;
!
! Value := String_Elements.Table (Value).Next;
! end loop;
!
! -- If we did not get any main, it means that all mains
! -- in attribute Mains are in a foreign language. So,
! -- we put all sources of the main project in the Q.
!
! if not At_Least_One_Main then
! -- First make sure that the binder and the linker
! -- will not be invoked.
!
! Do_Bind_Step := False;
! Do_Link_Step := False;
!
! -- Put all the sources in the queue
!
! Insert_Project_Sources
! (The_Project => Main_Project,
! All_Projects => Unique_Compile_All_Projects,
! Into_Q => False);
!
! -- If there are no sources to compile, we fail
!
! if Osint.Number_Of_Files = 0 then
! Make_Failed ("no sources to compile");
! end if;
! end if;
! end;
end if;
end;
*************** package body Make is
*** 5256,5261 ****
--- 5502,5509 ----
RTS_Specified := null;
+ Mains.Delete;
+
Next_Arg := 1;
Scan_Args : while Next_Arg <= Argument_Count loop
Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
*************** package body Make is
*** 5850,5855 ****
--- 6098,6165 ----
Set_Standard_Error;
end List_Depend;
+ -----------
+ -- Mains --
+ -----------
+
+ package body Mains is
+
+ package Names is new Table.Table
+ (Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Make.Mains.Names");
+ -- The table that stores the main
+
+ Current : Natural := 0;
+ -- The index of the last main retrieved from the table
+
+ --------------
+ -- Add_Main --
+ --------------
+
+ procedure Add_Main (Name : String) is
+ begin
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Name);
+ Names.Increment_Last;
+ Names.Table (Names.Last) := Name_Find;
+ end Add_Main;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete is
+ begin
+ Names.Set_Last (0);
+ Reset;
+ end Delete;
+
+ ---------------
+ -- Next_Main --
+ ---------------
+
+ function Next_Main return String is
+ begin
+ if Current >= Names.Last then
+ return "";
+
+ else
+ Current := Current + 1;
+ return Get_Name_String (Names.Table (Current));
+ end if;
+ end Next_Main;
+
+ procedure Reset is
+ begin
+ Current := 0;
+ end Reset;
+
+ end Mains;
+
----------
-- Mark --
----------
*************** package body Make is
*** 6521,6526 ****
--- 6831,6837 ----
else
Add_File (Argv);
+ Mains.Add_Main (Argv);
end if;
end Scan_Make_Arg;
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 Makefile.generic
*** Makefile.generic 21 Oct 2003 13:41:53 -0000 1.1
--- Makefile.generic 24 Oct 2003 12:12:39 -0000
***************
*** 47,52 ****
--- 47,53 ----
# CXX name of the C++ compiler (optional, default to gcc)
# AR_CMD command to create an archive (optional, default to "ar rc")
# AR_EXT file extension of an archive (optional, default to ".a")
+ # RANLIB command to generate an index (optional, default to "ranlib")
# GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
# CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
***************
*** 56,61 ****
--- 57,63 ----
# ADA_SOURCES list of main Ada sources (optional)
# EXEC name of the final executable (optional)
# MAIN language of the main program (optional)
+ # MAIN_OBJECT main object file (optional)
# PROJECT_FILE name of the project file, without the .gpr extension
# DEPS_PROJECTS list of project dependencies (optional)
*************** ifndef MAIN
*** 65,70 ****
--- 67,76 ----
MAIN=ada
endif
+ ifndef CC
+ CC=gcc
+ endif
+
ifndef ADA_SPEC
ADA_SPEC=.ads
endif
*************** ifndef AR_CMD
*** 100,109 ****
--- 106,123 ----
AR_CMD=ar rc
endif
+ ifndef RANLIB
+ RANLIB=ranlib
+ endif
+
ifndef GNATMAKE
GNATMAKE=gnatmake
endif
+ ifndef ARCHIVE
+ ARCHIVE=$(OBJ_DIR)/lib$(PROJECT_BASE)-full$(AR_EXT)
+ endif
+
ifeq ($(EXEC_DIR),)
EXEC_DIR=$(OBJ_DIR)
endif
*************** vpath %$(AR_EXT) $(OBJ_DIR)
*** 120,125 ****
--- 134,140 ----
clean_deps = $(subst :,|,$(DEPS_PROJECTS:%=clean_%))
compile_deps = $(subst :,|,$(DEPS_PROJECTS:%=compile_%))
+ object_deps = $(subst :,|,$(DEPS_PROJECTS:%=object_%))
ada_deps = $(subst :,|,$(DEPS_PROJECTS:%=ada_%))
c_deps = $(subst :,|,$(DEPS_PROJECTS:%=c_%))
c++_deps = $(subst :,|,$(DEPS_PROJECTS:%=c++_%))
*************** clean: $(clean_deps) internal-clean
*** 131,136 ****
--- 146,152 ----
build: $(compile_deps) internal-compile internal-build
compile: $(compile_deps) internal-compile $(ADA_SOURCES)
ada: $(ada_deps) internal-ada
+ archive-objects: $(object_deps) internal-archive-objects
c: $(c_deps) internal-c
c++: $(c++deps) internal-c++
*************** $(clean_deps): force
*** 140,145 ****
--- 156,164 ----
$(compile_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile
+ $(object_deps): force
+ @$(MAKE) -C $(dir $(@:object_%=%)) -f Makefile.$(notdir $@) internal-archive-objects ARCHIVE=$(ARCHIVE)
+
$(ada_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada
*************** DEP_FILES := $(OBJ_FILES:$(OBJ_EXT)=.d)
*** 238,243 ****
--- 257,263 ----
ifeq ($(strip $(OBJECTS)),)
internal-compile:
+ internal-archive-objects:
else
internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
*************** internal-compile: lib$(PROJECT_BASE)$(AR
*** 245,251 ****
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
@echo creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
! -ranlib $(OBJ_DIR)/$@
endif
# Linking rules
--- 265,277 ----
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
@echo creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
! -$(RANLIB) $(OBJ_DIR)/$@
!
! internal-archive-objects: $(OBJECTS)
! # @echo $(AR_CMD) $(ARCHIVE) $(strip $(OBJECTS))
! # cd $(OBJ_DIR); $(AR_CMD) $(ARCHIVE) $(strip $(OBJECTS))
! # -$(RANLIB) $(OBJ_DIR)/$@
!
endif
# Linking rules
*************** endif
*** 260,268 ****
ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
# link with C/C++
! link: $(EXEC_DIR)/$(EXEC)
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
! $(LINKER) $(OBJ_FILES) -o $(EXEC_DIR)/$(EXEC) $(LDFLAGS)
internal-build: internal-compile link
--- 286,309 ----
ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
# link with C/C++
! ifeq ($(MAIN_OBJECT),)
! link:
! @echo link: no main object specified, exiting...
! exit 1
! else
! ifeq ($(EXEC),)
!
! link:
! @echo link: no executable specified, exiting...
! exit 1
! else
!
! link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
! @echo $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
! $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
! endif
! endif
internal-build: internal-compile link
*************** ifeq ($(strip $(filter-out c c++ ada,$(L
*** 272,282 ****
ifeq ($(MAIN),ada)
# Ada main
! link: $(LINKER) force
$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
! internal-build: $(LINKER) force
@echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
--- 313,323 ----
ifeq ($(MAIN),ada)
# Ada main
! link: $(LINKER) archive-objects force
$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
! internal-build: $(LINKER) archive-objects force
@echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
*************** else
*** 288,298 ****
# close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch.
! link: $(LINKER) force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS)
! internal-build: $(LINKER) force
@echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) -z \
-P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
--- 329,339 ----
# close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch.
! link: $(LINKER) archive-objects force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS)
! internal-build: $(LINKER) archive-objects force
@echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) -z \
-P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
*************** internal-c : $(C_OBJECTS)
*** 385,391 ****
# Compile all C++ files in the project
internal-c++ : $(CXX_OBJECTS)
! .PHONY: force internal-clean internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
internal-clean:
@echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
--- 426,432 ----
# Compile all C++ files in the project
internal-c++ : $(CXX_OBJECTS)
! .PHONY: force internal-clean internal-archive internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
internal-clean:
@echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
Index: prj-env.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-env.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 prj-env.adb
*** prj-env.adb 21 Oct 2003 13:42:12 -0000 1.10
--- prj-env.adb 24 Oct 2003 12:12:39 -0000
*************** package body Prj.Env is
*** 1060,1066 ****
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True)
return String
is
The_Project : Project_Id := Project;
--- 1060,1067 ----
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False)
return String
is
The_Project : Project_Id := Project;
*************** package body Prj.Env is
*** 1151,1157 ****
Write_Line (" OK");
end if;
! return Get_Name_String (Current_Name);
-- If it has the name of the extended body name,
-- return the extended body name
--- 1152,1164 ----
Write_Line (" OK");
end if;
! if Full_Path then
! return Get_Name_String
! (Unit.File_Names (Body_Part).Path);
!
! else
! return Get_Name_String (Current_Name);
! end if;
-- If it has the name of the extended body name,
-- return the extended body name
*************** package body Prj.Env is
*** 1161,1167 ****
Write_Line (" OK");
end if;
! return Extended_Body_Name;
else
if Current_Verbosity = High then
--- 1168,1180 ----
Write_Line (" OK");
end if;
! if Full_Path then
! return Get_Name_String
! (Unit.File_Names (Body_Part).Path);
!
! else
! return Extended_Body_Name;
! end if;
else
if Current_Verbosity = High then
*************** package body Prj.Env is
*** 1202,1208 ****
Write_Line (" OK");
end if;
! return Get_Name_String (Current_Name);
-- If it has the same name as the extended spec name,
-- return the extended spec name.
--- 1215,1228 ----
Write_Line (" OK");
end if;
!
! if Full_Path then
! return Get_Name_String
! (Unit.File_Names (Specification).Path);
!
! else
! return Get_Name_String (Current_Name);
! end if;
-- If it has the same name as the extended spec name,
-- return the extended spec name.
*************** package body Prj.Env is
*** 1212,1218 ****
Write_Line (" OK");
end if;
! return Extended_Spec_Name;
else
if Current_Verbosity = High then
--- 1232,1244 ----
Write_Line (" OK");
end if;
! if Full_Path then
! return Get_Name_String
! (Unit.File_Names (Specification).Path);
!
! else
! return Extended_Spec_Name;
! end if;
else
if Current_Verbosity = High then
*************** package body Prj.Env is
*** 1700,1705 ****
--- 1726,1826 ----
Write_Line ("end of List of Sources.");
end Print_Sources;
+
+ ----------------
+ -- Project_Of --
+ ----------------
+
+ function Project_Of
+ (Name : String;
+ Main_Project : Project_Id)
+ return Project_Id
+ is
+ Result : Project_Id := No_Project;
+
+ Original_Name : String := Name;
+
+ Data : constant Project_Data := Projects.Table (Main_Project);
+
+ Extended_Spec_Name : String :=
+ Name & Namet.Get_Name_String
+ (Data.Naming.Current_Spec_Suffix);
+ Extended_Body_Name : String :=
+ Name & Namet.Get_Name_String
+ (Data.Naming.Current_Body_Suffix);
+
+ Unit : Unit_Data;
+
+ Current_Name : Name_Id;
+
+ The_Original_Name : Name_Id;
+ The_Spec_Name : Name_Id;
+ The_Body_Name : Name_Id;
+
+ begin
+ Canonical_Case_File_Name (Original_Name);
+ Name_Len := Original_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Original_Name;
+ The_Original_Name := Name_Find;
+
+ Canonical_Case_File_Name (Extended_Spec_Name);
+ Name_Len := Extended_Spec_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
+ The_Spec_Name := Name_Find;
+
+ Canonical_Case_File_Name (Extended_Body_Name);
+ Name_Len := Extended_Body_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
+ The_Body_Name := Name_Find;
+
+ for Current in reverse Units.First .. Units.Last loop
+ Unit := Units.Table (Current);
+
+ -- Check for body
+ Current_Name := Unit.File_Names (Body_Part).Name;
+ -- Case of a body present
+
+ if Current_Name /= No_Name then
+ -- If it has the name of the original name or the body name,
+ -- we have found the project.
+
+ if Unit.Name = The_Original_Name
+ or else Current_Name = The_Original_Name
+ or else Current_Name = The_Body_Name
+ then
+ Result := Unit.File_Names (Body_Part).Project;
+ exit;
+ end if;
+ end if;
+
+ -- Check for spec
+
+ Current_Name := Unit.File_Names (Specification).Name;
+
+ if Current_Name /= No_Name then
+ -- If name same as the original name, or the spec name, we have
+ -- found the project.
+
+ if Unit.Name = The_Original_Name
+ or else Current_Name = The_Original_Name
+ or else Current_Name = The_Spec_Name
+ then
+ Result := Unit.File_Names (Specification).Project;
+ exit;
+ end if;
+ end if;
+ end loop;
+
+ -- Get the ultimate extending project
+
+ if Result /= No_Project then
+ while Projects.Table (Result).Extended_By /= No_Project loop
+ Result := Projects.Table (Result).Extended_By;
+ end loop;
+ end if;
+
+ return Result;
+ end Project_Of;
-------------------
-- Set_Ada_Paths --
Index: prj-env.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-env.ads,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 prj-env.ads
*** prj-env.ads 21 Oct 2003 13:42:12 -0000 1.8
--- prj-env.ads 24 Oct 2003 12:12:39 -0000
*************** package Prj.Env is
*** 101,116 ****
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True)
return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
! -- name of the spec is returned. If neither a body or a spec can be found,
! -- return an empty string.
-- If Main_Project_Only is True, the unit must be an immediate source of
-- Project. If it is False, it may be a source of one of its imported
-- projects.
procedure Get_Reference
(Source_File_Name : String;
--- 101,128 ----
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False)
return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
! -- name of the spec is returned.
! -- If Full_Path is False (the default), the simple file name is returned.
! -- If Full_Path is True, the absolute path name is returned.
! -- If neither a body nor a spec can be found, an empty string is returned.
-- If Main_Project_Only is True, the unit must be an immediate source of
-- Project. If it is False, it may be a source of one of its imported
-- projects.
+
+ function Project_Of
+ (Name : String;
+ Main_Project : Project_Id)
+ return Project_Id;
+ -- Get the project of a source. The source file name may be truncated
+ -- (".adb" or ".ads" may be missing). If the source is in a project being
+ -- extended, return the ultimate extending project. If it is not a source
+ -- of any project, return No_Project.
procedure Get_Reference
(Source_File_Name : String;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.22
diff -u -c -3 -p -r1.22 sem_ch12.adb
*** sem_ch12.adb 22 Oct 2003 09:28:08 -0000 1.22
--- sem_ch12.adb 24 Oct 2003 12:12:39 -0000
*************** package body Sem_Ch12 is
*** 7688,7694 ****
or else
Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
then
-
-- Check whether the parent is another derived formal type
-- in the same generic unit.
--- 7688,7693 ----
*************** package body Sem_Ch12 is
*** 7697,7715 ****
and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
then
-
-- Locate ancestor of parent from the subtype declaration
-- created for the actual.
declare
Decl : Node_Id;
begin
Decl := First (Actual_Decls);
while (Present (Decl)) loop
if Nkind (Decl) = N_Subtype_Declaration
! and then Chars (Defining_Identifier (Decl))
! = Chars (Etype (A_Gen_T))
then
Ancestor := Generic_Parent_Type (Decl);
exit;
--- 7696,7714 ----
and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
then
-- Locate ancestor of parent from the subtype declaration
-- created for the actual.
declare
Decl : Node_Id;
+
begin
Decl := First (Actual_Decls);
while (Present (Decl)) loop
if Nkind (Decl) = N_Subtype_Declaration
! and then Chars (Defining_Identifier (Decl)) =
! Chars (Etype (A_Gen_T))
then
Ancestor := Generic_Parent_Type (Decl);
exit;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 sem_ch3.adb
*** sem_ch3.adb 22 Oct 2003 09:28:08 -0000 1.19
--- sem_ch3.adb 24 Oct 2003 12:12:39 -0000
*************** package body Sem_Ch3 is
*** 169,176 ****
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! Discs : Elist_Id)
! return Elist_Id;
-- Called from Build_Derived_Record_Type to inherit the components of
-- Parent_Base (a base type) into the Derived_Base (the derived base type).
-- For more information on derived types and component inheritance please
--- 169,175 ----
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! Discs : Elist_Id) return Elist_Id;
-- Called from Build_Derived_Record_Type to inherit the components of
-- Parent_Base (a base type) into the Derived_Base (the derived base type).
-- For more information on derived types and component inheritance please
*************** package body Sem_Ch3 is
*** 217,224 ****
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
! Derived_Def : Boolean := False)
! return Elist_Id;
-- Validate discriminant constraints, and return the list of the
-- constraints in order of discriminant declarations. T is the
-- discriminated unconstrained type. Def is the N_Subtype_Indication
--- 216,222 ----
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
! Derived_Def : Boolean := False) return Elist_Id;
-- Validate discriminant constraints, and return the list of the
-- constraints in order of discriminant declarations. T is the
-- discriminated unconstrained type. Def is the N_Subtype_Indication
*************** package body Sem_Ch3 is
*** 256,263 ****
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
! Der_T : Entity_Id)
! return Node_Id;
-- The bounds of a derived scalar type are conversions of the bounds of
-- the parent type. Optimize the representation if the bounds are literals.
-- Needs a more complete spec--what are the parameters exactly, and what
--- 254,260 ----
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
! Der_T : Entity_Id) return Node_Id;
-- The bounds of a derived scalar type are conversions of the bounds of
-- the parent type. Optimize the representation if the bounds are literals.
-- Needs a more complete spec--what are the parameters exactly, and what
*************** package body Sem_Ch3 is
*** 356,363 ****
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
! Constraints : Elist_Id)
! return Entity_Id;
-- Given a discriminated base type Typ, a list of discriminant constraint
-- Constraints for Typ and the type of a component of Typ, Compon_Type,
-- create and return the type corresponding to Compon_type where all
--- 353,359 ----
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
! Constraints : Elist_Id) return Entity_Id;
-- Given a discriminated base type Typ, a list of discriminant constraint
-- Constraints for Typ and the type of a component of Typ, Compon_Type,
-- create and return the type corresponding to Compon_type where all
*************** package body Sem_Ch3 is
*** 419,426 ****
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
! Related_Id : Entity_Id)
! return Entity_Id;
-- When constraining a protected type or task type with discriminants,
-- constrain the corresponding record with the same discriminant values.
--- 415,421 ----
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
! Related_Id : Entity_Id) return Entity_Id;
-- When constraining a protected type or task type with discriminants,
-- constrain the corresponding record with the same discriminant values.
*************** package body Sem_Ch3 is
*** 521,528 ****
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
! Constraint : Elist_Id)
! return Elist_Id;
-- Given a Constraint (ie a list of expressions) on the discriminants of
-- Typ, expand it into a constraint on the stored discriminants and
-- return the new list of expressions constraining the stored
--- 516,522 ----
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
! Constraint : Elist_Id) return Elist_Id;
-- Given a Constraint (ie a list of expressions) on the discriminants of
-- Typ, expand it into a constraint on the stored discriminants and
-- return the new list of expressions constraining the stored
*************** package body Sem_Ch3 is
*** 530,537 ****
function Find_Type_Of_Object
(Obj_Def : Node_Id;
! Related_Nod : Node_Id)
! return Entity_Id;
-- Get type entity for object referenced by Obj_Def, attaching the
-- implicit types generated to Related_Nod
--- 524,530 ----
function Find_Type_Of_Object
(Obj_Def : Node_Id;
! Related_Nod : Node_Id) return Entity_Id;
-- Get type entity for object referenced by Obj_Def, attaching the
-- implicit types generated to Related_Nod
*************** package body Sem_Ch3 is
*** 546,553 ****
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! Constraint_Kind : Node_Kind)
! return Boolean;
-- Returns True if it is legal to apply the given kind of constraint
-- to the given kind of type (index constraint to an array type,
-- for example).
--- 539,545 ----
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! Constraint_Kind : Node_Kind) return Boolean;
-- Returns True if it is legal to apply the given kind of constraint
-- to the given kind of type (index constraint to an array type,
-- for example).
*************** package body Sem_Ch3 is
*** 670,677 ****
function Access_Definition
(Related_Nod : Node_Id;
! N : Node_Id)
! return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
--- 662,668 ----
function Access_Definition
(Related_Nod : Node_Id;
! N : Node_Id) return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
*************** package body Sem_Ch3 is
*** 727,732 ****
--- 718,724 ----
is
Formals : constant List_Id := Parameter_Specifications (T_Def);
Formal : Entity_Id;
+
Desig_Type : constant Entity_Id :=
Create_Itype (E_Subprogram_Type, Parent (T_Def));
*************** package body Sem_Ch3 is
*** 739,744 ****
--- 731,737 ----
Error_Msg_N
("expect type in function specification", Subtype_Mark (T_Def));
end if;
+
else
Set_Etype (Desig_Type, Standard_Void_Type);
end if;
*************** package body Sem_Ch3 is
*** 5322,5329 ****
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
! Derived_Def : Boolean := False)
! return Elist_Id
is
C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T);
--- 5315,5321 ----
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
! Derived_Def : Boolean := False) return Elist_Id
is
C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T);
*************** package body Sem_Ch3 is
*** 5734,5741 ****
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
! Der_T : Entity_Id)
! return Node_Id
is
New_Bound : Entity_Id;
--- 5726,5732 ----
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
! Der_T : Entity_Id) return Node_Id
is
New_Bound : Entity_Id;
*************** package body Sem_Ch3 is
*** 6918,6943 ****
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
! Constraints : Elist_Id)
! return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Constrained_Typ);
function Build_Constrained_Array_Type
! (Old_Type : Entity_Id)
! return Entity_Id;
-- If Old_Type is an array type, one of whose indices is
-- constrained by a discriminant, build an Itype whose constraint
-- replaces the discriminant with its value in the constraint.
function Build_Constrained_Discriminated_Type
! (Old_Type : Entity_Id)
! return Entity_Id;
-- Ditto for record components.
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id)
! return Entity_Id;
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
--- 6909,6930 ----
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
! Constraints : Elist_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Constrained_Typ);
function Build_Constrained_Array_Type
! (Old_Type : Entity_Id) return Entity_Id;
-- If Old_Type is an array type, one of whose indices is
-- constrained by a discriminant, build an Itype whose constraint
-- replaces the discriminant with its value in the constraint.
function Build_Constrained_Discriminated_Type
! (Old_Type : Entity_Id) return Entity_Id;
-- Ditto for record components.
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id) return Entity_Id;
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
*************** package body Sem_Ch3 is
*** 6956,6963 ****
-----------------------------------
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id)
! return Entity_Id
is
Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
Itype : Entity_Id;
--- 6943,6949 ----
-----------------------------------
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id) return Entity_Id
is
Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
Itype : Entity_Id;
*************** package body Sem_Ch3 is
*** 7043,7050 ****
----------------------------------
function Build_Constrained_Array_Type
! (Old_Type : Entity_Id)
! return Entity_Id
is
Lo_Expr : Node_Id;
Hi_Expr : Node_Id;
--- 7029,7035 ----
----------------------------------
function Build_Constrained_Array_Type
! (Old_Type : Entity_Id) return Entity_Id
is
Lo_Expr : Node_Id;
Hi_Expr : Node_Id;
*************** package body Sem_Ch3 is
*** 7104,7111 ****
------------------------------------------
function Build_Constrained_Discriminated_Type
! (Old_Type : Entity_Id)
! return Entity_Id
is
Expr : Node_Id;
Constr_List : List_Id;
--- 7089,7095 ----
------------------------------------------
function Build_Constrained_Discriminated_Type
! (Old_Type : Entity_Id) return Entity_Id
is
Expr : Node_Id;
Constr_List : List_Id;
*************** package body Sem_Ch3 is
*** 7374,7381 ****
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
! Related_Id : Entity_Id)
! return Entity_Id
is
T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
--- 7358,7364 ----
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
! Related_Id : Entity_Id) return Entity_Id
is
T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
*************** package body Sem_Ch3 is
*** 9249,9256 ****
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
! Constraint : Elist_Id)
! return Elist_Id
is
Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id;
--- 9232,9238 ----
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
! Constraint : Elist_Id) return Elist_Id
is
Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id;
*************** package body Sem_Ch3 is
*** 9517,9524 ****
function Find_Type_Of_Object
(Obj_Def : Node_Id;
! Related_Nod : Node_Id)
! return Entity_Id
is
Def_Kind : constant Node_Kind := Nkind (Obj_Def);
P : constant Node_Id := Parent (Obj_Def);
--- 9499,9505 ----
function Find_Type_Of_Object
(Obj_Def : Node_Id;
! Related_Nod : Node_Id) return Entity_Id
is
Def_Kind : constant Node_Kind := Nkind (Obj_Def);
P : constant Node_Id := Parent (Obj_Def);
*************** package body Sem_Ch3 is
*** 9810,9823 ****
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
! Constraint : Elist_Id)
! return Node_Id
is
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
! Stored_Discrim_Values : Boolean)
! return Node_Or_Entity_Id;
-- This is the routine that performs the recursive search of levels
-- as described above.
--- 9791,9802 ----
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
! Constraint : Elist_Id) return Node_Id
is
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
! Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
-- This is the routine that performs the recursive search of levels
-- as described above.
*************** package body Sem_Ch3 is
*** 9828,9835 ****
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
! Stored_Discrim_Values : Boolean)
! return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
Disc : Entity_Id;
--- 9807,9813 ----
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
! Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
Disc : Entity_Id;
*************** package body Sem_Ch3 is
*** 10051,10058 ****
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! Discs : Elist_Id)
! return Elist_Id
is
Assoc_List : constant Elist_Id := New_Elmt_List;
--- 10029,10035 ----
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! Discs : Elist_Id) return Elist_Id
is
Assoc_List : constant Elist_Id := New_Elmt_List;
*************** package body Sem_Ch3 is
*** 10288,10295 ****
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! Constraint_Kind : Node_Kind)
! return Boolean
is
begin
case T_Kind is
--- 10265,10271 ----
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! Constraint_Kind : Node_Kind) return Boolean
is
begin
case T_Kind is
*************** package body Sem_Ch3 is
*** 12003,12010 ****
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! Suffix : Character := ' ')
! return Entity_Id
is
P : Node_Id;
Def_Id : Entity_Id;
--- 11979,11985 ----
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! Suffix : Character := ' ') return Entity_Id
is
P : Node_Id;
Def_Id : Entity_Id;
Index: sem_ch3.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.ads,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 sem_ch3.ads
*** sem_ch3.ads 21 Oct 2003 13:42:19 -0000 1.7
--- sem_ch3.ads 24 Oct 2003 12:12:39 -0000
*************** package Sem_Ch3 is
*** 42,49 ****
function Access_Definition
(Related_Nod : Node_Id;
! N : Node_Id)
! return Entity_Id;
-- An access definition defines a general access type for a formal
-- parameter. The procedure is called when processing formals, when
-- the current scope is the subprogram. The Implicit type is attached
--- 42,48 ----
function Access_Definition
(Related_Nod : Node_Id;
! N : Node_Id) return Entity_Id;
-- An access definition defines a general access type for a formal
-- parameter. The procedure is called when processing formals, when
-- the current scope is the subprogram. The Implicit type is attached
*************** package Sem_Ch3 is
*** 129,138 ****
-- private type.
function Get_Discriminant_Value
! (Discriminant : Entity_Id;
! Typ_For_Constraint : Entity_Id;
! Constraint : Elist_Id)
! return Node_Id;
-- ??? MORE DOCUMENTATION
-- Given a discriminant somewhere in the Typ_For_Constraint tree
-- and a Constraint, return the value of that discriminant.
--- 128,136 ----
-- private type.
function Get_Discriminant_Value
! (Discriminant : Entity_Id;
! Typ_For_Constraint : Entity_Id;
! Constraint : Elist_Id) return Node_Id;
-- ??? MORE DOCUMENTATION
-- Given a discriminant somewhere in the Typ_For_Constraint tree
-- and a Constraint, return the value of that discriminant.
*************** package Sem_Ch3 is
*** 195,202 ****
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! Suffix : Character := ' ')
! return Entity_Id;
-- Process a subtype indication S and return corresponding entity.
-- Related_Nod is the node where the potential generated implicit types
-- will be inserted. The Related_Id and Suffix parameters are used to
--- 193,199 ----
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! Suffix : Character := ' ') return Entity_Id;
-- Process a subtype indication S and return corresponding entity.
-- Related_Nod is the node where the potential generated implicit types
-- will be inserted. The Related_Id and Suffix parameters are used to
Index: adadecode.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adadecode.h,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 adadecode.h
*** adadecode.h 24 Oct 2003 02:28:37 -0000 1.5
--- adadecode.h 24 Oct 2003 12:12:39 -0000
***************
*** 2,12 ****
* *
* GNAT COMPILER COMPONENTS *
* *
! * G N A T D E C O *
* *
* C Header File *
* *
! * Copyright (C) 2001-2002, 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- *
--- 2,12 ----
* *
* GNAT COMPILER COMPONENTS *
* *
! * A D A D E C O D E *
* *
* C Header File *
* *
! * Copyright (C) 2001-2003, 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- *
Index: atree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 atree.h
*** atree.h 24 Oct 2003 02:28:37 -0000 1.6
--- atree.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * Copyright (C) 1992-2001, 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * Copyright (C) 1992-2003, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
*************** struct Extended
*** 235,241 ****
Int field8;
Int field9;
Int field10;
! union
{
Int field11;
struct Flag_Word3 fw3;
--- 235,241 ----
Int field8;
Int field9;
Int field10;
! union
{
Int field11;
struct Flag_Word3 fw3;
Index: elists.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/elists.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 elists.h
*** elists.h 24 Oct 2003 02:28:37 -0000 1.6
--- elists.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * Copyright (C) 1992-2001 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * Copyright (C) 1992-2003 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- *
Index: nlists.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/nlists.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 nlists.h
*** nlists.h 24 Oct 2003 02:28:37 -0000 1.6
--- nlists.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * Copyright (C) 1992-2001, 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * Copyright (C) 1992-2003, 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- *
Index: raise.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/raise.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 raise.h
*** raise.h 24 Oct 2003 02:28:37 -0000 1.6
--- raise.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * Copyright (C) 1992-2002, 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * Copyright (C) 1992-2003, 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- *
^ permalink raw reply [flat|nested] 178+ messages in thread
end of thread, other threads:[~2004-09-13 10:23 UTC | newest]
Thread overview: 178+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2004-07-26 21:43 committed: Ada updates Arnaud Charlet
-- strict thread matches above, loose matches on Subject: below --
2004-09-13 11:24 Arnaud Charlet
2004-09-01 15:28 Richard Kenner
2004-09-01 15:38 ` Arnaud Charlet
2004-09-01 15:45 ` Andreas Schwab
2004-09-01 14:22 Richard Kenner
2004-09-01 14:57 ` Andreas Schwab
2004-09-01 13:32 Richard Kenner
2004-09-01 14:15 ` Andreas Schwab
2004-09-01 14:38 ` Arnaud Charlet
2004-09-01 14:49 ` Florian Weimer
2004-09-01 20:48 ` Florian Weimer
2004-09-01 16:08 ` Andreas Schwab
2004-09-01 12:05 Arnaud Charlet
2004-09-01 12:55 ` Florian Weimer
2004-09-01 12:59 ` Arnaud Charlet
2004-08-16 9:20 Arnaud Charlet
2004-08-13 10:44 Arnaud Charlet
2004-08-09 13:10 Arnaud Charlet
2004-07-20 18:29 Arnaud Charlet
2004-07-20 20:11 ` Duncan Sands
2004-07-20 20:12 ` Andrew Pinski
2004-07-20 20:21 ` Arnaud Charlet
2004-07-20 20:24 ` Duncan Sands
2004-07-16 2:57 Arnaud Charlet
2004-07-14 3:46 Arnaud Charlet
2004-07-06 14:10 Arnaud Charlet
2004-06-28 15:50 Arnaud Charlet
2004-06-25 18:29 Arnaud Charlet
2004-06-14 14:16 Arnaud Charlet
2004-06-11 13:38 Arnaud Charlet
2004-06-07 16:21 Arnaud Charlet
2004-05-27 18:16 Arnaud Charlet
2004-05-24 17:31 Arnaud Charlet
2004-05-19 16:00 Arnaud Charlet
2004-05-17 13:52 Arnaud Charlet
2004-05-17 14:06 ` Arnaud Charlet
2004-05-14 14:29 Arnaud Charlet
2004-05-10 17:17 Arnaud Charlet
2004-05-05 12:49 Arnaud Charlet
2004-05-03 12:46 Arnaud Charlet
2004-04-29 15:39 Arnaud Charlet
2004-04-27 11:21 Arnaud Charlet
2004-04-26 12:30 Arnaud Charlet
2004-04-23 10:59 Arnaud Charlet
2004-04-21 10:13 Arnaud Charlet
2004-04-19 15:23 Committed: " Arnaud Charlet
2004-04-08 18:25 committed: " Richard Kenner
2004-04-09 20:06 ` Richard Kenner
2004-04-08 18:08 Richard Kenner
2004-04-08 18:13 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
2004-04-08 18:06 Richard Kenner
2004-04-08 18:17 ` Laurent GUERBY
2004-04-08 18:57 ` Richard Henderson
2004-04-09 20:06 ` Richard Henderson
2004-04-09 20:06 ` Laurent GUERBY
2004-04-09 20:06 ` Richard Kenner
2004-04-08 17:40 Richard Kenner
2004-04-08 18:00 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
2004-04-08 16:09 Richard Kenner
2004-04-08 16:39 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
2004-04-08 16:05 Richard Kenner
2004-04-09 20:06 ` Richard Kenner
2004-04-08 15:47 Richard Kenner
2004-04-08 15:53 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
2004-04-08 15:28 Richard Kenner
2004-04-09 20:06 ` Richard Kenner
2004-04-08 15:25 Richard Kenner
2004-04-08 15:42 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Richard Kenner
2004-04-08 15:15 Richard Kenner
2004-04-08 15:24 ` Diego Novillo
2004-04-09 20:06 ` Diego Novillo
2004-04-08 17:54 ` Richard Henderson
2004-04-09 20:06 ` Richard Henderson
2004-04-09 20:06 ` Richard Kenner
2004-04-08 13:34 Arnaud Charlet
2004-04-08 13:59 ` Diego Novillo
2004-04-08 15:03 ` Arnaud Charlet
2004-04-08 15:13 ` Diego Novillo
2004-04-08 15:17 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Arnaud Charlet
2004-04-09 20:06 ` Diego Novillo
2004-04-09 20:06 ` Arnaud Charlet
2004-04-06 14:21 Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
2004-04-05 14:58 Arnaud Charlet
2004-04-06 14:21 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
2004-04-01 10:06 Arnaud Charlet
2004-04-06 14:21 ` Arnaud Charlet
2004-04-09 20:06 ` Arnaud Charlet
2004-03-29 12:03 Arnaud Charlet
2004-03-25 16:00 Arnaud Charlet
2004-03-22 14:07 Arnaud Charlet
2004-03-19 16:13 Arnaud Charlet
2004-03-18 15:19 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
2004-03-15 14:55 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
2004-03-05 10:59 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
2004-03-02 13:53 Arnaud Charlet
2004-03-19 8:14 ` Arnaud Charlet
2004-02-25 17:27 Arnaud Charlet
2004-02-21 1:21 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
2004-02-18 12:47 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
2004-02-12 14:44 Arnaud Charlet
2004-02-17 23:04 ` Rainer Orth
2004-02-18 11:56 ` Arnaud Charlet
2004-02-18 18:36 ` Zack Weinberg
2004-02-18 18:37 ` Rainer Orth
2004-02-18 19:41 ` Zack Weinberg
2004-02-18 19:42 ` Rainer Orth
2004-02-21 13:45 ` Rainer Orth
2004-02-19 14:44 ` Rainer Orth
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Zack Weinberg
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Zack Weinberg
2004-02-19 14:57 ` Rainer Orth
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Arnaud Charlet
2004-02-21 13:45 ` Rainer Orth
2004-02-21 13:45 ` Arnaud Charlet
2004-02-09 12:31 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
2004-02-04 11:07 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
2004-02-02 12:36 Arnaud Charlet
2004-02-21 13:45 ` Arnaud Charlet
2004-01-26 15:03 Arnaud Charlet
2004-01-23 10:40 Arnaud Charlet
2004-01-23 19:18 ` Laurent GUERBY
2004-01-21 10:41 Arnaud Charlet
2004-01-19 10:43 Arnaud Charlet
2004-01-19 10:49 ` Gerald Pfeifer
2004-01-19 12:59 ` Andreas Schwab
2004-01-15 17:24 Arnaud Charlet
2004-01-16 8:53 ` Andreas Jaeger
2004-01-16 9:38 ` Arnaud Charlet
2004-01-13 11:52 Arnaud Charlet
2004-01-12 11:52 Arnaud Charlet
2004-01-05 15:24 Arnaud Charlet
2003-12-17 14:17 Arnaud Charlet
2003-12-15 11:51 Arnaud Charlet
2003-12-11 16:22 Arnaud Charlet
2003-12-08 10:34 Arnaud Charlet
2003-12-05 10:25 Arnaud Charlet
2003-12-03 11:49 Arnaud Charlet
2003-12-01 13:30 Arnaud Charlet
2003-11-27 13:11 Arnaud Charlet
2003-11-24 15:19 Arnaud Charlet
2003-11-21 11:12 Arnaud Charlet
2003-11-20 10:28 Arnaud Charlet
2003-11-18 10:29 Arnaud Charlet
2003-11-17 15:16 Arnaud Charlet
2003-11-14 10:40 Arnaud Charlet
2003-11-04 12:59 Arnaud Charlet
2003-10-30 11:54 committed: ada updates Arnaud Charlet
2003-10-29 12:25 Arnaud Charlet
2003-10-30 16:14 ` Joseph S. Myers
2003-10-27 14:56 Arnaud Charlet
2003-10-24 14:46 Arnaud Charlet
2003-10-24 13:22 Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).