diff options
106 files changed, 3683 insertions, 1717 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f829316f405..da33d279e46 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,207 @@ +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). + 2004-05-27 Vincent Celier <celier@gnat.com> * vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index bf691bb3aa2..9c54bd4967a 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -557,6 +557,9 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-tratas.adb<s-tratas-default.adb \ s-tfsetr.adb<s-tfsetr-vxworks.adb endif + + EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o + EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o endif ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) @@ -1145,17 +1148,18 @@ endif ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),) ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),) LIBGNAT_TARGET_PAIRS_AUX1 = \ - s-auxdec.ads<5qauxdec.ads \ + s-auxdec.ads<s-auxdec-vms_64.ads \ s-crtl.ads<s-crtl-vms.ads \ s-osinte.adb<s-osinte-vms-ia64.adb \ s-osinte.ads<s-osinte-vms-ia64.ads \ - system.ads<5qsystem.ads + system.ads<system-vms_64.ads else ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),) LIBGNAT_TARGET_PAIRS_AUX1 = \ s-crtl.ads<s-crtl-vms.ads \ s-osinte.adb<s-osinte-vms.adb \ s-osinte.ads<s-osinte-vms.ads \ + s-vaflop.adb<s-vaflop-vms-alpha.adb \ system.ads<system-vms-zcx.ads endif endif @@ -1197,11 +1201,18 @@ endif s-tpopde.ads<s-tpopde-vms.ads \ s-traent.adb<s-traent-vms.adb \ s-traent.ads<s-traent-vms.ads \ - s-vaflop.adb<s-vaflop-vms.adb \ $(LIBGNAT_TARGET_PAIRS_AUX1) \ $(LIBGNAT_TARGET_PAIRS_AUX2) - TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vms.adb +ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),) + TOOLS_TARGET_PAIRS= \ + mlib-tgt.adb<mlib-tgt-vms-ia64.adb \ + symbols.adb<symbols-vms-ia64.adb +else + TOOLS_TARGET_PAIRS= \ + mlib-tgt.adb<mlib-tgt-vms-alpha.adb \ + symbols.adb<symbols-vms-alpha.adb +endif GNATLIB_SHARED=gnatlib-shared-vms ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),) diff --git a/gcc/ada/a-calend.ads b/gcc/ada/a-calend.ads index 00d45321037..700b554bce0 100644 --- a/gcc/ada/a-calend.ads +++ b/gcc/ada/a-calend.ads @@ -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 -- @@ -67,8 +67,21 @@ package Ada.Calendar is (Year : Year_Number; Month : Month_Number; Day : Day_Number; - Seconds : Day_Duration := 0.0) - return Time; + Seconds : Day_Duration := 0.0) return Time; + -- GNAT Note: Normally when procedure Split is called on a Time value + -- result of a call to function Time_Of, the out parameters of procedure + -- Split are identical to the in parameters of function Time_Of. However, + -- when a non-existent time of day is specified, the values for Seconds + -- may or may not be different. This may happen when Daylight Saving Time + -- (DST) is in effect, on the day when switching to DST, if Seconds + -- specifies a time of day in the hour that does not exist. For example, + -- in New York: + -- + -- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0) + -- + -- will return a Time value T. If Split is called on T, the resulting + -- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being + -- a time that not exist). function "+" (Left : Time; Right : Duration) return Time; function "+" (Left : Duration; Right : Time) return Time; diff --git a/gcc/ada/a-direct.ads b/gcc/ada/a-direct.ads index b5ed79b3bee..d71e49357ed 100644 --- a/gcc/ada/a-direct.ads +++ b/gcc/ada/a-direct.ads @@ -1,5 +1,5 @@ ------------------------------------------------------------------------------ --- -- +-- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . D I R E C T O R I E S -- @@ -36,8 +36,8 @@ -- -- ------------------------------------------------------------------------------ --- Ada0Y: Implementation of Ada.Directories (AI95-00248). Note that this --- unit is available without -gnatX. That seems reasonable, since you only +-- Ada 2005: Implementation of Ada.Directories (AI95-00248). Note that this +-- unit is available without -gnat05. That seems reasonable, since you only -- get it if you explicitly ask for it. -- External files may be classified as directories, special files, or ordinary @@ -137,7 +137,7 @@ package Ada.Directories is -- all of its contents (possibly including other directories) are deleted. -- The exception Name_Error is propagated if the string given as Directory -- does not identify an existing directory. The exception Use_Error is - -- propagatedi f the external environment does not support the deletion of + -- propagated if the external environment does not support the deletion of -- the directory or some portion of its contents with the given name (in -- the absence of Name_Error). If Use_Error is propagated, it is -- unspecified if a portion of the contents of the directory are deleted. diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def index 33032f59851..719f15ec4be 100644 --- a/gcc/ada/ada-tree.def +++ b/gcc/ada/ada-tree.def @@ -94,8 +94,9 @@ DEFTREECODE (NULL_STMT, "null_stmt", 's', 0) DEFTREECODE (DECL_STMT, "decl_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) + statement tree, chained via TREE_CHAIN. BLOCK_STMT_BLOCK, if nonzero, + is the BLOCK node for these statements. */ +DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 2) /* 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 @@ -117,3 +118,6 @@ DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1) /* An "asm" statement. The operands are ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT, ASM_STMT_ORIG_OUT, ASM_STMT_INPUT, and ASM_STMT_CLOBBER. */ DEFTREECODE (ASM_STMT, "asm_stmt", 's', 5) + +/* An analog to the C "break" statement. */ +DEFTREECODE (BREAK_STMT, "break_stmt", 's', 0) diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index d2361a5d858..6ab348e9d20 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -300,6 +300,7 @@ struct lang_type GTY(()) #define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0) #define DECL_STMT_VAR(NODE) TREE_OPERAND_CHECK_CODE (NODE, DECL_STMT, 0) #define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0) +#define BLOCK_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 1) #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) diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index ea9cc28f09f..ec1670fc4da 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -2024,6 +2024,7 @@ package body Bindgen is procedure Gen_Output_File (Filename : String) is Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public; + Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP; begin -- Acquire settings for Interrupt_State pragmas @@ -2057,7 +2058,7 @@ package body Bindgen is -- Get the time stamp of the former bind for public version warning - if Is_Public_Version then + if Is_Public_Version or Is_GAP_Version then Record_Time_From_Last_Bind; end if; @@ -3096,7 +3097,7 @@ package body Bindgen is --------------------- procedure Set_Unit_Number (U : Unit_Id) is - Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First); + Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First); Unum : constant Nat := Nat (U) - Nat (Unit_Id'First); begin diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 713ea26306c..565cf534add 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2432,7 +2432,7 @@ package body Checks is if Has_Null_Exclusion and then not Is_Access_Type (Typ) then - Error_Msg_N ("(Ada 0Y) must be an access type", Related_Nod); + Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod); end if; end Check_Must_Be_Access; @@ -2450,7 +2450,7 @@ package body Checks is and then Can_Never_Be_Null (Typ) then Error_Msg_N - ("(Ada 0Y) already a null-excluding type", Related_Nod); + ("(Ada 2005) already a null-excluding type", Related_Nod); end if; end Check_Already_Null_Excluding_Type; @@ -2472,17 +2472,17 @@ package body Checks is case Msg_K is when Components => Error_Msg_N - ("(Ada 0Y) null-excluding components must be initialized", - Related_Nod); + ("(Ada 2005) null-excluding components must be " & + "initialized", Related_Nod); when Formals => Error_Msg_N - ("(Ada 0Y) null-excluding formals must be initialized", + ("(Ada 2005) null-excluding formals must be initialized", Related_Nod); when Objects => Error_Msg_N - ("(Ada 0Y) null-excluding objects must be initialized", + ("(Ada 2005) null-excluding objects must be initialized", Related_Nod); end case; end if; @@ -2502,17 +2502,17 @@ package body Checks is case Msg_K is when Components => Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding components", - Expr); + ("(Ada 2005) NULL not allowed in null-excluding " & + "components", Expr); when Formals => Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding formals", + ("(Ada 2005) NULL not allowed in null-excluding formals", Expr); when Objects => Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding objects", + ("(Ada 2005) NULL not allowed in null-excluding objects", Expr); end case; end if; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index dcb4606775d..2ec2c162d73 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -617,7 +617,7 @@ package Checks is -- will be raised if the value is not valid. procedure Null_Exclusion_Static_Checks (N : Node_Id); - -- Ada 0Y (AI-231): Check bad usages of the null-exclusion issue + -- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue procedure Remove_Checks (Expr : Node_Id); -- Remove all checks from Expr except those that are only executed diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index b7d1c90eb5c..61f2018270c 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1182,9 +1182,9 @@ package body CStand is Build_Exception (S_Tasking_Error); -- Numeric_Error is a normal exception in Ada 83, but in Ada 95 - -- it is a renaming of Constraint_Error + -- it is a renaming of Constraint_Error. Is this test too early??? - if Ada_83 then + if Ada_Version = Ada_83 then Build_Exception (S_Numeric_Error); else diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 806fd1a56ca..e38fcf05d43 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -1971,14 +1971,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_arr_type = TREE_TYPE (gnu_arr_type), gnu_str_name = concat_id_with_name (gnu_str_name, "ST")) { + tree eltype = TREE_TYPE (gnu_arr_type); + TYPE_SIZE (gnu_arr_type) = elaborate_expression_1 (gnat_entity, gnat_entity, TYPE_SIZE (gnu_arr_type), gnu_str_name, definition, 0); + + /* ??? For now, store the size as a multiple of the + alignment of the element type in bytes so that we + can see the alignment from the tree. */ TYPE_SIZE_UNIT (gnu_arr_type) - = elaborate_expression_1 - (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type), - concat_id_with_name (gnu_str_name, "U"), definition, 0); + = build_binary_op + (MULT_EXPR, sizetype, + elaborate_expression_1 + (gnat_entity, gnat_entity, + build_binary_op (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (gnu_arr_type), + size_int (TYPE_ALIGN (eltype) + / BITS_PER_UNIT)), + concat_id_with_name (gnu_str_name, "A_U"), + definition, 0), + size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT)); } } diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 47685f64639..57f97329602 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1162,7 +1162,7 @@ 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). +-- Currently this flag is also used to implement Ada 2005 (AI-50217). -- It will be renamed to From_Limited_With after removal of the current -- GNAT with_type clause??? @@ -2396,7 +2396,7 @@ package Einfo is -- fide package with the limited-view list through the first_entity and -- first_private attributes. 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 (Ada0Y: AI-50217) +-- in a package appearing in a limited_with clause (Ada 2005: AI-50217) -- Lit_Indexes (Node15) -- Present in enumeration types and subtypes. Non-empty only for the @@ -2566,7 +2566,7 @@ package Einfo is -- Non_Limited_View (Node17) -- Present in incomplete types that are the shadow entities created --- when analyzing a limited_with_clause (Ada0Y: AI-50217). Points to +-- when analyzing a limited_with_clause (Ada 2005: AI-50217). Points to -- the defining entity in the original declaration. -- Nonzero_Is_True (Flag162) [base type only] diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index e307bb039be..5bf33115cdc 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -299,19 +299,24 @@ package Errout is Gname4 : aliased constant String := "gnatf"; Vname4 : aliased constant String := "REPORT_ERRORS=FULL"; + Gname5 : aliased constant String := "gnat05"; + Vname5 : aliased constant String := "05"; + type Cstring_Ptr is access constant String; Gnames : array (Nat range <>) of Cstring_Ptr := (Gname1'Access, Gname2'Access, Gname3'Access, - Gname4'Access); + Gname4'Access, + Gname5'Access); Vnames : array (Nat range <>) of Cstring_Ptr := (Vname1'Access, Vname2'Access, Vname3'Access, - Vname4'Access); + Vname4'Access, + Vname5'Access); ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 966b848931c..1eddfd30b29 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -74,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 (Ada 0Y: AI-287) + -- initialization (<>) in any component (Ada 2005: AI-287) ------------------------------------------------------ -- Local subprograms for Record Aggregate Expansion -- @@ -443,8 +443,8 @@ package body Exp_Aggr is -- -- Otherwise we call Build_Code recursively. -- - -- Ada 0Y (AI-287): In case of default initialized component, Expr is - -- empty and we generate a call to the corresponding IP subprogram. + -- Ada 2005 (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. @@ -671,7 +671,7 @@ package body Exp_Aggr is Res : List_Id; begin - -- Ada 0Y (AI-287): Do nothing else in case of default + -- Ada 2005 (AI-287): Do nothing else in case of default -- initialized component. if not Present (Expr) then @@ -739,7 +739,7 @@ package body Exp_Aggr is Set_Assignment_OK (Indexed_Comp); - -- Ada 0Y (AI-287): In case of default initialized component, Expr + -- Ada 2005 (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 @@ -758,7 +758,7 @@ package body Exp_Aggr is elsif Present (Next (First (New_Indices))) then - -- Ada 0Y (AI-287): Do nothing in case of default initialized + -- Ada 2005 (AI-287): Do nothing in case of default initialized -- component because we have received the component type in -- the formal parameter Ctype. @@ -792,7 +792,7 @@ package body Exp_Aggr is end if; end if; - -- Ada 0Y (AI-287): We only analyze the expression in case of non + -- Ada 2005 (AI-287): We only analyze the expression in case of non- -- default initialized components (otherwise Expr_Q is not present). if Present (Expr_Q) @@ -818,7 +818,7 @@ package body Exp_Aggr is end if; end if; - -- Ada 0Y (AI-287): In case of default initialized component, call + -- Ada 2005 (AI-287): In case of default initialized component, call -- the initialization subprogram associated with the component type. if not Present (Expr) then @@ -918,7 +918,7 @@ package body Exp_Aggr is if Empty_Range (L, H) then Append_To (S, Make_Null_Statement (Loc)); - -- Ada 0Y (AI-287): Nothing else need to be done in case of + -- Ada 2005 (AI-287): Nothing else need to be done in case of -- default initialized component. if not Present (Expr) then @@ -1337,7 +1337,7 @@ package body Exp_Aggr is if Present (Component_Associations (N)) then Assoc := Last (Component_Associations (N)); - -- Ada 0Y (AI-287) + -- Ada 2005 (AI-287) if Box_Present (Assoc) then Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), @@ -1632,8 +1632,8 @@ package body Exp_Aggr is Selector_Name => Make_Identifier (Loc, Name_uController)); Set_Assignment_OK (Ref); - -- Ada 0Y (AI-287): Give support to default initialization of limited - -- types and components. + -- Ada 2005 (AI-287): Give support to default initialization of + -- limited types and components. if (Nkind (Target) = N_Identifier and then Present (Etype (Target)) @@ -1790,7 +1790,7 @@ package body Exp_Aggr is Check_Ancestor_Discriminants (Entity (A)); end if; - -- Ada 0Y (AI-287): If the ancestor part is a limited type, + -- Ada 2005 (AI-287): If the ancestor part is a limited type, -- a recursive call expands the ancestor. elsif Is_Limited_Type (Etype (A)) then @@ -1924,15 +1924,15 @@ package body Exp_Aggr is while Present (Comp) loop Selector := Entity (First (Choices (Comp))); - -- Ada 0Y (AI-287): Default initialization of a limited component + -- Ada 2005 (AI-287): Default initialization of a limited component if Box_Present (Comp) and then Is_Limited_Type (Etype (Selector)) then - -- 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). + -- Ada 2005 (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 : constant Entity_Id := Etype (Selector); @@ -2868,7 +2868,7 @@ package body Exp_Aggr is -- Start of processing for Convert_To_Positional begin - -- Ada 0Y (AI-287): Do not convert in case of default initialized + -- Ada 2005 (AI-287): Do not convert in case of default initialized -- components because in this case will need to call the corresponding -- IP procedure. @@ -4120,7 +4120,7 @@ package body Exp_Aggr is if Has_Default_Init_Comps (N) then - -- Ada 0Y (AI-287): This case has not been analyzed??? + -- Ada 2005 (AI-287): This case has not been analyzed??? raise Program_Error; end if; @@ -4333,8 +4333,8 @@ package body Exp_Aggr is then Convert_To_Assignments (N, Typ); - -- Ada 0Y (AI-287): In case of default initialized components we convert - -- the aggregate into assignments. + -- Ada 2005 (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); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index c8a28aab6f2..335a07ccd15 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1107,7 +1107,7 @@ package body Exp_Ch3 is Append_To (Args, Make_Identifier (Loc, Name_uChain)); - -- Ada 0Y (AI-287): In case of default initialized components + -- Ada 2005 (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??? @@ -1215,8 +1215,8 @@ package body Exp_Ch3 is end if; end if; - -- Ada 0Y (AI-287) In case of default initialized components, we - -- need to generate the corresponding selected component node + -- Ada 2005 (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. @@ -1491,16 +1491,15 @@ package body Exp_Ch3 is Exp := New_Copy_Tree (Original_Node (Exp)); end if; - -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- Ada 2005 (AI-231): Generate conversion to the null-excluding -- type to force the corresponding run-time check - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Can_Never_Be_Null (Etype (Id)) -- Lhs - and then (Present (Etype (Exp)) - and then not Can_Never_Be_Null (Etype (Exp))) + and then Present (Etype (Exp)) + and then not Can_Never_Be_Null (Etype (Exp)) then - Rewrite (Exp, Convert_To (Etype (Id), - Relocate_Node (Exp))); + Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp))); Analyze_And_Resolve (Exp, Etype (Id)); end if; @@ -3436,15 +3435,16 @@ package body Exp_Ch3 is elsif Is_Access_Type (Typ) then - -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- Ada 2005 (AI-231): Generate conversion to the null-excluding -- type to force the corresponding run-time check - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Can_Never_Be_Null (Def_Id) - or else Can_Never_Be_Null (Typ)) + or else Can_Never_Be_Null (Typ)) then - Rewrite (Expr_Q, Convert_To (Etype (Def_Id), - Relocate_Node (Expr_Q))); + Rewrite + (Expr_Q, + Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q))); Analyze_And_Resolve (Expr_Q, Etype (Def_Id)); end if; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 7de6498a696..7fc124aeb9a 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -58,8 +58,7 @@ package Exp_Ch3 is 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; + 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 @@ -78,9 +77,9 @@ package Exp_Ch3 is -- 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. + -- Ada 2005 (AI-287): With_Default_Init is used to indicate that the + -- initialization 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 @@ -97,8 +96,7 @@ package Exp_Ch3 is function Get_Simple_Init_Val (T : Entity_Id; - Loc : Source_Ptr) - return Node_Id; + Loc : Source_Ptr) return Node_Id; -- For a type which Needs_Simple_Initialization (see above), prepares -- the tree for an expression representing the required initial value. -- Loc is the source location used in constructing this tree which is diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8703e27b27b..d59e0b942ac 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6354,9 +6354,18 @@ package body Exp_Ch4 is is Loc : constant Source_Ptr := Sloc (Nod); + Result : Node_Id; + C : Entity_Id; + + First_Time : Boolean := True; + function Suitable_Element (C : Entity_Id) return Entity_Id; -- Return the first field to compare beginning with C, skipping the - -- inherited components + -- inherited components. + + ---------------------- + -- Suitable_Element -- + ---------------------- function Suitable_Element (C : Entity_Id) return Entity_Id is begin @@ -6383,11 +6392,6 @@ package body Exp_Ch4 is end if; end Suitable_Element; - Result : Node_Id; - C : Entity_Id; - - First_Time : Boolean := True; - -- Start of processing for Expand_Record_Equality begin @@ -6430,7 +6434,6 @@ package body Exp_Ch4 is C := Suitable_Element (First_Entity (Typ)); while Present (C) loop - declare New_Lhs : Node_Id; New_Rhs : Node_Id; @@ -6440,7 +6443,6 @@ package body Exp_Ch4 is First_Time := False; New_Lhs := Lhs; New_Rhs := Rhs; - else New_Lhs := New_Copy_Tree (Lhs); New_Rhs := New_Copy_Tree (Rhs); @@ -6546,7 +6548,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Pool : constant Entity_Id := Associated_Storage_Pool (Typ); - Pnod : Node_Id := Parent (N); + Pnod : constant Node_Id := Parent (N); function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; -- Return true if type of P is derived from Checked_Pool; @@ -6580,40 +6582,12 @@ package body Exp_Ch4 is begin pragma Assert (Nkind (Pnod) = N_Explicit_Dereference); - -- Do not recursively add a dereference check for the - -- attribute references contained within the generated check. - - if not Comes_From_Source (Pnod) - and then Nkind (Pnod) = N_Explicit_Dereference - and then Nkind (Parent (Pnod)) = N_Attribute_Reference - and then (Attribute_Name (Parent (Pnod)) = Name_Size - or else Attribute_Name (Parent (Pnod)) = Name_Alignment) + if not (Is_Checked_Storage_Pool (Pool) + and then Comes_From_Source (Original_Node (Pnod))) then return; - - elsif not Is_Checked_Storage_Pool (Pool) then - return; end if; - -- Do not generate a dereference check for the object passed - -- to an init proc: such a check is not desired (we know for - -- sure that a valid dereference is passed to init procs, - -- and the calls to 'Size and 'Alignment containent in the - -- dereference check would be erroneous anyway if the init proc - -- has not been executed yet.) - - while Present (Pnod) loop - if Nkind (Pnod) = N_Procedure_Call_Statement - and then Is_Entity_Name (Name (Pnod)) - and then Is_Init_Proc (Name (Pnod)) - then - return; - end if; - - Pnod := Parent (Pnod); - exit when Nkind (Pnod) not in N_Subexpr; - end loop; - Insert_Action (N, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To ( diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4a08a28477b..43fcf3b8bb1 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -109,7 +109,7 @@ package body Exp_Ch5 is -- 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). + -- of Exp_Util.Component_May_Be_Bit_Aligned for further details). ------------------------------ -- Change_Of_Representation -- @@ -1537,13 +1537,13 @@ package body Exp_Ch5 is (Expression (Rhs), Designated_Type (Etype (Lhs))); end if; - -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- Ada 2005 (AI-231): Generate conversion to the null-excluding -- type to force the corresponding run-time check if Is_Access_Type (Typ) - and then ((Is_Entity_Name (Lhs) - and then Can_Never_Be_Null (Entity (Lhs))) - or else Can_Never_Be_Null (Etype (Lhs))) + and then + ((Is_Entity_Name (Lhs) and then Can_Never_Be_Null (Entity (Lhs))) + or else Can_Never_Be_Null (Etype (Lhs))) then Rewrite (Rhs, Convert_To (Etype (Lhs), Relocate_Node (Rhs))); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index b049710f922..67d18dde16a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1516,10 +1516,10 @@ package body Exp_Ch6 is elsif Convention (Subp) = Convention_Java then null; - -- Ada 0Y (AI-231): do not force the check in case of Ada 0Y unless - -- it is a null-excluding type + -- Ada 2005 (AI-231): do not force the check in case of Ada 2005 + -- unless it is a null-excluding type - elsif not Extensions_Allowed + elsif Ada_Version < Ada_05 or else Can_Never_Be_Null (Etype (Prev)) then Cond := diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index f661c13c0ee..d93ed9ba0dc 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1204,10 +1204,10 @@ package body Exp_Ch9 is begin S := Scope (E); - -- Ada 0Y (AI-287): Do not set/get the has_master_entity reminder in - -- internal scopes. Required for nested limited aggregates. + -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder + -- in internal scopes. Required for nested limited aggregates. - if Extensions_Allowed then + if Ada_Version >= Ada_05 then while Is_Internal (S) loop S := Scope (S); end loop; @@ -1240,13 +1240,13 @@ package body Exp_Ch9 is Insert_Before (P, Decl); Analyze (Decl); - -- Ada 0Y (AI-287): Set the has_master_entity reminder in the + -- Ada 2005 (AI-287): Set the has_master_entity reminder in the -- non-internal scope selected above. - if not Extensions_Allowed then - Set_Has_Master_Entity (Scope (E)); - else + if Ada_Version >= Ada_05 then Set_Has_Master_Entity (S); + else + Set_Has_Master_Entity (Scope (E)); end if; -- Now mark the containing scope as a task master diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 72060781470..c6065824e97 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -168,10 +168,11 @@ package Exp_Ch9 is (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. + -- Ada 2005 (AI-287): Similar to previous routine, but used to expand + -- allocated 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 diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb index 775a937dd81..022fc61a307 100644 --- a/gcc/ada/exp_code.adb +++ b/gcc/ada/exp_code.adb @@ -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- -- @@ -165,7 +165,8 @@ package body Exp_Code is -- are never static). if Is_OK_Static_Expression (Temp) - or else (Ada_83 and then Nkind (Temp) = N_String_Literal) + or else (Ada_Version = Ada_83 + and then Nkind (Temp) = N_String_Literal) then return Get_String_Node (Temp); diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index be3eee56af7..f2284d408e8 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -631,8 +631,7 @@ package body Exp_Dbug is -- Get_External_Name -- ----------------------- - procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) - is + procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is E : Entity_Id := Entity; Kind : Entity_Kind; diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index 9566e21c3d7..48963fbf40b 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -39,6 +39,14 @@ with System; use System; package body GNAT.OS_Lib is + OpenVMS : Boolean; + -- Note: OpenVMS should be a constant, but it cannot be, because it + -- prevents bootstrapping on some platforms. + + pragma Import (Ada, OpenVMS, "system__openvms"); + -- Needed to avoid doing useless checks when non on a VMS platform (see + -- Normalize_Pathname). + package SSL renames System.Soft_Links; -- The following are used by Create_Temp_File @@ -1661,12 +1669,10 @@ package body GNAT.OS_Lib is -- Resolving logical names from VMS. -- If we have a Unix path on VMS such as /temp/..., and TEMP is a -- logical name, we need to resolve this logical name. - -- As we have no means to know if we are on VMS, we need to do that - -- for absolute paths starting with '/'. -- We find the directory, change to it, get the current directory, -- and change the directory to this value. - if Path_Buffer (1) = '/' then + if OpenVMS and then Path_Buffer (1) = '/' then declare Cur_Dir : String := Get_Directory (""); -- Save the current directory, so that we can change dir back to diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads index 0bb3509b9ed..3ff38b0fa22 100644 --- a/gcc/ada/g-trasym.ads +++ b/gcc/ada/g-trasym.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- @@ -34,7 +34,7 @@ -- Run-time symbolic traceback support -- Note: this is only available on selected targets. Currently it is --- supported on Sparc/Solaris, GNU/Linux, Windows NT, HP-UX and Tru64. +-- supported on Sparc/Solaris, GNU/Linux, Windows NT, HP-UX, VMS and Tru64. -- The routines provided in this package assume that your application has -- been compiled with debugging information turned on, since this information @@ -46,12 +46,14 @@ -- need to be provided when launching the executable), and load then in -- memory, causing a significant cpu and memory overhead. --- 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. +-- 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. --- You should consider using off-line symbolic traceback instead, using --- addr2line or gdb. +-- 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 +-- VMS731_TRACE-V0100 must be applied in order to use this package. with Ada.Exceptions; use Ada.Exceptions; diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index ae1ba2ae3ee..b9c1d2c4cb8 100644 --- a/gcc/ada/gigi.h +++ b/gcc/ada/gigi.h @@ -383,9 +383,10 @@ extern int global_bindings_p (void); is in reverse order (it has to be so for back-end compatibility). */ extern tree getdecls (void); -/* Enter and exit a new binding level. */ +/* Enter and exit a new binding level. We return the BLOCK node, if any + when we exit a binding level. */ extern void gnat_pushlevel (void); -extern void gnat_poplevel (void); +extern tree gnat_poplevel (void); /* Insert BLOCK at the end of the list of subblocks of the current binding level. This is used when a BIND_EXPR is expanded, diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index a544e55534e..b51edf27c0e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -329,7 +329,7 @@ begin -- a junk spec as not needing a body when it really does). if Main_Kind = N_Package_Declaration - and then Ada_83 + and then Ada_Version = Ada_83 and then Operating_Mode = Generate_Code and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body and then not Compilation_Errors diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 300e9602128..82f64a92396 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -14413,8 +14413,12 @@ error message; no output file will be generated. If the compilation unit contained in the input source depends semantically upon units located outside the current directory, you have to provide the source search path -when invoking @command{gnatpp}; see the description of the @command{gnatpp} -switches below. +when invoking @command{gnatpp}, if these units are contained in files with +names that do not follow the GNAT file naming rules, you have to provide +the configuration file describing the corresponding naming scheme; +see the description of the @command{gnatpp} +switches below. Another possibility is to use a project file and to +call @command{gnatpp} through the @command{gnat} driver The @command{gnatpp} command has the form @@ -16306,10 +16310,11 @@ where @code{gnatclean} was invoked. @cindex Library, building, installing, using @noindent -This chapter addresses the issues related to building and using -libraries with GNAT. It also shows how the GNAT run-time library can be -recompiled. It is recommended that the user understands how to use the -@ref{GNAT Project Manager} facility before reading this chapter. +This chapter describes how to build and use +libraries with GNAT, and also shows how to recompile the GNAT run-time library. +You should be familiar with the +Project Manager facility (see @ref{GNAT Project Manager}) before reading this +chapter. @menu * Introduction to Libraries in GNAT:: @@ -16327,34 +16332,41 @@ own main thread of execution, but rather provides certain services to the applications that use it. A library can be either statically linked with the application, in which case its code is directly included in the application, or, on platforms that support it, be dynamically linked, in which case -its code is shared by all applications making use of this library. GNAT -supports both types of libraries. In the static case, the compiled code can -be provided in different ways. The simplest way is to provide directly the -set of objects produced by the compiler during the compilation of the library. -It is also possible to group the objects into an archive using whatever -commands are provided by the operating system. For the later case, the objects -are grouped into a shared library. +its code is shared by all applications making use of this library. + +GNAT supports both types of libraries. +In the static case, the compiled code can be provided in different ways. +The simplest approach is to provide directly the +set of objects resulting from compilation of the library source files. +Alternatively, you can group the objects into an archive using whatever +commands are provided by the operating system. For the latter case, +the objects are grouped into a shared library. In the GNAT environment, a library has two types of components: @itemize @bullet @item Source files. @item -Compiled code and Ali files. See @ref{The Ada Library Information Files}. +Compiled code and @file{ALI} files. +See @ref{The Ada Library Information Files}. @end itemize @noindent -GNAT libraries can either completely expose their source files to the -compilation context of the user's application, or alternatively only expose -a limited set of source files, called interface units, in which case they are -called @ref{Stand-alone Ada Libraries}. In addition, GNAT provides full support -for foreign libraries which are only available in the object format. +A GNAT library may either completely expose its source files to the +compilation context of the user's application. +Alternatively, it may expose +a limited subset of its source files, called @emph{interface units}, +in which case the library is referred to as a @emph{stand-alone library} +(see @ref{Stand-alone Ada Libraries}). In addition, GNAT fully supports +foreign libraries, which are only available in the object format. -Ada semantics requires that all compilation units comprising the application -are elaborated in the timely fashion. Where possible, GNAT provides facilities +All compilation units comprising +an application are elaborated, in an order partially defined by Ada language +semantics. +Where possible, GNAT provides facilities to ensure that compilation units of a library are automatically elaborated; however, there are cases where this must be responsibility of a user. This will -be addressed in greater detail further on. +be addressed in greater detail below. @node General Ada Libraries @section General Ada Libraries @@ -16369,56 +16381,56 @@ be addressed in greater detail further on. @subsection Building the library @noindent -The easiest way to build a library is to use the @ref{GNAT Project Manager}, -which supports a special type of projects called @ref{Library Projects}. +The easiest way to build a library is to use the Project Manager, +which supports a special type of projects called Library Projects +(see @ref{Library Projects}). A project is considered a library project, when two project-level attributes are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to control different aspects of library configuration, additional optional project-level attributes can be specified: -@itemize -@item @code{Library_Kind} +@table @code +@item Library_Kind This attribute controls whether the library is to be static or shared -@item @code{Library_Version} + +@item Library_Version This attribute specifies what is the library version; this value is used during dynamic linking of shared libraries to determine if the currently installed versions of the binaries are compatible. -@item @code{Library_Options}, @code{Library_GCC} + +@item Library_Options +@item Library_GCC These attributes specify additional low-level options to be used during library generation, and redefine the actual application used to generate library. -@end itemize +@end table @noindent -GNAT Project Manager takes full care of the library maintenance task, +The GNAT Project Manager takes full care of the library maintenance task, including recompilation of the source files for which objects do not exist or are not up to date, assembly of the library archive, and installation of -the library, i.e. the copy of associated source, object and ALI files to the -specific location. +the library, i.e. copying associated source, object and @file{ALI} files +to the specified location. -It is not entirely trivial to correctly do all the steps required to -produce a library. We recommend that you use @ref{GNAT Project Manager} +It is not entirely trivial to correctly perform all the steps required to +produce a library. We recommend that you use the GNAT Project Manager for this task. In special cases where this is not desired, the necessary steps are discussed below. There are various possibilities for compiling the units that make up the -library: for example with a Makefile @ref{Using the GNU make Utility}, +library: for example with a Makefile (see @ref{Using the GNU make Utility}) or with a conventional script. For simple libraries, it is also possible to create a dummy main program which depends upon all the packages that comprise the interface of the library. This dummy main program can then be given to -gnatmake, which will ensure that all necessary objects are built. +@command{gnatmake}, which will ensure that all necessary objects are built. -After this task is accomplished, the user should follow the standard procedure +After this task is accomplished, you should follow the standard procedure of the underlying operating system to produce the static or shared library. -Below is an example of such a dummy program and the generic commands used to -build an archive or a shared library. - +Here is an example of such a dummy program: @smallexample @c ada -@iftex -@leftskip=.7cm -@end iftex +@group with My_Lib.Service1; with My_Lib.Service2; with My_Lib.Service3; @@ -16426,8 +16438,12 @@ procedure My_Lib_Dummy is begin null; end; +@end group @end smallexample +@noindent +Here are the generic commands that will build an archive or a shared library. + @smallexample # compiling the library $ gnatmake -c my_lib_dummy.adb @@ -16449,13 +16465,12 @@ $ rm *.o # Make the ALI files read-only so that gnatmake will not try to # regenerate the objects that are in the library $ chmod -w *.ali - @end smallexample @noindent -Please note that the library must have a name of the form libxxx.a or -libxxx.so in order to be accessed by the directive -lxxx at link -time. +Please note that the library must have a name of the form @file{libxxx.a} or +@file{libxxx.so} in order to be accessed by the directive @option{-lxxx} +at link time. @node Installing the library @subsection Installing the library @@ -16464,16 +16479,16 @@ time. In the GNAT model, installing a library consists in copying into a specific location the files that make up this library. When the library is built using projects, it is automatically installed in the location specified in the -project by means of the attribute @code{Library_Dir}, otherwise it is -responsibility of the user. GNAT also supports installing the sources in a -different directory from the other files (ALI, objects, archives) since the -source path and the object path can be specified separately. - -For general purpose libraries, it is possible for the system -administrator to put those libraries in the default compiler paths. To -achieve this, he must specify their location in the configuration files -@file{ada_source_path} and @file{ada_object_path} that must be located in -the GNAT +project by means of the attribute @code{Library_Dir}, +otherwise the user must specify the destination. +GNAT also supports installing the sources in a +different directory from the other files (@file{ALI}, objects, archives) +since the source path and the object path can be specified separately. + +The system administrator can place general purpose libraries in the default +compiler paths, by specifying the libraries' location in the configuration +files @file{ada_source_path} and @file{ada_object_path}. +These configuration files must be located in the GNAT installation tree at the same place as the gcc spec file. The location of the gcc spec file can be determined as follows: @smallexample @@ -16481,29 +16496,30 @@ $ gcc -v @end smallexample @noindent -The configuration files mentioned above have simple format: each line in them -must contain one unique -directory name. Those names are added to the corresponding path +The configuration files mentioned above have a simple format: each line +must contain one unique directory name. +Those names are added to the corresponding path in their order of appearance in the file. The names can be either absolute -or relative, in the latter case, they are relative to where theses files +or relative; in the latter case, they are relative to where theses files are located. -@file{ada_source_path} and @file{ada_object_path} might actually not be +The files @file{ada_source_path} and @file{ada_object_path} might not be present in a GNAT installation, in which case, GNAT will look for its run-time library in -he directories @file{adainclude} for the sources and @file{adalib} for the -objects and @file{ALI} files. When the files exist, the compiler does not -look in @file{adainclude} and @file{adalib} at all, and thus the +the directories @file{adainclude} (for the sources) and @file{adalib} (for the +objects and @file{ALI} files). When the files exist, the compiler does not +look in @file{adainclude} and @file{adalib}, and thus the @file{ada_source_path} file must contain the location for the GNAT run-time sources (which can simply be @file{adainclude}). In the same way, the @file{ada_object_path} file must contain the location for the GNAT run-time objects (which can simply be @file{adalib}). -You can also specify a new default path to the runtime library at compilation -time with the switch @option{--RTS=rts-path}. You can easily choose and change -the runtime you want your program to be compiled with. This switch is -recognized by gcc, gnatmake, gnatbind, gnatls, gnatfind and gnatxref. +You can also specify a new default path to the run-time library at compilation +time with the switch @option{--RTS=rts-path}. You can thus choose / change +the run-time library you want your program to be compiled with. This switch is +recognized by @command{gcc}, @command{gnatmake}, @command{gnatbind}, +@command{gnatls}, @command{gnatfind} and @command{gnatxref}. It is possible to install a library before or after the standard GNAT library, by reordering the lines in the configuration files. In general, a @@ -16517,14 +16533,14 @@ any part of it. @noindent Once again, the project facility greatly simplifies the addition of libraries to the compilation. If the project file for an application lists a library -project in its @code{with} clause, the project manager will ensure that the -library files are consistent, and are considered during compilation and -linking of the main application. +project in its @code{with} clause, the Project Manager will ensure that the +library files are consistent, and that they are considered during the +compilation and linking of the application. -Even if you have a third-party, non-Ada library, you can still use GNAT -Project facility to provide a wrapper for it. The following project for -example, when "withed" in your main project, will link with the third-party -library liba.a: +Even if you have a third-party, non-Ada library, you can still use GNAT's +Project Manager facility to provide a wrapper for it. The following project for +example, when @code{with}ed in your main project, will link with the +third-party library @file{liba.a}: @smallexample @c projectfile @group @@ -16540,12 +16556,12 @@ end Liba; @noindent In order to use an Ada library manually, you need to make sure that this library is on both your source and object path -@ref{Search Paths and the Run-Time Library (RTL)} -and @ref{Search Paths for gnatbind}. Furthermore, when the objects are grouped -in an archive or a shared library, the user needs to specify the desired +(see @ref{Search Paths and the Run-Time Library (RTL)}, +and @ref{Search Paths for gnatbind}). Furthermore, when the objects are grouped +in an archive or a shared library, you need to specify the desired library at link time. -By means of example, you can use the library @file{mylib} installed in +For example, you can use the library @file{mylib} installed in @file{/dir/my_lib_src} and @file{/dir/my_lib_obj} with the following commands: @smallexample @@ -16554,10 +16570,11 @@ $ gnatmake -aI/dir/my_lib_src -aO/dir/my_lib_obj my_appl \ @end smallexample @noindent -This can be simplified down to the following: +This can be expressed more simply: @smallexample $ gnatmake my_appl @end smallexample +@noindent when the following conditions are met: @itemize @bullet @item @@ -16569,7 +16586,7 @@ variable @code{ADA_INCLUDE_PATH}, or by the administrator to the file variable @code{ADA_OBJECTS_PATH}, or by the administrator to the file @file{ada_object_path} @item -a pragma @code{Linker_Options}, has been added to one of the sources. +a pragma @code{Linker_Options} has been added to one of the sources. For example: @smallexample @c ada @@ -16583,50 +16600,55 @@ pragma Linker_Options ("-lmy_lib"); @cindex Stand-alone library, building, using @menu -* Introduction to Stand-Alone Libraries:: -* Building SAL:: -* Creating SAL to be used in a non-Ada context:: -* Restrictions in SALs:: +* Introduction to Stand-alone Libraries:: +* Building a Stand-alone Library:: +* Creating a Stand-alone Library to be used in a non-Ada context:: +* Restrictions in Stand-alone Libraries:: @end menu -@node Introduction to Stand-Alone Libraries -@subsection Introduction to Stand-Alone Libraries +@node Introduction to Stand-alone Libraries +@subsection Introduction to Stand-alone Libraries @noindent A Stand-alone Library (SAL) is a library that contains the necessary code to -elaborate the Ada units that are included in the library. Different from -ordinary libraries, which consist of all sources, objects and ALI files of the -library, the SAL creator can specify a restricted subset of compilation units -comprising SAL to serve as a library interface. In this case, the fully -self-sufficient set of files of such library will normally consist of objects -archive, sources of interface units specs, and ALI files of interface units. -Note that if interface specs contain generics or inlined subprograms, body +elaborate the Ada units that are included in the library. In contrast with +an ordinary library, which consists of all sources, objects and @file{ALI} +files of the +library, a SAL may specify a restricted subset of compilation units +to serve as a library interface. In this case, the fully +self-sufficient set of files will normally consist of an objects +archive, the sources of interface units' specs, and the @file{ALI} +files of interface units. +If an interface spec contains a generic unit or an inlined subprogram, +the body's source must also be provided; if the units that must be provided in the source -form depend on other units, the source and ALIs of those must also be provided. +form depend on other units, the source and @file{ALI} files of those must +also be provided. -The main purpose of SAL is to minimize the recompilation overhead of client -applications when the new version of the library is installed. Specifically, +The main purpose of a SAL is to minimize the recompilation overhead of client +applications when a new version of the library is installed. Specifically, if the interface sources have not changed, client applications do not need to -be recompiled. If, furthermore, SAL is provided in the shared form and its -version, controlled by @code{Library_Version} attribute, is not changed, the -clients don't need to be relinked, either. +be recompiled. If, furthermore, a SAL is provided in the shared form and its +version, controlled by @code{Library_Version} attribute, is not changed, +then the clients do not need to be relinked. -SALs also allow the library providers to minimize amount of library source -text exposed to the clients, which might be necessary for different reasons. +SALs also allow the library providers to minimize the amount of library source +text exposed to the clients. Such ``information hiding'' might be useful or +necessary for various reasons. -Stand-alone libraries are also well suited to be used in an executable which -main is not written in Ada. +Stand-alone libraries are also well suited to be used in an executable whose +main routine is not written in Ada. -@node Building SAL -@subsection Building SAL +@node Building a Stand-alone Library +@subsection Building a Stand-alone Library @noindent -GNAT Project facility provides a simple way of building and installing -stand-alone libraries, see @ref{Stand-alone Library Projects}. +GNAT's Project facility provides a simple way of building and installing +stand-alone libraries; see @ref{Stand-alone Library Projects}. To be a Stand-alone Library Project, in addition to the two attributes that make a project a Library Project (@code{Library_Name} and -@code{Library_Dir}, see @ref{Library Projects}), the attribute -@code{Library_Interface} must be defined. +@code{Library_Dir}; see @ref{Library Projects}), the attribute +@code{Library_Interface} must be defined. For example: @smallexample @c projectfile @group @@ -16636,21 +16658,25 @@ that make a project a Library Project (@code{Library_Name} and @end group @end smallexample +@noindent Attribute @code{Library_Interface} has a non empty string list value, each string in the list designating a unit contained in an immediate source of the project file. When a Stand-alone Library is built, first the binder is invoked to build a package whose name depends on the library name -(^b~dummy.ads/b^B$DUMMY.ADS/B^ in the example above). +(@file{^b~dummy.ads/b^B$DUMMY.ADS/B^} in the example above). This binder-generated package includes initialization and finalization procedures whose -names depend on the library name (dummyinit and dummyfinal in the example +names depend on the library name (@code{dummyinit} and @code{dummyfinal} +in the example above). The object corresponding to this package is included in the library. -The user must ensure timely (e.g. prior to any use of interfaces in the SAL) -calling of these procedures if static SAL is built, or shared SAL is built -with project-level attribute @code{Library_Auto_Init} set to "false". +You must ensure timely (e.g., prior to any use of interfaces in the SAL) +calling of these procedures if a static SAL is built, or if a shared SAL +is built +with the project-level attribute @code{Library_Auto_Init} set to +@code{"false"}. For a Stand-Alone Library, only the @file{ALI} files of the Interface Units (those that are listed in attribute @code{Library_Interface}) are copied to @@ -16658,60 +16684,65 @@ the Library Directory. As a consequence, only the Interface Units may be imported from Ada units outside of the library. If other units are imported, the binding phase will fail. -The attribute @code{Library_Src_Dir}, may be specified for a +The attribute @code{Library_Src_Dir} may be specified for a Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a single string value. Its value must be the path (absolute or relative to the project directory) of an existing directory. This directory cannot be the object directory or one of the source directories, but it can be the same as the library directory. The sources of the Interface -Units of the library, necessary to an Ada client of the library, will be -copied to the designated directory, called Interface Copy directory. +Units of the library that are needed by an Ada client of the library will be +copied to the designated directory, called the Interface Copy directory. These sources includes the specs of the Interface Units, but they may also include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always} -are used, or when there is a generic units in the spec. Before the sources +are used, or when there is a generic unit in the spec. Before the sources are copied to the Interface Copy directory, an attempt is made to delete all files in the Interface Copy directory. -Building stand-alone libraries by hand is difficult. Below are listed the steps -necessary to be done by the user: +Building stand-alone libraries by hand is somewhat tedious, but for those +occasions when it is necessary here are the steps that you need to perform: @itemize @bullet @item -compile all library sources +Compile all library sources. + @item -invoke the binder with the switch -n (No Ada main program), -with all the ALI files of the interfaces, and -with the switch -L to give specific names to the init and final -procedure. +Invoke the binder with the switch @option{-n} (No Ada main program), +with all the @file{ALI} files of the interfaces, and +with the switch @option{-L} to give specific names to the @code{init} +and @code{final} procedures. For example: @smallexample gnatbind -n int1.ali int2.ali -Lsal1 @end smallexample + @item -compile the binder generated file +Compile the binder generated file: @smallexample gcc -c b~int2.adb @end smallexample + @item -link the dynamic library with all the necessary object files, -indicating to the linker the names of the init (and possibly -final) procedures for automatic initialization (and finalization). -The built library should be put in a directory different from +Link the dynamic library with all the necessary object files, +indicating to the linker the names of the @code{init} (and possibly +@code{final}) procedures for automatic initialization (and finalization). +The built library should be placed in a directory different from the object directory. + @item -copy the ALI files of the interface to the library directory, -add in the copy the indication that it is an interface to a SAL -(i.e. add a word @option{SL} on the line in ALI file that starts -with letter P) and make the modified copy of the ALI file read-only. +Copy the @code{ALI} files of the interface to the library directory, +add in this copy an indication that it is an interface to a SAL +(i.e. add a word @option{SL} on the line in the @file{ALI} file that starts +with letter ``P'') and make the modified copy of the @file{ALI} file +read-only. @end itemize @noindent Using SALs is not different from using other libraries (see @ref{Using the library}). -@node Creating SAL to be used in a non-Ada context -@subsection Creating SAL to be used in a non-Ada context +@node Creating a Stand-alone Library to be used in a non-Ada context +@subsection Creating a Stand-alone Library to be used in a non-Ada context @noindent -It is easy to adapt SAL build procedure discussed above for use of SAL in +It is easy to adapt the SAL build procedure discussed above for use of a SAL in a non-Ada context. The only extra step required is to ensure that library interface subprograms @@ -16734,8 +16765,8 @@ end Interface; @noindent On the foreign language side, you must provide a ``foreign'' view of the -library interface; remeber that it should contain elaboration routines in -addition to interface subrporams. +library interface; remember that it should contain elaboration routines in +addition to interface subprograms. The example below shows the content of @code{mylib_interface.h} (note that there is no rule for the naming of this file, any name can be used) @@ -16758,7 +16789,7 @@ example) are called before the library services are used. Any number of libraries can be used simultaneously, as long as the elaboration procedure of each library is called. -Below is an example of C program that uses our @code{mylib} library. +Below is an example of C program that uses the @code{mylib} library. @smallexample #include "mylib_interface.h" @@ -16781,13 +16812,14 @@ main (void) @noindent Note that invoking any library finalization procedure generated by -@code{gnatbind} shuts down the Ada run time permanently. Consequently, the +@code{gnatbind} shuts down the Ada run-time environment. +Consequently, the finalization of all Ada libraries must be performed at the end of the program. -No call to these libraries nor the Ada run time should be made past the -finalization phase. +No call to these libraries nor to the Ada run-time library should be made +after the finalization phase. -@node Restrictions in SALs -@subsection Restrictions in SALs +@node Restrictions in Stand-alone Libraries +@subsection Restrictions in Stand-alone Libraries @noindent The pragmas listed below should be used with caution inside libraries, @@ -16798,21 +16830,23 @@ as they can create incompatibilities with other Ada libraries: @item pragma @code{Task_Dispatching_Policy} @item pragma @code{Unreserve_All_Interrupts} @end itemize + +@noindent When using a library that contains such pragmas, the user must make sure that all libraries use the same pragmas with the same values. Otherwise, -a @code{Program_Error} will +@code{Program_Error} will be raised during the elaboration of the conflicting libraries. The usage of these pragmas and its consequences for the user should therefore be well documented. -Similarly, the traceback in exception occurrences mechanism should be +Similarly, the traceback in the exception occurrence mechanism should be enabled or disabled in a consistent manner across all libraries. -Otherwise, a Program_Error will be raised during the elaboration of the +Otherwise, Program_Error will be raised during the elaboration of the conflicting libraries. -If the @code{'Version} and @code{'Body_Version} -attributes are used inside a library, then it is necessary to -perform a @code{gnatbind} step that mentions all @file{ALI} files in all +If the @code{Version} or @code{Body_Version} +attributes are used inside a library, then you need to +perform a @code{gnatbind} step that specifies all @file{ALI} files in all libraries, so that version identifiers can be properly computed. In practice these attributes are rarely used, so this is unlikely to be a consideration. @@ -21288,12 +21322,14 @@ compared to other native thread libraries: @noindent On AIX, the resolver library initializes some internal structure on the first call to @code{get*by*} functions, which are used to implement -@code{GNAT.Sockets.Get_Host_By_Name} and @code{GNAT.Sockets.Get_Host_By_Addrss}. +@code{GNAT.Sockets.Get_Host_By_Name} and +@code{GNAT.Sockets.Get_Host_By_Addrss}. If such initialization occurs within an Ada task, and the stack size for the task is the default size, a stack overflow may occur. To avoid this overflow, the user should either ensure that the first call -to @code{GNAT.Sockets.Get_Host_By_Name} or @code{GNAT.Sockets.Get_Host_By_Addrss} +to @code{GNAT.Sockets.Get_Host_By_Name} or +@code{GNAT.Sockets.Get_Host_By_Addrss} occurs in the environment task, or use @code{pragma Storage_Size} to specify a sufficiently large size for the stack of the task that contains this call. @@ -26682,7 +26718,8 @@ $ dll2def API.dll > API.def to standard output the list of entry points in the DLL. Note that if some routines in the DLL have the @code{Stdcall} convention (@pxref{Windows Calling Conventions}) with stripped @code{@@}@i{nn} -suffix then you'll have to edit @file{api.def} to add it. +suffix then you'll have to edit @file{api.def} to add it, and specify +@code{-k} to @code{gnatdll} when creating the import library. @noindent Here are some hints to find the right @code{@@}@i{nn} suffix. @@ -27182,10 +27219,11 @@ object files needed to build the DLL. @item -k @cindex @option{-k} (@code{gnatdll}) Removes the @code{@@}@i{nn} suffix from the import library's exported -names. You must specified this option if you want to use a -@code{Stdcall} function in a DLL for which the @code{@@}@i{nn} suffix -has been removed. This is the case for most of the Windows NT DLL for -example. This option has no effect when @option{-n} option is specified. +names, but keeps them for the link names. You must specify this +option if you want to use a @code{Stdcall} function in a DLL for which +the @code{@@}@i{nn} suffix has been removed. This is the case for most +of the Windows NT DLL for example. This option has no effect when +@option{-n} option is specified. @item -l @var{file} @cindex @option{-l} (@code{gnatdll}) diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 1747d25d307..0352d7c05cb 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -97,6 +97,7 @@ procedure GNATCmd is Gnatls_String : constant String_Access := new String'("gnatls"); Pretty_String : constant String_Access := new String'("pretty_printer"); Gnatstub_String : constant String_Access := new String'("gnatstub"); + Metric_String : constant String_Access := new String'("metrics"); Xref_String : constant String_Access := new String'("cross_reference"); Packages_To_Check_By_Binder : constant String_List_Access := @@ -120,6 +121,9 @@ procedure GNATCmd is Packages_To_Check_By_Gnatstub : constant String_List_Access := new String_List'((Naming_String, Gnatstub_String)); + Packages_To_Check_By_Metric : constant String_List_Access := + new String_List'((Naming_String, Metric_String)); + Packages_To_Check_By_Xref : constant String_List_Access := new String_List'((Naming_String, Xref_String)); @@ -151,8 +155,8 @@ procedure GNATCmd is function Configuration_Pragmas_File return Name_Id; -- Return an argument, if there is a configuration pragmas file to be -- specified for Project, otherwise return No_Name. - -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY) and gnatelim - -- (GNAT ELIM). + -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim + -- (GNAT ELIM), and gnatmetric (GNAT METRIC). procedure Delete_Temp_Config_Files; -- Delete all temporary config files @@ -416,7 +420,7 @@ procedure GNATCmd is end loop; New_Line; - Put_Line ("Commands FIND, LIST, PRETTY, STUB and XREF accept " & + Put_Line ("Commands FIND, LIST, PRETTY, STUB, NETRIC and XREF accept " & "project file switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; @@ -596,6 +600,7 @@ begin or else The_Command = Xref or else The_Command = Pretty or else The_Command = Stub + or else The_Command = Metric then case The_Command is when Bind => @@ -613,6 +618,9 @@ begin when List => Tool_Package_Name := Name_Gnatls; Packages_To_Check := Packages_To_Check_By_Gnatls; + when Metric => + Tool_Package_Name := Name_Metrics; + Packages_To_Check := Packages_To_Check_By_Metric; when Pretty => Tool_Package_Name := Name_Pretty_Printer; Packages_To_Check := Packages_To_Check_By_Pretty; @@ -825,9 +833,9 @@ begin -- Packages Binder (for gnatbind), Cross_Reference (for -- gnatxref), Linker (for gnatlink) Finder (for gnatfind), - -- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim) - -- have an attributed Switches, an associative array, indexed - -- by the name of the file. + -- Pretty_Printer (for gnatpp) Eliminate (for gnatelim) and + -- Metric (for gnatmetric) 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. @@ -901,10 +909,11 @@ begin Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False); - -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas - -- file, if necessary. + -- For gnatstub, gnatmetric, gnatpp and gnatelim, create + -- a configuration pragmas file, if necessary. if The_Command = Pretty + or else The_Command = Metric or else The_Command = Stub or else The_Command = Elim then @@ -1328,10 +1337,11 @@ begin end; end if; - -- For gnat pretty, if no file has been put on the command line, - -- call gnatpp with all the sources of the main project. + -- For gnat pretty and gnat metric, if no file has been put on the + -- command line, call the tool with all the sources of the main + -- project. - if The_Command = Pretty then + if The_Command = Pretty or else The_Command = Metric then declare Add_Sources : Boolean := True; Unit_Data : Prj.Com.Unit_Data; diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 3b2c5e84285..a00e185f5fc 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -45,7 +45,7 @@ package Gnatvsn is -- Static string identifying this version, that can be used as an argument -- to e.g. pragma Ident. - type Gnat_Build_Type is (FSF, Public); + type Gnat_Build_Type is (FSF, Public, GAP); -- See Get_Gnat_Build_Type below for the meaning of these values. function Get_Gnat_Build_Type return Gnat_Build_Type; @@ -63,6 +63,9 @@ package Gnatvsn is -- The binder will output informational messages, and the bug box -- generated by the package Comperr will give appropriate bug -- submission instructions. + -- + -- GAP + -- GNAT Academic Program, similar to Public. Ver_Len_Max : constant := 32; -- Longest possible length for Gnat_Version_String in this or any @@ -71,7 +74,7 @@ package Gnatvsn is -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. - Library_Version : constant String := "3.4"; + Library_Version : constant String := "3.5"; -- 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. @@ -82,7 +85,7 @@ package Gnatvsn is 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_Number : constant := 4; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees, and an ASIS application that is reading the -- trees. It must be updated (incremented) whenever a change is made to diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 03dcfe8cd73..59879f0a431 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -479,7 +479,7 @@ package body Lib.Load is -- legitimately occurs (e.g. two package bodies that contain -- inlined subprogram referenced by the other). - -- Ada0Y (AI-50217): We also ignore limited_with clauses, because + -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because -- their purpose is precisely to create legal circular structures. if Loading (Unum) diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index c4dd7668d48..df61c3f6154 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -220,7 +220,7 @@ package body Lib.Writ is Item := First (Context_Items (Cunit)); while Present (Item) loop - -- Ada0Y (AI-50217): limited with_clauses do not create + -- Ada 2005 (AI-50217): limited with_clauses do not create -- dependencies if Nkind (Item) = N_With_Clause @@ -673,7 +673,7 @@ package body Lib.Writ is -- a body or if a body is present in Ada 83 mode. if Body_Required (Cunit) - or else (Ada_83 + or else (Ada_Version = Ada_83 and then Full_Source_Name (Body_Fname) /= No_File) then Write_Info_Name (Body_Fname); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 1f271e89c21..eb8d72554f1 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -198,6 +198,63 @@ package body Lib.Xref is Def : Source_Ptr; Ent : Entity_Id; + function Is_On_LHS (Node : Node_Id) return Boolean; + -- Used to check if a node is on the left hand side of an + -- assignment. The following cases are handled: + -- + -- Variable Node is a direct descendant of an assignment + -- statement. + -- + -- Prefix Of an indexed or selected component that is + -- present in a subtree rooted by an assignment + -- statement. There is no restriction of nesting + -- of components, thus cases such as A.B(C).D are + -- handled properly. + + --------------- + -- Is_On_LHS -- + --------------- + + -- Couldn't we use Is_Lvalue or whatever it is called ??? + + function Is_On_LHS (Node : Node_Id) return Boolean is + N : Node_Id := Node; + + begin + -- Only identifiers are considered, is this necessary??? + + if Nkind (N) /= N_Identifier then + return False; + end if; + + -- Reach the assignment statement subtree root. In the + -- case of a variable being a direct descendant of an + -- assignment statement, the loop is skiped. + + while Nkind (Parent (N)) /= N_Assignment_Statement loop + + -- Check whether the parent is a component and the + -- current node is its prefix. + + if (Nkind (Parent (N)) = N_Selected_Component + or else + Nkind (Parent (N)) = N_Indexed_Component) + and then Prefix (Parent (N)) = N + then + N := Parent (N); + else + return False; + end if; + end loop; + + -- Parent (N) is an assignment statement, check whether + -- N is its name. + + return Name (Parent (N)) = N; + end Is_On_LHS; + + -- Start of processing for Generate_Reference + begin pragma Assert (Nkind (E) in N_Entity); @@ -243,11 +300,11 @@ package body Lib.Xref is -- For a variable that appears on the left side of an -- assignment statement, we set the Referenced_As_LHS -- flag since this is indeed a left hand side. + -- We also set the Referenced_As_LHS flag of a prefix + -- of selected or indexed component. if Ekind (E) = E_Variable - and then Nkind (Parent (N)) = N_Assignment_Statement - and then Name (Parent (N)) = N - and then No (Renamed_Object (E)) + and then Is_On_LHS (N) then Set_Referenced_As_LHS (E); diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index a881bc30d49..5204206d481 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -3130,6 +3130,15 @@ package body Makegpr is Get_Name_String (Source.Object_Name), True); + -- Add the switches specified in package Linker of + -- the main project. + + Add_Switches + (Data => Data, + Proc => Linker, + Language => Source.Language, + File_Name => Main_Id); + -- Add the switches specified in attribute -- Linker_Options of packages Linker. diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index b55d801388d..97dee952dc6 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -71,6 +71,9 @@ package body MLib.Prj is S_Dec_Ads : Name_Id := No_Name; -- Name_Id for "dec.ads" + G_Trasym_Ads : Name_Id := No_Name; + -- Name_Id for "g-trasym.ads" + No_Argument_List : aliased String_List := (1 .. 0 => null); No_Argument : constant String_List_Access := No_Argument_List'Access; @@ -308,6 +311,10 @@ package body MLib.Prj is Libdecgnat_Needed : Boolean := False; -- On OpenVMS, set to True if library needs to be linked with libdecgnat + Gtrasymobj_Needed : Boolean := False; + -- On OpenVMS, set to True if library needs to be linked with + -- g-trasym.obj. + Data : Project_Data := Projects.Table (For_Project); Object_Directory_Path : constant String := @@ -372,7 +379,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), and set + -- Gtrasymobj_Needed if there is a dependency on g-trasym.ads. procedure Process (The_ALI : File_Name_Type); -- Check if the closure of a library unit which is or should be in the @@ -506,7 +514,9 @@ package body MLib.Prj is begin if not Libgnarl_Needed or - (Hostparm.OpenVMS and then (not Libdecgnat_Needed)) + (Hostparm.OpenVMS and then + ((not Libdecgnat_Needed) or + (not Gtrasymobj_Needed))) then -- Scan the ALI file @@ -531,10 +541,13 @@ package body MLib.Prj is if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then Libgnarl_Needed := True; - elsif Hostparm.OpenVMS and then - ALI.Sdep.Table (Index).Sfile = S_Dec_Ads - then - Libdecgnat_Needed := True; + elsif Hostparm.OpenVMS then + if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then + Libdecgnat_Needed := True; + + elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then + Gtrasymobj_Needed := True; + end if; end if; end loop; end if; @@ -741,17 +754,23 @@ package body MLib.Prj is -- of "s-osinte.ads". if S_Osinte_Ads = No_Name then - Name_Len := 12; - Name_Buffer (1 .. Name_Len) := "s-osinte.ads"; + Name_Len := 0; + Add_Str_To_Name_Buffer ("s-osinte.ads"); S_Osinte_Ads := Name_Find; end if; if S_Dec_Ads = No_Name then - Name_Len := 7; - Name_Buffer (1 .. Name_Len) := "dec.ads"; + Name_Len := 0; + Add_Str_To_Name_Buffer ("dec.ads"); S_Dec_Ads := Name_Find; end if; + if G_Trasym_Ads = No_Name then + Name_Len := 0; + Add_Str_To_Name_Buffer ("g-trasym.ads"); + G_Trasym_Ads := Name_Find; + end if; + -- We work in the object directory Change_Dir (Object_Directory_Path); @@ -1193,8 +1212,8 @@ package body MLib.Prj is new String'(ALI_File); -- Find out if for this ALI file, - -- libgnarl or libdecgnat (on OpenVMS) - -- is necessary. + -- libgnarl or libdecgnat or g-trasym.obj + -- (on OpenVMS) is necessary. Check_Libs (ALI_File); @@ -1255,6 +1274,12 @@ package body MLib.Prj is end if; end if; + if Gtrasymobj_Needed then + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'(Lib_Directory & "/g-trasym.obj"); + end if; + if Libdecgnat_Needed then Opts.Increment_Last; Opts.Table (Opts.Last) := diff --git a/gcc/ada/mlib-tgt-vms.adb b/gcc/ada/mlib-tgt-vms-alpha.adb index 6db0dccb9dc..8637014a9c9 100644 --- a/gcc/ada/mlib-tgt-vms.adb +++ b/gcc/ada/mlib-tgt-vms-alpha.adb @@ -3,7 +3,7 @@ -- GNAT COMPILER COMPONENTS -- -- -- -- M L I B . T G T -- --- (VMS Version) -- +-- (Alpha VMS Version) -- -- -- -- B o d y -- -- -- @@ -25,7 +25,7 @@ -- -- ------------------------------------------------------------------------------ --- This is the VMS version of the body +-- This is the Alpha VMS version of the body with Ada.Characters.Handling; use Ada.Characters.Handling; diff --git a/gcc/ada/mlib-tgt-vms-ia64.adb b/gcc/ada/mlib-tgt-vms-ia64.adb new file mode 100644 index 00000000000..7d868d0b327 --- /dev/null +++ b/gcc/ada/mlib-tgt-vms-ia64.adb @@ -0,0 +1,736 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (Integrity VMS Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Integrity VMS version of the body + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Prj.Com; +with System; use System; +with System.Case_Util; use System.Case_Util; + +package body MLib.Tgt is + + use GNAT; + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; + -- The name of the command to invoke the macro-assembler + + VMS_Options : Argument_List := (1 .. 1 => null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + 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 -- + ------------------------------ + + function Popen (Command, Mode : System.Address) return System.Address; + pragma Import (C, Popen); + + function Pclose (File : System.Address) return Integer; + pragma Import (C, Pclose); + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "olb"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + 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 := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + 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 + -- 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 -- + ------------------ + + 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"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 1) = "b$" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + 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 + 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; + + -------------------- + -- 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; + Version : constant String := Version_String; + For_Linker_Opt : String_Access; + + -- 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; + + -- Option file must end with ".opt" + + 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 + Fail ("Options File """, Opt_File_Name, """ must end with .opt"); + end if; + + VMS_Options (VMS_Options'First) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name, " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "$init.asm"; + Macro_File : File_Descriptor; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + Len : Natural; + OK : Boolean := True; + + Command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the assembler on the generated auto-init + -- assembly file. + + Mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + -- Create and write the auto-init assembly file + + declare + First_Line : constant String := + ASCII.HT & + ".type " & Init_Proc & "#, @function" & + ASCII.LF; + Second_Line : constant String := + ASCII.HT & + ".global " & Init_Proc & "#" & + ASCII.LF; + Third_Line : constant String := + ASCII.HT & + ".global LIB$INITIALIZE#" & + ASCII.LF; + Fourth_Line : constant String := + ASCII.HT & + ".section LIB$INITIALIZE#,""a"",@progbits" & + ASCII.LF; + Fifth_Line : constant String := + ASCII.HT & + "data4 @fptr(" & Init_Proc & "#)" & + ASCII.LF; + + begin + Macro_File := Create_File (Macro_File_Name, Text); + OK := Macro_File /= Invalid_FD; + + if OK then + Len := Write + (Macro_File, First_Line (First_Line'First)'Address, + First_Line'Length); + OK := Len = First_Line'Length; + end if; + + if OK then + Len := Write + (Macro_File, Second_Line (Second_Line'First)'Address, + Second_Line'Length); + OK := Len = Second_Line'Length; + end if; + + if OK then + Len := Write + (Macro_File, Third_Line (Third_Line'First)'Address, + Third_Line'Length); + OK := Len = Third_Line'Length; + end if; + + if OK then + Len := Write + (Macro_File, Fourth_Line (Fourth_Line'First)'Address, + Fourth_Line'Length); + OK := Len = Fourth_Line'Length; + end if; + + if OK then + Len := Write + (Macro_File, Fifth_Line (Fifth_Line'First)'Address, + Fifth_Line'Length); + OK := Len = Fifth_Line'Length; + end if; + + if OK then + Close (Macro_File, OK); + end if; + + if not OK then + Fail ("creation of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := Popen (Command (Command'First)'Address, + Mode (Mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := Pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "$init.obj")); + end; + end if; + + -- 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 + 8); + + 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 + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """, + Lib_Filename, """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Link_With_Shared_Libgcc.all & + Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "$init.obj"; + Disregard : Boolean; + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "exe"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".obj"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".olb" or else Ext = ".exe"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + Libgnat_A : constant String := "libgnat.a"; + Libgnat_Olb : constant String := "libgnat.olb"; + + begin + Name_Len := Libgnat_A'Length; + Name_Buffer (1 .. Name_Len) := Libgnat_A; + + if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then + return Libgnat_A; + + else + return Libgnat_Olb; + end if; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "obj"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index be1eca67bcd..69798078f92 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -49,7 +49,7 @@ package body Opt is procedure Register_Opt_Config_Switches is begin - Ada_83_Config := Ada_83; + Ada_Version_Config := Ada_Version; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; Extensions_Allowed_Config := Extensions_Allowed; @@ -65,8 +65,7 @@ package body Opt is procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type) is begin - Ada_83 := Save.Ada_83; - Ada_95 := not Ada_83; + Ada_Version := Save.Ada_Version; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; Extensions_Allowed := Save.Extensions_Allowed; @@ -82,7 +81,7 @@ package body Opt is procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type) is begin - Save.Ada_83 := Ada_83; + Save.Ada_Version := Ada_Version; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; Save.Extensions_Allowed := Extensions_Allowed; @@ -99,8 +98,7 @@ package body Opt is procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is begin if Internal_Unit then - Ada_83 := False; - Ada_95 := True; + Ada_Version := Ada_Version_Default; Dynamic_Elaboration_Checks := False; Extensions_Allowed := True; External_Name_Exp_Casing := As_Is; @@ -108,8 +106,7 @@ package body Opt is Use_VADS_Size := False; else - Ada_83 := Ada_83_Config; - Ada_95 := not Ada_83_Config; + Ada_Version := Ada_Version_Config; Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; Extensions_Allowed := Extensions_Allowed_Config; External_Name_Exp_Casing := External_Name_Exp_Casing_Config; @@ -127,6 +124,7 @@ package body Opt is procedure Tree_Read is Tree_Version_String_Len : Nat; + Ada_Version_Config_Val : Nat; begin Tree_Read_Int (Tree_ASIS_Version_Number); @@ -139,12 +137,14 @@ package body Opt is Tree_Read_Bool (Verbose_Mode); Tree_Read_Data (Warning_Mode'Address, Warning_Mode_Type'Object_Size / Storage_Unit); - Tree_Read_Bool (Ada_83_Config); + Tree_Read_Int (Ada_Version_Config_Val); Tree_Read_Bool (All_Errors_Mode); Tree_Read_Bool (Assertions_Enabled); Tree_Read_Bool (Enable_Overflow_Checks); Tree_Read_Bool (Full_List); + Ada_Version_Config := Ada_Version_Type'Val (Ada_Version_Config_Val); + -- Read version string: we have to check the length first Tree_Read_Int (Tree_Version_String_Len); @@ -198,7 +198,7 @@ package body Opt is Tree_Write_Bool (Verbose_Mode); Tree_Write_Data (Warning_Mode'Address, Warning_Mode_Type'Object_Size / Storage_Unit); - Tree_Write_Bool (Ada_83_Config); + Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config)); Tree_Write_Bool (All_Errors_Mode); Tree_Write_Bool (Assertions_Enabled); Tree_Write_Bool (Enable_Overflow_Checks); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index eb34e50f3fc..0bd4336e53b 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -60,15 +60,17 @@ package Opt is -- GNATBIND, GNATLINK -- Set True if binder file to be generated in Ada rather than C - Ada_95 : Boolean := True; + type Ada_Version_Type is (Ada_83, Ada_95, Ada_05); + -- Versions of Ada for Ada_Version below. Note that these are ordered, + -- so that tests like Ada_Version >= Ada_95 are legitimate and useful. + + Ada_Version_Default : Ada_Version_Type := Ada_95; -- GNAT - -- Set True if operating in Ada 95 mode - -- Set False if operating in Ada 83 mode + -- Default Ada version if no switch given - Ada_83 : Boolean := False; + Ada_Version : Ada_Version_Type := Ada_Version_Default; -- GNAT - -- Set True if operating in Ada 83 mode - -- Set False if operating in Ada 95 mode + -- Current Ada version for compiler Ada_Final_Suffix : constant String := "final"; Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix); @@ -369,7 +371,7 @@ package Opt is Extensions_Allowed : Boolean := False; -- GNAT -- Set to True by switch -gnatX if GNAT specific language extensions - -- are allowed. For example, "with type" is a GNAT extension. + -- are allowed. For example, "limited with" is a GNAT extension. type External_Casing_Type is ( As_Is, -- External names cased as they appear in the Ada source @@ -488,7 +490,7 @@ package Opt is -- 'p' PC (US, IBM page 437) -- '8' PC (European, IBM page 850) -- 'f' Full upper set (all distinct) - -- 'n' No upper characters (Ada/83 rules) + -- 'n' No upper characters (Ada 83 rules) -- 'w' Latin-1 plus wide characters allowed in identifiers -- -- The setting affects the set of letters allowed in identifiers and the @@ -1090,15 +1092,15 @@ package Opt is -- command line switches, or by the use of appropriate configuration -- pragmas in the gnat.adc file. - Ada_83_Config : Boolean; + Ada_Version_Config : Ada_Version_Type; -- GNAT - -- This is the value of the configuration switch for Ada 83 mode, as set - -- by the command line switch -gnat83, and possibly modified by the use - -- of configuration pragmas Ada_95 and Ada_83 in the gnat.adc file. This - -- switch is used to set the initial value for Ada_83 mode at the start + -- This is the value of the configuration switch for the Ada 83 mode, as + -- set by the command line switches -gnat83/95/05, and possibly modified + -- by the use of configuration pragmas Ada_83/Ada95/Ada05. This switch + -- is used to set the initial value for Ada_Version mode at the start -- of analysis of a unit. Note however, that the setting of this flag -- is ignored for internal and predefined units (which are always compiled - -- in Ada 95 mode). + -- in the most up to date version of Ada). Dynamic_Elaboration_Checks_Config : Boolean := False; -- GNAT @@ -1230,7 +1232,7 @@ package Opt is private type Config_Switches_Type is record - Ada_83 : Boolean; + Ada_Version : Ada_Version_Type; Dynamic_Elaboration_Checks : Boolean; Exception_Locations_Suppressed : Boolean; Extensions_Allowed : Boolean; diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index d776635a778..50fa7e50cb4 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -514,7 +514,7 @@ package body Ch10 is Unit_Node := Specification (Unit_Node); elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_N ("(Ada 83) library unit renaming not allowed", Unit_Node); end if; @@ -608,7 +608,7 @@ package body Ch10 is -- Ada 83 error checks - if Ada_83 then + if Ada_Version = Ada_83 then -- Check we did not with any child units @@ -763,7 +763,7 @@ package body Ch10 is -- WITH_CLAUSE ::= -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME}; - -- Note: the two qualifiers are ADA0Y extensions. + -- Note: the two qualifiers are Ada 2005 extensions. -- WITH_TYPE_CLAUSE ::= -- with type type_NAME is access; | with type type_NAME is tagged; @@ -799,7 +799,7 @@ package body Ch10 is -- Processing for WITH clause - -- Ada0Y (AI-50217, AI-262): First check for LIMITED WITH, + -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH, -- PRIVATE WITH, or both. if Token = Tok_Limited then @@ -818,11 +818,10 @@ package body Ch10 is Error_Msg_SC ("unexpected LIMITED ignored"); end if; - if not Extensions_Allowed then - Error_Msg_SP ("`LIMITED WITH` is an Ada0X extension"); + if Ada_Version < Ada_05 then + Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension"); Error_Msg_SP - ("\unit must be compiled with -gnatX switch"); - + ("\unit must be compiled with -gnat05 switch"); end if; elsif Token = Tok_Private then @@ -838,10 +837,10 @@ package body Ch10 is Restore_Scan_State (Scan_State); -- to PRIVATE return Item_List; - elsif not Extensions_Allowed then - Error_Msg_SP ("`PRIVATE WITH` is an Ada0X extension"); + elsif Ada_Version < Ada_05 then + Error_Msg_SP ("PRIVATE WITH is an Ada 2005 extension"); Error_Msg_SP - ("\unit must be compiled with -gnatX switch"); + ("\unit must be compiled with -gnat05 switch"); end if; else @@ -854,10 +853,10 @@ package body Ch10 is if Token = Tok_Type then - -- WITH TYPE is an extension + -- WITH TYPE is an GNAT specific extension if not Extensions_Allowed then - Error_Msg_SP ("`WITH TYPE` is a non-standard extension"); + Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension"); Error_Msg_SP ("\unit must be compiled with -gnatX switch"); end if; diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 57f3c5db3b3..5968b72f4fc 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -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- -- @@ -104,7 +104,7 @@ package body Ch11 is Scan; -- past identifier if Token = Tok_Colon then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SP ("(Ada 83) choice parameter not allowed!"); end if; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index dad0101e46a..440f6468637 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -388,7 +388,7 @@ package body Ch3 is case Token is when Tok_Access | - Tok_Not => -- Ada 0Y (AI-231) + Tok_Not => -- Ada 2005 (AI-231) Typedef_Node := P_Access_Type_Definition; TF_Semicolon; exit; @@ -564,7 +564,7 @@ package body Ch3 is -- LIMITED RECORD or LIMITED NULL RECORD if Token = Tok_Record or else Token = Tok_Null then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SP ("(Ada 83) limited record declaration not allowed!"); end if; @@ -741,7 +741,7 @@ package body Ch3 is Scan; -- past NEW end if; - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Subtype_Indication @@ -765,10 +765,10 @@ package body Ch3 is return False; else - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Error_Msg_SP - ("null-excluding access is an Ada 0Y extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + ("null-excluding access is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Scan; -- past NOT @@ -776,7 +776,7 @@ package body Ch3 is if Token = Tok_Null then Scan; -- past NULL else - Error_Msg_SP ("(Ada 0Y) missing NULL"); + Error_Msg_SP ("NULL expected"); end if; return True; @@ -826,7 +826,7 @@ package body Ch3 is return Subtype_Mark; else if Not_Null_Present then - Error_Msg_SP ("(Ada 0Y) constrained null-exclusion not allowed"); + Error_Msg_SP ("constrained null-exclusion not allowed"); end if; Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); @@ -1280,7 +1280,7 @@ package body Ch3 is if Present (Init_Expr) then if Not_Null_Present then - Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in " + Error_Msg_SP ("null-exclusion not allowed in " & "numeric expression"); end if; @@ -1309,7 +1309,7 @@ package body Ch3 is (Decl_Node, P_Array_Type_Definition); else - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Object_Definition (Decl_Node, @@ -1357,7 +1357,7 @@ package body Ch3 is (Decl_Node, P_Array_Type_Definition); else - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Object_Definition (Decl_Node, P_Subtype_Indication (Not_Null_Present)); @@ -1369,7 +1369,7 @@ 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-254) + -- Ada 2005 (AI-254) elsif Token = Tok_Not then @@ -1381,14 +1381,14 @@ package body Ch3 is -- ... -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME; - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) if Token = Tok_Access then - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Error_Msg_SP ("generalized use of anonymous access types " & - "is an Ada 0Y extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Acc_Node := P_Access_Definition (Not_Null_Present); @@ -1411,8 +1411,8 @@ package body Ch3 is -- Object renaming declaration if Token_Is_Renames then - Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in " - & "object renamings"); + Error_Msg_SP + ("null-exclusion not allowed in object renamings"); raise Error_Resync; -- Object declaration @@ -1437,14 +1437,14 @@ package body Ch3 is end if; end if; - -- Ada 0Y (AI-230): Access Definition case + -- Ada 2005 (AI-230): Access Definition case elsif Token = Tok_Access then - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Error_Msg_SP ("generalized use of anonymous access types " & - "is an Ada 0Y extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Acc_Node := P_Access_Definition (Null_Exclusion_Present => False); @@ -1601,7 +1601,7 @@ package body Ch3 is Scan; end if; - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present); Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication (Not_Null_Present)); @@ -1915,7 +1915,7 @@ package body Ch3 is Typedef_Node : Node_Id; begin - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83): modular types not allowed"); end if; @@ -2044,7 +2044,7 @@ package body Ch3 is Check_Simple_Expression_In_Ada_83 (Delta_Node); if Token = Tok_Digits then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!"); end if; @@ -2246,16 +2246,16 @@ package body Ch3 is Scan; -- past ALIASED end if; - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231/AI-254) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) - -- Ada 0Y (AI-230): Access Definition case + -- Ada 2005 (AI-230): Access Definition case if Token = Tok_Access then - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Error_Msg_SP ("generalized use of anonymous access types " & - "is an Ada 0Y extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; if Aliased_Present then @@ -2415,7 +2415,7 @@ package body Ch3 is Scan; -- past the left paren if Token = Tok_Box then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); end if; @@ -2496,10 +2496,10 @@ package body Ch3 is Specification_Node := New_Node (N_Discriminant_Specification, Ident_Sloc); Set_Defining_Identifier (Specification_Node, Idents (Ident)); - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) if Token = Tok_Access then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access discriminant not allowed!"); end if; @@ -2512,7 +2512,7 @@ package body Ch3 is Set_Discriminant_Type (Specification_Node, P_Subtype_Mark); No_Constraint; - Set_Null_Exclusion_Present -- Ada 0Y (AI-231) + Set_Null_Exclusion_Present -- Ada 2005 (AI-231) (Specification_Node, Not_Null_Present); end if; @@ -2995,16 +2995,16 @@ package body Ch3 is Scan; -- past ALIASED end if; - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231/AI-254) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) - -- Ada 0Y (AI-230): Access Definition case + -- Ada 2005 (AI-230): Access Definition case if Token = Tok_Access then - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Error_Msg_SP - ("Generalized use of anonymous access types " & - "is an Ada 0Y extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; if Aliased_Present then @@ -3288,7 +3288,7 @@ package body Ch3 is -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK - -- Ada 0Y (AI-254): If Header_Already_Parsed then the caller has already + -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already -- parsed the null_exclusion part and has also removed the ACCESS token; -- otherwise the caller has just checked that the initial token is ACCESS @@ -3327,7 +3327,7 @@ package body Ch3 is begin if not Header_Already_Parsed then - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Scan; -- past ACCESS end if; @@ -3347,7 +3347,7 @@ package body Ch3 is end if; if Token = Tok_Procedure then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); end if; @@ -3359,7 +3359,7 @@ package body Ch3 is Set_Protected_Present (Type_Def_Node, Prot_Flag); elsif Token = Tok_Function then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access to function not allowed!"); end if; @@ -3379,7 +3379,7 @@ package body Ch3 is Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); if Token = Tok_All or else Token = Tok_Constant then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access modifier not allowed!"); end if; @@ -3445,11 +3445,11 @@ package body Ch3 is Def_Node := New_Node (N_Access_Definition, Token_Ptr); Scan; -- past ACCESS - -- Ada 0Y (AI-254/AI-231) + -- Ada 2005 (AI-254/AI-231) - if Extensions_Allowed then + if Ada_Version >= Ada_05 then - -- Ada 0Y (AI-254): Access_To_Subprogram_Definition + -- Ada 2005 (AI-254): Access_To_Subprogram_Definition if Token = Tok_Protected or else Token = Tok_Procedure @@ -3460,7 +3460,7 @@ package body Ch3 is Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present); Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node); - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK else @@ -3482,7 +3482,7 @@ package body Ch3 is -- Ada 95 else - -- Ada 0Y (AI-254): The null-exclusion present is never present + -- Ada 2005 (AI-254): The null-exclusion present is never present -- in Ada 83 and Ada 95 pragma Assert (Null_Exclusion_Present = False); diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 1e8e23f1e10..c35cac7c0ed 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1126,7 +1126,7 @@ 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) + -- to Ada 2005 limited aggregates (AI-287) function P_Aggregate_Or_Paren_Expr return Node_Id is Aggregate_Node : Node_Id; @@ -1165,14 +1165,14 @@ package body Ch4 is end if; end if; - -- Ada0Y (AI-287): The box notation is allowed only with named + -- Ada 2005 (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 " + if Ada_Version >= Ada_05 and then Token = Tok_Box then + Error_Msg_SC ("(Ada 2005) box notation only allowed with " & "named notation"); Scan; -- past BOX Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); @@ -1192,7 +1192,7 @@ package body Ch4 is return Error; end if; - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) extension aggregate not allowed"); end if; @@ -1389,7 +1389,7 @@ package body Ch4 is -- Error recovery: can raise Error_Resync -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION - -- rules have been extended to give support to Ada0Y limited + -- rules have been extended to give support to Ada 2005 limited -- aggregates (AI-287) function P_Record_Or_Array_Component_Association return Node_Id is @@ -1403,13 +1403,13 @@ package body Ch4 is if Token = Tok_Box then - -- Ada0Y (AI-287): The box notation is used to indicate the default - -- initialization of limited aggregate components + -- Ada 2005(AI-287): The box notation is used to indicate the + -- default initialization of limited aggregate components - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Error_Msg_SP - ("(Ada 0Y) limited aggregates are an Ada0X extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + ("limited aggregate is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Set_Box_Present (Assoc_Node); @@ -2335,7 +2335,7 @@ package body Ch4 is Alloc_Node := New_Node (N_Allocator, Token_Ptr); T_New; - -- Scan Null_Exclusion if present (Ada 0Y (AI-231)) + -- Scan Null_Exclusion if present (Ada 2005 (AI-231)) Null_Exclusion_Present := P_Null_Exclusion; Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present); diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index e45b0fafb59..8a19316112b 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1979,7 +1979,7 @@ package body Ch5 is -- Check for misplacement of later vs basic declarations in Ada 83 - if Ada_83 then + if Ada_Version = Ada_83 then Decl := First (Decls); -- Loop through sequence of basic declarative items @@ -2002,7 +2002,7 @@ package body Ch5 is if Nkind (Decl) not in N_Later_Decl_Item and then Nkind (Decl) /= N_Pragma then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_Sloc := Body_Sloc; Error_Msg_N ("(Ada 83) decl cannot appear after body#", Decl); diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 406545d4316..48af5bada8f 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -735,7 +735,7 @@ package body Ch6 is Error_Msg_SP ("child unit allowed only at library level"); raise Error_Resync; - elsif Ada_83 then + elsif Ada_Version = Ada_83 then Error_Msg_SP ("(Ada 83) child unit not allowed!"); end if; @@ -953,13 +953,13 @@ package body Ch6 is Specification_Node := New_Node (N_Parameter_Specification, Ident_Sloc); Set_Defining_Identifier (Specification_Node, Idents (Ident)); - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) if Token = Tok_Access then Set_Null_Exclusion_Present (Specification_Node, Not_Null_Present); - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access parameters not allowed"); end if; @@ -974,7 +974,7 @@ package body Ch6 is end if; P_Mode (Specification_Node); - Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) end if; Set_Null_Exclusion_Present diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb index 5b1cd0a8f6f..105937515d9 100644 --- a/gcc/ada/par-ch8.adb +++ b/gcc/ada/par-ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -110,7 +110,7 @@ package body Ch8 is Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr); Set_Subtype_Marks (Use_Node, New_List); - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) use type not allowed!"); end if; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 6bfc409acce..4c6da467634 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -770,7 +770,7 @@ package body Ch9 is -- Exception handlers not allowed in Ada 95 node if Present (Exception_Handlers (Hand_Seq)) then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_N ("(Ada 83) exception handlers in accept not allowed", First_Non_Pragma (Exception_Handlers (Hand_Seq))); @@ -1258,7 +1258,7 @@ package body Ch9 is -- Else error else - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_BC ("OR or ELSE expected"); else Error_Msg_BC ("OR or ELSE or THEN ABORT expected"); @@ -1578,7 +1578,7 @@ package body Ch9 is Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr); T_Abort; -- scan past ABORT - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_SP ("(Ada 83) asynchronous select not allowed!"); end if; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 941d7d256e0..0754319b8cc 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -241,24 +241,33 @@ begin ------------ -- This pragma must be processed at parse time, since we want to set - -- the Ada 83 and Ada 95 switches properly at parse time to recognize - -- Ada 83 syntax or Ada 95 syntax as appropriate. + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. when Pragma_Ada_83 => - Ada_83 := True; - Ada_95 := False; + Ada_Version := Ada_83; ------------ -- Ada_95 -- ------------ -- This pragma must be processed at parse time, since we want to set - -- the Ada 83 and Ada_95 switches properly at parse time to recognize - -- Ada 83 syntax or Ada 95 syntax as appropriate. + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. when Pragma_Ada_95 => - Ada_83 := False; - Ada_95 := True; + Ada_Version := Ada_95; + + ------------ + -- Ada_05 -- + ------------ + + -- This pragma must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. + + when Pragma_Ada_05 => + Ada_Version := Ada_05; ----------- -- Debug -- @@ -307,7 +316,14 @@ begin Check_Arg_Count (1); Check_No_Identifier (Arg1); Check_Arg_Is_On_Or_Off (Arg1); - Opt.Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On); + + if Chars (Expression (Arg1)) = Name_On then + Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + else + Extensions_Allowed := False; + Ada_Version := Ada_Version_Type'Min (Ada_Version, Ada_95); + end if; ---------------- -- List (2.8) -- diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index d23269ea88d..508877cafb6 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -195,7 +195,7 @@ package body Util is procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is begin if Expr_Form = EF_Non_Simple then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E); end if; end if; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 85a2fde13e2..23230235e35 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -576,12 +576,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Access_Definition (Null_Exclusion_Present : Boolean) return Node_Id; - -- Ada 0Y (AI-231/AI-254): The caller parses the null-exclusion part + -- Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part -- and indicates if it was present function P_Access_Type_Definition (Header_Already_Parsed : Boolean := False) return Node_Id; - -- Ada 0Y (AI-254): The formal is used to indicate if the caller has + -- Ada 2005 (AI-254): The formal is used to indicate if the caller has -- parsed the null_exclusion part. In this case the caller has also -- removed the ACCESS token @@ -597,12 +597,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- declaration of this type for details. function P_Null_Exclusion return Boolean; - -- Ada 0Y (AI-231): Parse the null-excluding part. True indicates + -- Ada 2005 (AI-231): Parse the null-excluding part. True indicates -- that the null-excluding part was present. function P_Subtype_Indication (Not_Null_Present : Boolean := False) return Node_Id; - -- Ada 0Y (AI-231): The flag Not_Null_Present indicates that the + -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the -- null-excluding part has been scanned out and it was present. function Init_Expr_Opt (P : Boolean := False) return Node_Id; @@ -624,7 +624,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is Not_Null_Present : Boolean := False) return Node_Id; -- This version of P_Subtype_Indication is called when the caller has -- already scanned out the subtype mark which is passed as a parameter. - -- Ada 0Y (AI-231): The flag Not_Null_Present indicates that the + -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the -- null-excluding part has been scanned out and it was present. function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index a0588bcb4e1..f473b6c8816 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -160,6 +160,12 @@ package body Prj.Attr is "Ladefault_switches#" & "Lbswitches#" & + -- package Metrics + + "Pmetrics#" & + "Ladefault_switches#" & + "Lbswitches#" & + -- package Ide "Pide#" & diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index f728d975d34..c710a2bd0af 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1281,7 +1281,7 @@ package body Prj.Nmsc is else Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value; - Get_Name_String (Lib_Symbol_File.Value); + Get_Name_String (Lib_Ref_Symbol_File.Value); if Name_Len = 0 then Error_Msg @@ -4717,6 +4717,7 @@ package body Prj.Nmsc is then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_Name := Name_Find; NL := Source_Names.Get (Canonical_Name); diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads new file mode 100644 index 00000000000..daf4b4682f2 --- /dev/null +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -0,0 +1,592 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- S p e c -- +-- -- +-- 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS For A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains definitions that are designed to be compatible +-- with the extra definitions in package System for DEC Ada implementations. + +-- These definitions can be used directly by withing this package, or merged +-- with System using pragma Extend_System (Aux_DEC) + +-- This is the IPF VMS 64 bit version. + +with Unchecked_Conversion; + +package System.Aux_DEC is +pragma Elaborate_Body (Aux_DEC); + + subtype Short_Address is Address + range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; + for Short_Address'Object_Size use 32; + -- This subtype allows addresses to be converted from 64 bits to 32 bits + -- with an appropriate range check. Note that since this is a subtype of + -- type System.Address, the same limitations apply to this subtype. Namely + -- there are no visible arithmetic operations, and integer literals are + -- not available. + + Short_Memory_Size : constant := 2 ** 32; + -- Defined for convenience of porting. + + type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; + for Integer_8'Size use 8; + + type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1; + for Integer_16'Size use 16; + + type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; + for Integer_32'Size use 32; + + type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1; + for Integer_64'Size use 64; + + type Largest_Integer is range Min_Int .. Max_Int; + + type AST_Handler is limited private; + + No_AST_Handler : constant AST_Handler; + + type Type_Class is + (Type_Class_Enumeration, + Type_Class_Integer, + Type_Class_Fixed_Point, + Type_Class_Floating_Point, + Type_Class_Array, + Type_Class_Record, + Type_Class_Access, + Type_Class_Task, -- also in Ada 95 protected + Type_Class_Address); + + function "not" (Left : Largest_Integer) return Largest_Integer; + function "and" (Left, Right : Largest_Integer) return Largest_Integer; + function "or" (Left, Right : Largest_Integer) return Largest_Integer; + function "xor" (Left, Right : Largest_Integer) return Largest_Integer; + + Address_Zero : constant Address; + No_Addr : constant Address; + Address_Size : constant := Standard'Address_Size; + + function "+" (Left : Address; Right : Integer) return Address; + function "+" (Left : Integer; Right : Address) return Address; + function "-" (Left : Address; Right : Address) return Integer; + function "-" (Left : Address; Right : Integer) return Address; + + generic + type Target is private; + function Fetch_From_Address (A : Address) return Target; + + generic + type Target is private; + procedure Assign_To_Address (A : Address; T : Target); + + -- Floating point type declarations for VAX floating point data types + + pragma Warnings (Off); + + type F_Float is digits 6; + pragma Float_Representation (VAX_Float, F_Float); + + type D_Float is digits 9; + pragma Float_Representation (Vax_Float, D_Float); + + type G_Float is digits 15; + pragma Float_Representation (Vax_Float, G_Float); + + -- Floating point type declarations for IEEE floating point data types + + type IEEE_Single_Float is digits 6; + pragma Float_Representation (IEEE_Float, IEEE_Single_Float); + + type IEEE_Double_Float is digits 15; + pragma Float_Representation (IEEE_Float, IEEE_Double_Float); + + pragma Warnings (On); + + Non_Ada_Error : exception; + + -- Hardware-oriented types and functions + + type Bit_Array is array (Integer range <>) of Boolean; + pragma Pack (Bit_Array); + + subtype Bit_Array_8 is Bit_Array (0 .. 7); + subtype Bit_Array_16 is Bit_Array (0 .. 15); + subtype Bit_Array_32 is Bit_Array (0 .. 31); + subtype Bit_Array_64 is Bit_Array (0 .. 63); + + type Unsigned_Byte is range 0 .. 255; + for Unsigned_Byte'Size use 8; + + function "not" (Left : Unsigned_Byte) return Unsigned_Byte; + function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + + function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte; + function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8; + + type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte; + + type Unsigned_Word is range 0 .. 65535; + for Unsigned_Word'Size use 16; + + function "not" (Left : Unsigned_Word) return Unsigned_Word; + function "and" (Left, Right : Unsigned_Word) return Unsigned_Word; + function "or" (Left, Right : Unsigned_Word) return Unsigned_Word; + function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word; + + function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word; + function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16; + + type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word; + + type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647; + for Unsigned_Longword'Size use 32; + + function "not" (Left : Unsigned_Longword) return Unsigned_Longword; + function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + + function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword; + function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32; + + type Unsigned_Longword_Array is + array (Integer range <>) of Unsigned_Longword; + + type Unsigned_32 is range 0 .. 4_294_967_295; + for Unsigned_32'Size use 32; + + function "not" (Left : Unsigned_32) return Unsigned_32; + function "and" (Left, Right : Unsigned_32) return Unsigned_32; + function "or" (Left, Right : Unsigned_32) return Unsigned_32; + function "xor" (Left, Right : Unsigned_32) return Unsigned_32; + + function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32; + function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32; + + type Unsigned_Quadword is record + L0 : Unsigned_Longword; + L1 : Unsigned_Longword; + end record; + + for Unsigned_Quadword'Size use 64; + for Unsigned_Quadword'Alignment use + Integer'Min (8, Standard'Maximum_Alignment); + + function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword; + function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + + function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword; + function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64; + + type Unsigned_Quadword_Array is + array (Integer range <>) of Unsigned_Quadword; + + function To_Address (X : Integer) return Address; + pragma Pure_Function (To_Address); + + function To_Address_Long (X : Unsigned_Longword) return Address; + pragma Pure_Function (To_Address_Long); + + function To_Integer (X : Address) return Integer; + + function To_Unsigned_Longword (X : Address) return Unsigned_Longword; + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; + + -- Conventional names for static subtypes of type UNSIGNED_LONGWORD + + subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1-1; + subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2-1; + subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3-1; + subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4-1; + subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5-1; + subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6-1; + subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7-1; + subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8-1; + subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9-1; + subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10-1; + subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11-1; + subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12-1; + subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13-1; + subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14-1; + subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15-1; + subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16-1; + subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17-1; + subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18-1; + subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19-1; + subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20-1; + subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21-1; + subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22-1; + subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23-1; + subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24-1; + subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25-1; + subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26-1; + subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27-1; + subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28-1; + subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29-1; + subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30-1; + subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31-1; + + -- Function for obtaining global symbol values + + function Import_Value (Symbol : String) return Unsigned_Longword; + function Import_Address (Symbol : String) return Address; + function Import_Largest_Value (Symbol : String) return Largest_Integer; + + pragma Import (Intrinsic, Import_Value); + pragma Import (Intrinsic, Import_Address); + pragma Import (Intrinsic, Import_Largest_Value); + + -- For the following declarations, note that the declaration without + -- a Retry_Count parameter means to retry infinitely. A value of zero + -- for the Retry_Count parameter means do not retry. + + -- Interlocked-instruction procedures + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean); + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean); + + type Aligned_Word is record + Value : Short_Integer; + end record; + + for Aligned_Word'Alignment use + Integer'Min (2, Standard'Maximum_Alignment); + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : in Natural; + Success_Flag : out Boolean); + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : in Natural; + Success_Flag : out Boolean); + + procedure Add_Interlocked + (Addend : in Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer); + + type Aligned_Integer is record + Value : Integer; + end record; + + for Aligned_Integer'Alignment use + Integer'Min (4, Standard'Maximum_Alignment); + + type Aligned_Long_Integer is record + Value : Long_Integer; + end record; + + for Aligned_Long_Integer'Alignment use + Integer'Min (8, Standard'Maximum_Alignment); + + -- For the following declarations, note that the declaration without + -- a Retry_Count parameter mean to retry infinitely. A value of zero + -- for the Retry_Count means do not retry. + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : in Integer); + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : in Long_Integer); + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : in Integer); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer); + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : in Integer); + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer); + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + type Insq_Status is + (Fail_No_Lock, OK_Not_First, OK_First); + + for Insq_Status use + (Fail_No_Lock => -1, + OK_Not_First => 0, + OK_First => +1); + + type Remq_Status is ( + Fail_No_Lock, + Fail_Was_Empty, + OK_Not_Empty, + OK_Empty); + + for Remq_Status use + (Fail_No_Lock => -1, + Fail_Was_Empty => 0, + OK_Not_Empty => +1, + OK_Empty => +2); + + procedure Insqhi + (Item : in Address; + Header : in Address; + Status : out Insq_Status); + + procedure Remqhi + (Header : in Address; + Item : out Address; + Status : out Remq_Status); + + procedure Insqti + (Item : in Address; + Header : in Address; + Status : out Insq_Status); + + procedure Remqti + (Header : in Address; + Item : out Address; + Status : out Remq_Status); + +private + + Address_Zero : constant Address := Null_Address; + No_Addr : constant Address := Null_Address; + + -- An AST_Handler value is from a typing point of view simply a pointer + -- to a procedure taking a single 64bit parameter. However, this + -- is a bit misleading, because the data that this pointer references is + -- highly stylized. See body of System.AST_Handling for full details. + + type AST_Handler is access procedure (Param : Long_Integer); + No_AST_Handler : constant AST_Handler := null; + + -- Other operators have incorrect profiles. It would be nice to make + -- them intrinsic, since the backend can handle them, but the front + -- end is not prepared to deal with them, so at least inline them. + + pragma Inline_Always ("+"); + pragma Inline_Always ("-"); + pragma Inline_Always ("not"); + pragma Inline_Always ("and"); + pragma Inline_Always ("or"); + pragma Inline_Always ("xor"); + + -- Other inlined subprograms + + pragma Inline_Always (Fetch_From_Address); + pragma Inline_Always (Assign_To_Address); + + -- Synchronization related subprograms. These are declared to have + -- convention C so that the critical parameters are passed by reference. + -- Without this, the parameters are passed by copy, creating load/store + -- race conditions. We also inline them, since this seems more in the + -- spirit of the original (hardware instrinsic) routines. + + pragma Convention (C, Clear_Interlocked); + pragma Inline_Always (Clear_Interlocked); + + pragma Convention (C, Set_Interlocked); + pragma Inline_Always (Set_Interlocked); + + pragma Convention (C, Add_Interlocked); + pragma Inline_Always (Add_Interlocked); + + pragma Convention (C, Add_Atomic); + pragma Inline_Always (Add_Atomic); + + pragma Convention (C, And_Atomic); + pragma Inline_Always (And_Atomic); + + pragma Convention (C, Or_Atomic); + pragma Inline_Always (Or_Atomic); + + -- Provide proper unchecked conversion definitions for transfer + -- functions. Note that we need this level of indirection because + -- the formal parameter name is X and not Source (and this is indeed + -- detectable by a program) + + function To_Unsigned_Byte_A is new + Unchecked_Conversion (Bit_Array_8, Unsigned_Byte); + + function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte + renames To_Unsigned_Byte_A; + + function To_Bit_Array_8_A is new + Unchecked_Conversion (Unsigned_Byte, Bit_Array_8); + + function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8 + renames To_Bit_Array_8_A; + + function To_Unsigned_Word_A is new + Unchecked_Conversion (Bit_Array_16, Unsigned_Word); + + function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word + renames To_Unsigned_Word_A; + + function To_Bit_Array_16_A is new + Unchecked_Conversion (Unsigned_Word, Bit_Array_16); + + function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16 + renames To_Bit_Array_16_A; + + function To_Unsigned_Longword_A is new + Unchecked_Conversion (Bit_Array_32, Unsigned_Longword); + + function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + function To_Bit_Array_32_A is new + Unchecked_Conversion (Unsigned_Longword, Bit_Array_32); + + function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32 + renames To_Bit_Array_32_A; + + function To_Unsigned_32_A is new + Unchecked_Conversion (Bit_Array_32, Unsigned_32); + + function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32 + renames To_Unsigned_32_A; + + function To_Bit_Array_32_A is new + Unchecked_Conversion (Unsigned_32, Bit_Array_32); + + function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32 + renames To_Bit_Array_32_A; + + function To_Unsigned_Quadword_A is new + Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword); + + function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword + renames To_Unsigned_Quadword_A; + + function To_Bit_Array_64_A is new + Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64); + + function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64 + renames To_Bit_Array_64_A; + + pragma Warnings (Off); + -- Turn warnings off. This is needed for systems with 64-bit integers, + -- where some of these operations are of dubious meaning, but we do not + -- want warnings when we compile on such systems. + + function To_Address_A is new + Unchecked_Conversion (Integer, Address); + pragma Pure_Function (To_Address_A); + + function To_Address (X : Integer) return Address + renames To_Address_A; + pragma Pure_Function (To_Address); + + function To_Address_Long_A is new + Unchecked_Conversion (Unsigned_Longword, Address); + pragma Pure_Function (To_Address_Long_A); + + function To_Address_Long (X : Unsigned_Longword) return Address + renames To_Address_Long_A; + pragma Pure_Function (To_Address_Long); + + function To_Integer_A is new + Unchecked_Conversion (Address, Integer); + + function To_Integer (X : Address) return Integer + renames To_Integer_A; + + function To_Unsigned_Longword_A is new + Unchecked_Conversion (Address, Unsigned_Longword); + + function To_Unsigned_Longword (X : Address) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + function To_Unsigned_Longword_A is new + Unchecked_Conversion (AST_Handler, Unsigned_Longword); + + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + pragma Warnings (On); + +end System.Aux_DEC; diff --git a/gcc/ada/s-interr-sigaction.adb b/gcc/ada/s-interr-sigaction.adb index 7dff527ae80..dc0fffd048a 100644 --- a/gcc/ada/s-interr-sigaction.adb +++ b/gcc/ada/s-interr-sigaction.adb @@ -105,10 +105,9 @@ package body System.Interrupts is type Server_Task_Access is access Server_Task; - Attached_Interrupts : array (Interrupt_ID) of Boolean; - Handlers : array (Interrupt_ID) of Task_Id; - Descriptors : array (Interrupt_ID) of Handler_Desc; - Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0); + Handlers : array (Interrupt_ID) of Task_Id; + Descriptors : array (Interrupt_ID) of Handler_Desc; + Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0); pragma Volatile_Components (Interrupt_Count); @@ -149,8 +148,13 @@ package body System.Interrupts is function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address); + -------------------- + -- Signal_Handler -- + -------------------- + procedure Signal_Handler (Sig : Interrupt_ID) is Handler : Task_Id renames Handlers (Sig); + begin if Intr_Attach_Reset and then intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR @@ -386,9 +390,8 @@ package body System.Interrupts is if New_Handler = null then - -- The null handler means we are detaching the handler. + -- The null handler means we are detaching the handler - Attached_Interrupts (Interrupt) := False; Descriptors (Interrupt) := (Kind => Unknown, T => null, E => 0, H => null, Static => False); @@ -396,7 +399,6 @@ package body System.Interrupts is Descriptors (Interrupt).Kind := Protected_Procedure; Descriptors (Interrupt).H := New_Handler; Descriptors (Interrupt).Static := Static; - Attached_Interrupts (Interrupt) := True; end if; end Attach_Handler; @@ -408,7 +410,8 @@ package body System.Interrupts is (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; - Static : Boolean := False) is + Static : Boolean := False) + is begin if Is_Reserved (Interrupt) then raise Program_Error; @@ -433,7 +436,8 @@ package body System.Interrupts is procedure Detach_Handler (Interrupt : Interrupt_ID; - Static : Boolean := False) is + Static : Boolean := False) + is begin if Is_Reserved (Interrupt) then raise Program_Error; @@ -449,7 +453,6 @@ package body System.Interrupts is "Trying to detach a static Interrupt Handler"); end if; - Attached_Interrupts (Interrupt) := False; Descriptors (Interrupt) := (Kind => Unknown, T => null, E => 0, H => null, Static => False); @@ -537,7 +540,7 @@ package body System.Interrupts is Int_Ref : System.Address) is Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); New_Task : Server_Task_Access; @@ -572,8 +575,6 @@ package body System.Interrupts is -- make by the task before it terminates. T.Interrupt_Entry := True; - - Attached_Interrupts (Interrupt) := True; end Bind_Interrupt_To_Entry; ------------------------------ @@ -582,14 +583,14 @@ package body System.Interrupts is procedure Detach_Interrupt_Entries (T : Task_Id) is begin - for I in Interrupt_ID loop - if not Is_Reserved (I) then - if Descriptors (I).Kind = Task_Entry and then - Descriptors (I).T = T then - Attached_Interrupts (I) := False; - Descriptors (I).Kind := Unknown; - - if intr_attach (int (I), null) = FUNC_ERR then + for J in Interrupt_ID loop + if not Is_Reserved (J) then + if Descriptors (J).Kind = Task_Entry + and then Descriptors (J).T = T + then + Descriptors (J).Kind := Unknown; + + if intr_attach (int (J), null) = FUNC_ERR then raise Program_Error; end if; end if; diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb index b19bb56f274..3c3c84e8980 100644 --- a/gcc/ada/s-stchop-vxworks.adb +++ b/gcc/ada/s-stchop-vxworks.adb @@ -165,28 +165,6 @@ package body System.Stack_Checking.Operations is return My_Stack; -- Never trust the cached value, but return local copy! end Set_Stack_Info; - -------------------- - -- Set_Stack_Size -- - -------------------- - - -- Specify the stack size for the current frame. - - procedure Set_Stack_Size - (Stack_Size : System.Storage_Elements.Storage_Offset) - is - My_Stack : Stack_Access; - Frame_Address : constant System.Address := My_Stack'Address; - - begin - My_Stack := Stack_Check (Frame_Address); - - if Stack_Grows_Down then - My_Stack.Limit := My_Stack.Base - Stack_Size; - else - My_Stack.Limit := My_Stack.Base + Stack_Size; - end if; - end Set_Stack_Size; - ----------------- -- Stack_Check -- ----------------- diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb index 3a1b1e91a07..0759941d638 100644 --- a/gcc/ada/s-stchop.adb +++ b/gcc/ada/s-stchop.adb @@ -166,28 +166,6 @@ package body System.Stack_Checking.Operations is return My_Stack; -- Never trust the cached value, but return local copy! end Set_Stack_Info; - -------------------- - -- Set_Stack_Size -- - -------------------- - - -- Specify the stack size for the current frame. - - procedure Set_Stack_Size - (Stack_Size : System.Storage_Elements.Storage_Offset) - is - My_Stack : Stack_Access; - Frame_Address : constant System.Address := My_Stack'Address; - - begin - My_Stack := Stack_Check (Frame_Address); - - if Stack_Grows_Down then - My_Stack.Limit := My_Stack.Base - Stack_Size; - else - My_Stack.Limit := My_Stack.Base + Stack_Size; - end if; - end Set_Stack_Size; - ----------------- -- Stack_Check -- ----------------- diff --git a/gcc/ada/s-stchop.ads b/gcc/ada/s-stchop.ads index 10217204d6f..11738f63c0b 100644 --- a/gcc/ada/s-stchop.ads +++ b/gcc/ada/s-stchop.ads @@ -38,17 +38,11 @@ pragma Restrictions (No_Elaboration_Code); -- We want to guarantee the absence of elaboration code because the -- binder does not handle references to this package. -with System.Storage_Elements; - pragma Polling (Off); -- Turn off polling, we do not want polling to take place during stack -- checking operations. It causes infinite loops and other problems. package System.Stack_Checking.Operations is - procedure Set_Stack_Size - (Stack_Size : System.Storage_Elements.Storage_Offset); - -- Specify the stack size for the current task. - procedure Update_Stack_Cache (Stack : Stack_Access); -- Set the stack cache for the current task. Note that this is only -- for optimization purposes, nothing can be assumed about the diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 608d412686e..bd5d05800f5 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -397,8 +397,7 @@ package body System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_Id; - Thread_Self : OSI.Thread_Id) - return Boolean + Thread_Self : OSI.Thread_Id) return Boolean is begin return False; @@ -410,8 +409,7 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_Id; - Thread_Self : OSI.Thread_Id) - return Boolean + Thread_Self : OSI.Thread_Id) return Boolean is begin return False; diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 97b3009e674..1789635f685 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -970,8 +970,7 @@ package body System.Task_Primitives.Operations is 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); @@ -986,8 +985,7 @@ package body System.Task_Primitives.Operations is 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); @@ -1006,8 +1004,8 @@ package body System.Task_Primitives.Operations is 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, diff --git a/gcc/ada/s-taprop-irix-athread.adb b/gcc/ada/s-taprop-irix-athread.adb index 8c0f95503d8..31965743c52 100644 --- a/gcc/ada/s-taprop-irix-athread.adb +++ b/gcc/ada/s-taprop-irix-athread.adb @@ -127,7 +127,6 @@ package body System.Task_Primitives.Operations is procedure Initialize_Athread_Library; function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id); - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); ------------------- @@ -829,7 +828,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 542bf4b5782..83fb530e7a2 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -958,7 +958,6 @@ package body System.Task_Primitives.Operations is 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)); @@ -973,7 +972,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; @@ -984,7 +982,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_No_Locks; @@ -1022,12 +1019,10 @@ package body System.Task_Primitives.Operations is 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); - begin return False; end Suspend_Task; @@ -1038,12 +1033,10 @@ package body System.Task_Primitives.Operations is 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; @@ -1058,8 +1051,8 @@ package body System.Task_Primitives.Operations is 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: diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 3af3ad3ef95..250bd8de779 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -251,7 +251,6 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is pragma Unreferenced (T); pragma Unreferenced (On); - begin null; end Stack_Guard; @@ -948,7 +947,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; @@ -959,7 +957,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_No_Locks; @@ -1015,8 +1012,8 @@ package body System.Task_Primitives.Operations is 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, diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb index 42f77f75f29..2b2af90ca5e 100644 --- a/gcc/ada/s-taprop-lynxos.adb +++ b/gcc/ada/s-taprop-lynxos.adb @@ -1076,8 +1076,7 @@ package body System.Task_Primitives.Operations is 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); @@ -1110,8 +1109,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; function State - (Int : System.Interrupt_Management.Interrupt_ID) - return Character; + (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, diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 7c9c5922bfe..7d7299f4970 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -400,7 +400,6 @@ package body System.Task_Primitives.Operations is procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is pragma Unreferenced (Level); - begin InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end Initialize_Lock; @@ -661,7 +660,6 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - begin Cond_Signal (T.Common.LL.CV'Access); end Wakeup; @@ -961,7 +959,7 @@ package body System.Task_Primitives.Operations is ---------------- procedure Abort_Task (T : Task_Id) is - pragma Unreferenced (T); + pragma Unreferenced (T); begin null; end Abort_Task; @@ -1055,7 +1053,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; @@ -1066,7 +1063,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_No_Locks; diff --git a/gcc/ada/s-taprop-os2.adb b/gcc/ada/s-taprop-os2.adb index a0e1e4b79d6..7556af3d025 100644 --- a/gcc/ada/s-taprop-os2.adb +++ b/gcc/ada/s-taprop-os2.adb @@ -202,7 +202,6 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is pragma Unreferenced (T); pragma Unreferenced (On); - begin null; end Stack_Guard; @@ -222,6 +221,7 @@ package body System.Task_Primitives.Operations is function Self return Task_Id is Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID; + begin -- Check that the thread local data has been initialized. @@ -681,7 +681,6 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - begin Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV)); end Wakeup; @@ -748,7 +747,6 @@ package body System.Task_Primitives.Operations is Loss_Of_Inheritance : Boolean := False) is pragma Unreferenced (Loss_Of_Inheritance); - begin T.Common.Current_Priority := Prio; Set_Temporary_Priority (T, Prio); @@ -1031,7 +1029,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr; - begin return Self_ID = TLD.Self_ID and then TLD.Lock_Prio_Level = 0; @@ -1070,8 +1067,7 @@ package body System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_Id; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is begin if Thread_Id (T.Common.LL.Thread) /= Thread_Self then @@ -1087,8 +1083,7 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_Id; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is begin if Thread_Id (T.Common.LL.Thread) /= Thread_Self then diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 297a9bd2cb2..0e84a75891b 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -688,7 +688,6 @@ package body System.Task_Primitives.Operations is 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); @@ -711,9 +710,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is pragma Warnings (Off, Reason); - Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -1055,7 +1052,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Warnings (Off, Self_ID); - begin return True; end Check_Exit; @@ -1066,7 +1062,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Warnings (Off, Self_ID); - begin return True; end Check_No_Locks; @@ -1104,12 +1099,10 @@ package body System.Task_Primitives.Operations is 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); - begin return False; end Suspend_Task; @@ -1120,12 +1113,10 @@ package body System.Task_Primitives.Operations is 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); - begin return False; end Resume_Task; @@ -1140,8 +1131,8 @@ package body System.Task_Primitives.Operations is 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, diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 7011fe0568e..941e34a65cd 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -321,7 +321,6 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is pragma Unreferenced (T); pragma Unreferenced (On); - begin null; end Stack_Guard; @@ -412,8 +411,8 @@ package body System.Task_Primitives.Operations is null; end Configure_Processors; - 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, @@ -698,7 +697,6 @@ package body System.Task_Primitives.Operations is function Monotonic_Clock return Duration is TS : aliased timespec; Result : Interfaces.C.int; - begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index ceccef9553a..88b4636204c 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -222,7 +222,6 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is pragma Unreferenced (T); pragma Unreferenced (On); - begin null; end Stack_Guard; @@ -601,7 +600,6 @@ package body System.Task_Primitives.Operations is function Monotonic_Clock return Duration is TS : aliased timespec; Result : Interfaces.C.int; - begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); @@ -979,7 +977,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; @@ -990,7 +987,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_No_Locks; @@ -1032,7 +1028,6 @@ package body System.Task_Primitives.Operations is is pragma Warnings (Off, T); pragma Warnings (Off, Thread_Self); - begin return False; end Suspend_Task; @@ -1047,7 +1042,6 @@ package body System.Task_Primitives.Operations is is pragma Warnings (Off, T); pragma Warnings (Off, Thread_Self); - begin return False; end Resume_Task; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index b40274ccca7..c7c9839a07f 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -588,9 +588,7 @@ package body System.Task_Primitives.Operations is 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); @@ -913,7 +911,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; @@ -924,7 +921,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_No_Locks; @@ -966,7 +962,6 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (T); pragma Unreferenced (Thread_Self); - begin return False; end Suspend_Task; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 4ed3d8d925b..f83fc02e495 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -681,7 +681,6 @@ package body System.Task_Primitives.Operations is function Monotonic_Clock return Duration is TS : aliased timespec; Result : int; - begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); @@ -703,9 +702,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : int; - begin Result := semGive (T.Common.LL.CV); pragma Assert (Result = 0); @@ -1019,7 +1016,6 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_Exit; @@ -1030,7 +1026,6 @@ package body System.Task_Primitives.Operations is function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); - begin return True; end Check_No_Locks; @@ -1068,8 +1063,7 @@ package body System.Task_Primitives.Operations is 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 /= 0 @@ -1087,8 +1081,7 @@ package body System.Task_Primitives.Operations is 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 /= 0 diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index dca1c3f8c06..41101095814 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -307,9 +307,8 @@ package System.Task_Primitives.Operations is -- The effect should be consistent with the Ada Reference Manual. -- In particular, when a task lowers its priority due to the loss of -- inherited priority, it goes at the head of the queue for its new - -- priority (RM D.2.2 par 9). - -- Loss_Of_Inheritance helps the underlying implementation to do it - -- right when the OS doesn't. + -- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying + -- implementation to do it right when the OS doesn't. function Get_Priority (T : ST.Task_Id) return System.Any_Priority; pragma Inline (Get_Priority); @@ -317,14 +316,13 @@ package System.Task_Primitives.Operations is function Monotonic_Clock return Duration; pragma Inline (Monotonic_Clock); - -- Returns "absolute" time, represented as an offset - -- relative to "the Epoch", which is Jan 1, 1970. - -- This clock implementation is immune to the system's clock changes. + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970. This clock implementation is immune to + -- the system's clock changes. function RT_Resolution return Duration; pragma Inline (RT_Resolution); - -- Returns the resolution of the underlying clock used to implement - -- RT_Clock. + -- Returns resolution of the underlying clock used to implement RT_Clock ---------------- -- Extensions -- @@ -477,8 +475,7 @@ package System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_Id; - Thread_Self : OSI.Thread_Id) - return Boolean; + Thread_Self : OSI.Thread_Id) return Boolean; -- Suspend a specific task when the underlying thread library provides -- such functionality, unless the thread associated with T is Thread_Self. -- Such functionality is needed by gdb on some targets (e.g VxWorks) @@ -486,8 +483,7 @@ package System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_Id; - Thread_Self : OSI.Thread_Id) - return Boolean; + Thread_Self : OSI.Thread_Id) return Boolean; -- Resume a specific task when the underlying thread library provides -- such functionality, unless the thread associated with T is Thread_Self. -- Such functionality is needed by gdb on some targets (e.g VxWorks) diff --git a/gcc/ada/s-vaflop-vms.adb b/gcc/ada/s-vaflop-vms-alpha.adb index 8b1bf031fa4..8b1bf031fa4 100644 --- a/gcc/ada/s-vaflop-vms.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 92b3c74810d..3cbe7cc7b7f 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1056,7 +1056,7 @@ package body Scng is exit; elsif C in Upper_Half_Character then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Bad_String_Char; end if; @@ -1604,7 +1604,7 @@ package body Scng is if Source (Scan_Ptr) not in Graphic_Character then if Source (Scan_Ptr) in Upper_Half_Character then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Illegal_Character; end if; @@ -2062,7 +2062,8 @@ package body Scng is -- Here is where we check if it was a keyword if Get_Name_Table_Byte (Token_Name) /= 0 - and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words) + and then (Ada_Version >= Ada_95 + or else Token_Name not in Ada_95_Reserved_Words) then Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e5646e7f338..1e27760a04a 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -79,7 +79,7 @@ package body Sem_Aggr is -- sorted order. procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id); - -- Ada 0Y (AI-231): Check bad usage of the null-exclusion issue + -- Ada 2005 (AI-231): Check bad usage of the null-exclusion issue ------------------------------------------------------ -- Subprograms used for RECORD AGGREGATE Processing -- @@ -469,7 +469,7 @@ package body Sem_Aggr is Check_Unset_Reference (Exp); end if; - -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- Ada 2005 (AI-231): Generate conversion to the null-excluding -- type to force the corresponding run-time check elsif Is_Access_Type (Check_Typ) @@ -881,10 +881,10 @@ package body Sem_Aggr is Error_Msg_N ("aggregate type cannot have limited component", N); Explain_Limited_Type (Typ, N); - -- Ada 0Y (AI-287): Limited aggregates allowed + -- Ada 2005 (AI-287): Limited aggregates allowed elsif Is_Limited_Type (Typ) - and not Extensions_Allowed + and Ada_Version < Ada_05 then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); @@ -979,10 +979,10 @@ package body Sem_Aggr is 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 + -- Ada 2005 (AI-231): Propagate the null_exclusion attribute to + -- the components of the array aggregate - if Extensions_Allowed then + if Ada_Version >= Ada_05 then Set_Can_Never_Be_Null (Aggr_Typ, Can_Never_Be_Null (Typ)); end if; @@ -1399,7 +1399,7 @@ package body Sem_Aggr is end if; end if; - -- Ada 0Y (AI-231): Propagate the type to the nested aggregate. + -- Ada 2005 (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. @@ -1488,7 +1488,7 @@ package body Sem_Aggr is return Failure; end if; - if Ada_83 + if Ada_Version = Ada_83 and then Assoc /= First (Component_Associations (N)) and then (Nkind (Parent (N)) = N_Assignment_Statement or else @@ -1671,18 +1671,18 @@ package body Sem_Aggr is end if; end loop; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) Check_Can_Never_Be_Null (N, Expression (Assoc)); - -- Ada 0Y (AI-287): In case of default initialized component + -- Ada 2005 (AI-287): In case of default initialized component -- we delay the resolution to the expansion phase if Box_Present (Assoc) then - -- Ada 0Y (AI-287): In case of default initialization of a - -- component the expander will generate calls to the - -- corresponding initialization subprogram. + -- Ada 2005 (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)) @@ -1690,7 +1690,7 @@ package body Sem_Aggr is null; else Error_Msg_N - ("(Ada 0Y): no value supplied for this component", + ("(Ada 2005): no value supplied for this component", Assoc); end if; @@ -1807,7 +1807,7 @@ package body Sem_Aggr is while Present (Expr) loop Nb_Elements := Nb_Elements + 1; - Check_Can_Never_Be_Null (N, Expr); -- Ada 0Y (AI-231) + Check_Can_Never_Be_Null (N, Expr); -- Ada 2005 (AI-231) if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then return Failure; @@ -1819,22 +1819,23 @@ package body Sem_Aggr is if Others_Present then Assoc := Last (Component_Associations (N)); - Check_Can_Never_Be_Null (N, Expression (Assoc)); -- Ada 0Y (AI-231) + Check_Can_Never_Be_Null + (N, Expression (Assoc)); -- Ada 2005 (AI-231) - -- Ada 0Y (AI-287): In case of default initialized component + -- Ada 2005 (AI-287): In case of default initialized component -- we delay the resolution to the expansion phase. if Box_Present (Assoc) then - -- Ada 0Y (AI-287): In case of default initialization of a - -- component the expander will generate calls to the - -- corresponding initialization subprogram. + -- Ada 2005 (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", + ("(Ada 2005): no value supplied for these components", Assoc); end if; @@ -1993,11 +1994,9 @@ package body Sem_Aggr is elsif Is_Limited_Type (Typ) then - -- Ada 0Y (AI-287): Limited aggregates are allowed + -- Ada 2005 (AI-287): Limited aggregates are allowed - if Extensions_Allowed then - null; - else + if Ada_Version < Ada_05 then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); return; @@ -2104,8 +2103,8 @@ package body Sem_Aggr is Mbox_Present : Boolean := False; Others_Mbox : Boolean := False; - -- Ada 0Y (AI-287): Variables used in case of default initialization to - -- provide a functionality similar to Others_Etype. Mbox_Present + -- Ada 2005 (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 @@ -2293,9 +2292,9 @@ package body Sem_Aggr is and then Comes_From_Source (Compon) and then not In_Instance_Body then - -- Ada 0Y (AI-287): Limited aggregates are allowed + -- Ada 2005 (AI-287): Limited aggregates are allowed - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Present (Expression (Assoc)) and then Nkind (Expression (Assoc)) = N_Aggregate then @@ -2333,8 +2332,8 @@ package body Sem_Aggr is -- indispensable otherwise, because each one must be -- expanded individually to preserve side-effects. - -- Ada 0Y (AI-287): In case of default initialization of - -- components, we duplicate the corresponding default + -- Ada 2005 (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 @@ -2371,15 +2370,15 @@ package body Sem_Aggr is elsif Chars (Compon) = Chars (Selector_Name) then if No (Expr) then - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Present (Expression (Assoc)) and then Nkind (Expression (Assoc)) = N_Null and then Can_Never_Be_Null (Compon) then Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding " & + ("(Ada 2005) NULL not allowed in null-excluding " & "components", Expression (Assoc)); end if; @@ -2387,7 +2386,7 @@ package body Sem_Aggr is -- components are grouped together with a "|" choice. -- For instance "filed1 | filed2 => Expr" - -- Ada 0Y (AI-287) + -- Ada 2005 (AI-287) if Box_Present (Assoc) then Mbox_Present := True; @@ -2396,8 +2395,8 @@ package body Sem_Aggr is -- from the record type declaration if Present (Next (Selector_Name)) then - Expr := New_Copy_Tree - (Expression (Parent (Compon))); + Expr := + New_Copy_Tree (Expression (Parent (Compon))); else Expr := Expression (Parent (Compon)); end if; @@ -2693,15 +2692,15 @@ package body Sem_Aggr is if Discr_Present (Discrim) then Resolve_Aggr_Expr (Positional_Expr, Discrim); - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Nkind (Positional_Expr) = N_Null and then Can_Never_Be_Null (Discrim) then Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding components", - Positional_Expr); + ("(Ada 2005) NULL not allowed in null-excluding " & + "components", Positional_Expr); end if; Next (Positional_Expr); @@ -2935,13 +2934,14 @@ package body Sem_Aggr is Component := Node (Component_Elmt); Resolve_Aggr_Expr (Positional_Expr, Component); - -- Ada 0Y (AI-231) - if Extensions_Allowed + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_05 and then Nkind (Positional_Expr) = N_Null and then Can_Never_Be_Null (Component) then Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding components", + ("(Ada 2005) NULL not allowed in null-excluding components", Positional_Expr); end if; @@ -2967,10 +2967,10 @@ package body Sem_Aggr is if Mbox_Present and then Is_Limited_Type (Etype (Component)) then - -- Ada 0Y (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. + -- Ada 2005 (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 initialization subprograms. Add_Association (Component => Component, @@ -3008,7 +3008,7 @@ package body Sem_Aggr is if Nkind (Selectr) = N_Others_Choice then - -- Ada 0Y (AI-287): others choice may have expression or mbox + -- Ada 2005 (AI-287): others choice may have expression or mbox if No (Others_Etype) and then not Others_Mbox @@ -3092,12 +3092,12 @@ package body Sem_Aggr is procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id) is begin - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Nkind (Expr) = N_Null and then Can_Never_Be_Null (Etype (N)) then Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding components", Expr); + ("(Ada 2005) NULL not allowed in null-excluding components", Expr); end if; end Check_Can_Never_Be_Null; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 031ffa41e94..25285378550 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1524,7 +1524,7 @@ package body Sem_Attr is if Comes_From_Source (N) then if not Attribute_83 (Attr_Id) then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Error_Msg_N ("(Ada 83) attribute% is not standard?", N); end if; @@ -1920,7 +1920,7 @@ package body Sem_Attr is Find_Type (P); Typ := Entity (P); - if Ada_95 + if Ada_Version >= Ada_95 and then not Is_Scalar_Type (Typ) and then not Is_Generic_Type (Typ) then @@ -2644,7 +2644,7 @@ package body Sem_Attr is Check_Scalar_Type; if Is_Real_Type (P_Type) then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Error_Msg_N ("(Ada 83) % attribute not allowed for real types", N); @@ -3150,7 +3150,7 @@ package body Sem_Attr is when Attribute_Range => Check_Array_Or_Scalar_Type; - if Ada_83 + if Ada_Version = Ada_83 and then Is_Scalar_Type (P_Type) and then Comes_From_Source (N) then @@ -4573,7 +4573,7 @@ package body Sem_Attr is -- Again we compute the variable Static for easy reference later -- (note that no array attributes are static in Ada 83). - Static := Ada_95; + Static := Ada_Version >= Ada_95; declare N : Node_Id; @@ -6624,16 +6624,16 @@ package body Sem_Attr is and then (Ekind (Btyp) = E_General_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. + -- Ada 2005 (AI-230): Check the accessibility of anonymous + -- access types in record and array components. For a + -- component definition the level is the same of the + -- enclosing composite type. - if Extensions_Allowed + if Ada_Version >= Ada_05 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) + 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. diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 3dac1e3aa02..1ad1baa6ac5 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -761,7 +761,7 @@ package body Sem_Cat is return; end if; - -- Ada0Y (AI-50217): Process explicit with_clauses that are not limited + -- Ada 2005 (AI-50217): Process explicit non-limited with_clauses declare Item : Node_Id; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 333bae3a9a7..31ddc659dba 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -76,7 +76,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 Ada 0Y (AI-50217). + -- Implements Ada 2005 (AI-50217). procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); -- Check whether the source for the body of a compilation unit must @@ -100,7 +100,7 @@ package body Sem_Ch10 is -- 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 Ada 0Y (AI-50217). + -- Implements Ada 2005 (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 @@ -128,11 +128,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. Implements Ada 0Y (AI-50217). + -- for current unit. Implements Ada 2005 (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. Implements Ada 0Y (AI-50217). + -- structures for the current compilation. Implements Ada 2005 (AI-50217). procedure Install_Withed_Unit (With_Clause : Node_Id; @@ -181,7 +181,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. Implements Ada 0Y (AI-50217). + -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217). procedure Remove_Parents (Lib_Unit : Node_Id); -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent @@ -619,7 +619,7 @@ package body Sem_Ch10 is Item := First (Context_Items (N)); while Present (Item) loop - -- Ada 0Y (AI-50217): Do not consider limited-withed units + -- Ada 2005 (AI-50217): Do not consider limited-withed units if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) @@ -798,8 +798,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 (Ada 0Y: AI-50217) - -- c) The third pass analyzes limited_with clauses (Ada 0Y: AI-50217) + -- the parents of child units (Ada 2005: AI-50217) + -- c) The third pass analyzes limited_with clauses (Ada 2005: AI-50217) Item := First (Context_Items (N)); while Present (Item) loop @@ -1616,7 +1616,7 @@ package body Sem_Ch10 is begin if Limited_Present (N) then - -- Ada 0Y (AI-50217): Build visibility structures but do not + -- Ada 2005 (AI-50217): Build visibility structures but do not -- analyze unit Build_Limited_Views (N); @@ -1818,9 +1818,9 @@ package body Sem_Ch10 is null; end if; - -- Ada 0Y (AI-262): Remove from visibility the entity corresponding to - -- private_with units; they will be made visible later (just before the - -- private part is analyzed) + -- Ada 2005 (AI-262): Remove from visibility the entity corresponding + -- to private_with units; they will be made visible later (just before + -- the private part is analyzed) if Private_Present (N) then Set_Is_Immediately_Visible (E_Name, False); @@ -2164,6 +2164,7 @@ package body Sem_Ch10 is or else Nkind (Lib_Unit) = N_Subprogram_Body) then Check_Parent_Context (Library_Unit (N)); + if Is_Child_Spec (Unit (Library_Unit (N))) then Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N)))); end if; @@ -2239,8 +2240,8 @@ package body Sem_Ch10 is Item := First (Context_Items (N)); while Present (Item) loop - -- Ada 0Y (AI-262): Allow private_with of a private child package in - -- public siblings + -- Ada 2005 (AI-262): Allow private_with of a private child package + -- in public siblings if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) @@ -3216,7 +3217,7 @@ package body Sem_Ch10 is then Set_Is_Immediately_Visible (Id); - -- Ada 0Y (AI-262): Make visible the private entities of + -- Ada 2005 (AI-262): Make visible the private entities of -- private-withed siblings if Private_Present (Item) then @@ -3366,7 +3367,7 @@ package body Sem_Ch10 is or else (Is_Child_Package and then Is_Visible_Child_Unit (P))) then - -- Ada 0Y (AI-262): Install the private declarations of P + -- Ada 2005 (AI-262): Install the private declarations of P if Private_Present (N) and then not In_Private_Part (P) @@ -3508,7 +3509,7 @@ package body Sem_Ch10 is P : constant Entity_Id := Scope (Uname); begin - -- Ada 0Y (AI-262): Do not install the private withed unit if we are + -- Ada 2005 (AI-262): 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 (before -- analyzing the private part of the package). @@ -4011,7 +4012,7 @@ package body Sem_Ch10 is Last_Pub_Lim_E := Last_Lim_E; - -- Ada 0Y (AI-262): Add the limited view of the private declarations + -- Ada 2005 (AI-262): Add the limited view of the private declarations -- Required to give support to limited-private-with clauses Build_Chain (Scope => P, @@ -4153,7 +4154,7 @@ package body Sem_Ch10 is Unit_Name : Entity_Id; begin - -- Ada 0Y (AI-50217): We remove the context clauses in two phases: + -- Ada 2005 (AI-50217): We remove the context clauses in two phases: -- limited-views first and regular-views later (to maintain the -- stack model). diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 2cd1ef589eb..e2918ae2d2f 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -99,7 +99,6 @@ package body Sem_Ch11 is Handler := First_Non_Pragma (L); while Present (Handler) loop Id1 := First (Exception_Choices (Handler)); - while Present (Id1) loop -- Only check against the exception choices which precede @@ -120,7 +119,9 @@ package body Sem_Ch11 is ("exception choice duplicates &#", Id, Id1); else - if Ada_83 and then Comes_From_Source (Id) then + if Ada_Version = Ada_83 + and then Comes_From_Source (Id) + then Error_Msg_N ("(Ada 83): duplicate exception choice&", Id); end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 6d4e25d2d7f..8a531409b71 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -674,7 +674,7 @@ package body Sem_Ch12 is -- generic is unit is validated, Set_Instance_Env completes Save_Env. type Instance_Env is record - Ada_83 : Boolean; + Ada_Version : Ada_Version_Type; Instantiated_Parent : Assoc; Exchanged_Views : Elist_Id; Hidden_Entities : Elist_Id; @@ -1469,9 +1469,9 @@ package body Sem_Ch12 is if K = E_Generic_In_Parameter then - -- Ada 0Y (AI-287): Limited aggregates allowed in generic formals + -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals - if not Extensions_Allowed and then Is_Limited_Type (T) then + if Ada_Version < Ada_05 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); @@ -2384,7 +2384,7 @@ package body Sem_Ch12 is elsif Ekind (Gen_Unit) /= E_Generic_Package then - -- Ada 0Y (AI-50217): Instance can not be used in limited with_clause + -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause if From_With_Type (Gen_Unit) then Error_Msg_N @@ -5674,7 +5674,7 @@ package body Sem_Ch12 is Saved : Instance_Env; begin - Saved.Ada_83 := Ada_83; + Saved.Ada_Version := Ada_Version; Saved.Instantiated_Parent := Current_Instantiated_Parent; Saved.Exchanged_Views := Exchanged_Views; Saved.Hidden_Entities := Hidden_Entities; @@ -8072,7 +8072,7 @@ package body Sem_Ch12 is elsif Is_Indefinite_Subtype (Act_T) and then not Is_Indefinite_Subtype (A_Gen_T) - and then Ada_95 + and then Ada_Version >= Ada_95 then Error_Msg_NE ("actual for & must be a definite subtype", Actual, Gen_T); @@ -8128,7 +8128,7 @@ package body Sem_Ch12 is elsif not Subtypes_Statically_Match (Formal_Subt, Etype (Actual_Discr)) - and then Ada_95 + and then Ada_Version >= Ada_95 then Error_Msg_NE ("subtypes of actual discriminants must match formal", @@ -8791,7 +8791,7 @@ package body Sem_Ch12 is Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); begin - Ada_83 := Saved.Ada_83; + Ada_Version := Saved.Ada_Version; if No (Current_Instantiated_Parent.Act_Id) then @@ -9751,12 +9751,13 @@ package body Sem_Ch12 is begin -- Regardless of the current mode, predefined units are analyzed in - -- Ada95 mode, and Ada83 checks don't apply. + -- the most current Ada mode, and earlier version Ada checks do not + -- apply to predefined units. if Is_Internal_File_Name (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), Renamings_Included => True) then - Ada_83 := False; + Ada_Version := Ada_Version_Type'Last; end if; Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index ebfc834b84c..0656bde1668 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -103,7 +103,6 @@ package body Sem_Ch2 is procedure Analyze_String_Literal (N : Node_Id) is begin - -- The type is eventually inherited from the context. If expansion -- has already established the proper type, do not modify it. @@ -115,7 +114,7 @@ package body Sem_Ch2 is -- turns out to be non-static, then the Is_Static_Expression flag -- will be reset in Eval_String_Literal. - if Ada_95 then + if Ada_Version >= Ada_95 then Set_Is_Static_Expression (N); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 109c05b7ada..b81cac9052d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -677,7 +677,7 @@ package body Sem_Ch3 is Error_Msg_N ("task entries cannot have access parameters", N); end if; - -- Ada 0Y (AI-254): In case of anonymous access to subprograms + -- Ada 2005 (AI-254): In case of anonymous access to subprograms -- call the corresponding semantic routine if Present (Access_To_Subprogram_Definition (N)) then @@ -705,11 +705,12 @@ package body Sem_Ch3 is Init_Size_Align (Anon_Type); Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); - -- Ada 0Y (AI-231): Ada 0Y semantics for anonymous access differs from - -- Ada 95 semantics. In Ada 0Y, anonymous access must specify if the - -- null value is allowed; in Ada 95 the null value is not allowed + -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs + -- from Ada 95 semantics. In Ada 2005, anonymous access must specify + -- if the null value is allowed. In Ada 95 the null value is never + -- allowed. - if Extensions_Allowed then + if Ada_Version >= Ada_05 then Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); else Set_Can_Never_Be_Null (Anon_Type, True); @@ -721,12 +722,12 @@ package body Sem_Ch3 is Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); - -- Ada 0Y (AI-50217): Propagate the attribute that indicates that the + -- Ada 2005 (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)); - -- Ada 0Y (AI-231): Propagate the access-constant attribute + -- Ada 2005 (AI-231): Propagate the access-constant attribute Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); @@ -836,7 +837,7 @@ package body Sem_Ch3 is Init_Size_Align (T_Name); Set_Directly_Designated_Type (T_Name, Desig_Type); - -- Ada 0Y (AI-231): Propagate the null-excluding attribute + -- Ada 2005 (AI-231): Propagate the null-excluding attribute Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); @@ -899,9 +900,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. - -- 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. + -- Ada 2005 (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. declare N_Desig : Entity_Id; @@ -933,7 +934,7 @@ package body Sem_Ch3 is Set_Has_Task (T, False); Set_Has_Controlled_Component (T, False); - -- Ada 0Y (AI-231): Propagate the null-excluding and access-constant + -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant -- attributes Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); @@ -957,7 +958,7 @@ package body Sem_Ch3 is T := Find_Type_Of_Object (Subtype_Indication (Component_Definition (N)), N); - -- Ada 0Y (AI-230): Access Definition case + -- Ada 2005 (AI-230): Access Definition case else pragma Assert (Present @@ -967,13 +968,13 @@ 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 + -- Ada 2005 (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) + Set_Scope (T, Current_Scope); -- Ada 2005 (AI-230) - -- Ada 0Y (AI-254) + -- Ada 2005 (AI-254) if Present (Access_To_Subprogram_Definition (Access_Definition (Component_Definition (N)))) @@ -1041,10 +1042,10 @@ package body Sem_Ch3 is Set_Etype (Id, T); Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N))); - -- Ada 0Y (AI-231): Propagate the null-excluding attribute and carry + -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Null_Exclusion_Present (Component_Definition (N)) or else Can_Never_Be_Null (T)) then @@ -1600,10 +1601,10 @@ package body Sem_Ch3 is end if; end if; - -- Ada 0Y (AI-231): Propagate the null-excluding attribute and carry + -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Null_Exclusion_Present (N) or else Can_Never_Be_Null (T)) then @@ -1633,7 +1634,7 @@ package body Sem_Ch3 is -- In Ada 83, deferred constant must be of private type elsif not Is_Private_Type (T) then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) deferred constant must be private type", N); end if; @@ -1775,7 +1776,7 @@ package body Sem_Ch3 is -- Not allowed in Ada 83 if not Constant_Present (N) then - if Ada_83 + if Ada_Version = Ada_83 and then Comes_From_Source (Object_Definition (N)) then Error_Msg_N @@ -2449,8 +2450,8 @@ package body Sem_Ch3 is Set_Directly_Designated_Type (Id, Designated_Type (T)); - -- Ada 0Y (AI-231): Propagate the null-excluding attribute and - -- carry out some static checks + -- Ada 2005 (AI-231): Propagate the null-excluding attribute + -- and carry out some static checks if Null_Exclusion_Present (N) or else Can_Never_Be_Null (T) @@ -2461,7 +2462,7 @@ package body Sem_Ch3 is and then Can_Never_Be_Null (T) then Error_Msg_N - ("(Ada 0Y) null exclusion not allowed if parent " + ("(Ada 2005) null exclusion not allowed if parent " & "is already non-null", Subtype_Indication (N)); end if; end if; @@ -2651,9 +2652,9 @@ package body Sem_Ch3 is -- The full view, if present, now points to the current type - -- 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. + -- Ada 2005 (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)) @@ -2969,20 +2970,20 @@ package body Sem_Ch3 is Element_Type := Process_Subtype (Subtype_Indication (Component_Def), P, Related_Id, 'C'); - -- Ada 0Y (AI-230): Access Definition case + -- Ada 2005 (AI-230): Access Definition case else pragma Assert (Present (Access_Definition (Component_Def))); 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 + -- Ada 2005 (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, Current_Scope); -- Ada 0Y (AI-230) + Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) - -- Ada 0Y (AI-254) + -- Ada 2005 (AI-254) declare CD : constant Node_Id := @@ -3065,10 +3066,10 @@ package body Sem_Ch3 is Set_Has_Aliased_Components (Etype (T)); end if; - -- Ada 0Y (AI-231): Propagate the null-excluding attribute to the array - -- to ensure that objects of this type are initialized + -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the + -- array to ensure that objects of this type are initialized. - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Null_Exclusion_Present (Component_Definition (Def)) or else Can_Never_Be_Null (Element_Type)) then @@ -3078,7 +3079,7 @@ package body Sem_Ch3 is and then Can_Never_Be_Null (Element_Type) then Error_Msg_N - ("(Ada 0Y) already a null-excluding type", + ("(Ada 2005) already a null-excluding type", Subtype_Indication (Component_Definition (Def))); end if; end if; @@ -3297,7 +3298,7 @@ package body Sem_Ch3 is Has_Private_Component (Derived_Type)); Conditional_Delay (Derived_Type, Subt); - -- Ada 0Y (AI-231). Set the null-exclusion attribute + -- Ada 2005 (AI-231). Set the null-exclusion attribute if Null_Exclusion_Present (Type_Definition (N)) or else Can_Never_Be_Null (Parent_Type) @@ -6622,12 +6623,12 @@ package body Sem_Ch3 is and then not In_Instance and then not In_Inlined_Body then - -- Ada 0Y (AI-287): Relax the strictness of the front-end in case of - -- limited aggregates and extension aggregates. + -- Ada 2005 (AI-287): Relax the strictness of the front-end in + -- case of limited aggregates and extension aggregates. - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Nkind (Exp) = N_Aggregate - or else Nkind (Exp) = N_Extension_Aggregate) + or else Nkind (Exp) = N_Extension_Aggregate) then null; else @@ -6668,10 +6669,10 @@ package body Sem_Ch3 is Set_Is_Immediately_Visible (D); Set_Homonym (D, Prev); - -- Ada 0Y (AI-230): Access discriminant allowed in non-limited - -- record types + -- Ada 2005 (AI-230): Access discriminant allowed in + -- non-limited record types. - if not Extensions_Allowed then + if Ada_Version < Ada_05 then -- This restriction gets applied to the full type here; it -- has already been applied earlier to the partial view @@ -9416,13 +9417,13 @@ package body Sem_Ch3 is elsif Is_Unchecked_Union (Parent_Type) then Error_Msg_N ("cannot derive from Unchecked_Union type", N); - -- Ada 0Y (AI-231): Static check + -- Ada 2005 (AI-231): Static check elsif Is_Access_Type (Parent_Type) and then Null_Exclusion_Present (Type_Definition (N)) and then Can_Never_Be_Null (Parent_Type) then - Error_Msg_N ("(Ada 0Y) null exclusion not allowed if parent is " + Error_Msg_N ("(Ada 2005) null exclusion not allowed if parent is " & "already non-null", Type_Definition (N)); end if; @@ -9444,11 +9445,11 @@ package body Sem_Ch3 is -- be used for further derivation until the end of its visible part. -- Note that derivation in the private part of the package is allowed. - if Ada_83 + if Ada_Version = Ada_83 and then Is_Derived_Type (Parent_Type) and then In_Visible_Part (Scope (Parent_Type)) then - if Ada_83 and then Comes_From_Source (Indic) then + if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then Error_Msg_N ("(Ada 83): premature use of type for derivation", Indic); end if; @@ -10996,7 +10997,7 @@ package body Sem_Ch3 is elsif T = Any_Character then - if not Ada_83 then + if Ada_Version >= Ada_95 then Error_Msg_N ("ambiguous character literals (could be Wide_Character)", I); @@ -11609,7 +11610,7 @@ package body Sem_Ch3 is if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then Discr_Type := Access_Definition (N, Discriminant_Type (Discr)); - -- Ada 0Y (AI-254) + -- Ada 2005 (AI-254) if Present (Access_To_Subprogram_Definition (Discriminant_Type (Discr))) @@ -11632,15 +11633,15 @@ package body Sem_Ch3 is if Is_Access_Type (Discr_Type) then - -- Ada 0Y (AI-230): Access discriminant allowed in non-limited + -- Ada 2005 (AI-230): Access discriminant allowed in non-limited -- record types - if not Extensions_Allowed then + if Ada_Version < Ada_05 then Check_Access_Discriminant_Requires_Limited (Discr, Discriminant_Type (Discr)); end if; - if Ada_83 and then Comes_From_Source (Discr) then + if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then Error_Msg_N ("(Ada 83) access discriminant not allowed", Discr); end if; @@ -11694,10 +11695,10 @@ package body Sem_Ch3 is Default_Not_Present := True; end if; - -- Ada 0Y (AI-231): Set the null-excluding attribute and carry out - -- some static checks + -- Ada 2005 (AI-231): Set the null-excluding attribute and carry + -- out some static checks. - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Null_Exclusion_Present (Discr) or else Can_Never_Be_Null (Discr_Type)) then @@ -12470,16 +12471,16 @@ package body Sem_Ch3 is Find_Type (S); Check_Incomplete (S); - -- Ada 0Y (AI-231): Static check + -- Ada 2005 (AI-231): Static check - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Present (Parent (S)) and then Null_Exclusion_Present (Parent (S)) and then Nkind (Parent (S)) /= N_Access_To_Object_Definition and then not Is_Access_Type (Entity (S)) then Error_Msg_N - ("(Ada 0Y) null-exclusion part requires an access type", S); + ("(Ada 2005) null-exclusion part requires an access type", S); end if; return Entity (S); diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 08b2c202f56..2fa14209bc2 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -209,12 +209,12 @@ package Sem_Ch3 is function Replace_Anonymous_Access_To_Protected_Subprogram (N : Node_Id; Prev_E : Entity_Id) return Entity_Id; - -- Ada 0Y (AI-254): Create and decorate an internal full type declaration - -- in the enclosing scope corresponding to an anonymous access to protected - -- subprogram. In addition, replace the anonymous access by an occurrence - -- of this internal type. Prev_Etype is used to link the new internal - -- entity with the anonymous entity. Return the entity of this type - -- declaration. + -- Ada 2005 (AI-254): Create and decorate an internal full type + -- declaration in the enclosing scope corresponding to an anonymous + -- access to protected subprogram. In addition, replace the anonymous + -- access by an occurrence of this internal type. Prev_Etype is used + -- to link the new internal entity with the anonymous entity. Return + -- the entity of this type declaration. procedure Set_Completion_Referenced (E : Entity_Id); -- If E is the completion of a private or incomplete type declaration, diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 48169d94f12..e84044e74c0 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -336,12 +336,12 @@ package body Sem_Ch4 is and then Comes_From_Source (N) and then not In_Instance_Body then - -- Ada 0Y (AI-287): Do not post an error if the expression + -- Ada 2005 (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 + if Ada_Version >= Ada_05 and then Nkind (Expression (E)) = N_Aggregate then null; @@ -393,7 +393,7 @@ package body Sem_Ch4 is Find_Type (Subtype_Mark (E)); if Is_Elementary_Type (Entity (Subtype_Mark (E))) then - if not (Ada_83 + if not (Ada_Version = Ada_83 and then Is_Access_Type (Entity (Subtype_Mark (E)))) then Error_Msg_N ("constraint not allowed here", E); @@ -444,10 +444,10 @@ package body Sem_Ch4 is Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Can_Never_Be_Null (Type_Id) then - Error_Msg_N ("(Ada 0Y) qualified expression required", + Error_Msg_N ("(Ada 2005) qualified expression required", Expression (N)); end if; @@ -494,9 +494,9 @@ package body Sem_Ch4 is Check_Restriction (No_Local_Allocators, N); end if; - -- Ada 0Y (AI-231): Static checks + -- Ada 2005 (AI-231): Static checks - if Extensions_Allowed + if Ada_Version >= Ada_05 and then (Null_Exclusion_Present (N) or else Can_Never_Be_Null (Etype (N))) then @@ -2435,7 +2435,7 @@ package body Sem_Ch4 is end if; end if; - if Ada_83 + if Ada_Version = Ada_83 and then (Nkind (Parent (N)) = N_Loop_Parameter_Specification or else Nkind (Parent (N)) = N_Constrained_Array_Definition) @@ -3082,7 +3082,7 @@ package body Sem_Ch4 is Error_Msg_N ("\use qualified expression instead", N); elsif Nkind (Expr) = N_Character_Literal then - if Ada_83 then + if Ada_Version = Ada_83 then Resolve (Expr, T); else Error_Msg_N ("argument of conversion cannot be character literal", @@ -3480,12 +3480,12 @@ package body Sem_Ch4 is Void_Interp_Seen : Boolean := False; begin - if Extensions_Allowed then + if Ada_Version >= Ada_05 then Actual := First_Actual (N); - while Present (Actual) loop - -- Ada 0Y (AI-50217): Post an error in case of premature usage of - -- an entity from the limited view. + + -- Ada 2005 (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)) @@ -3904,10 +3904,10 @@ 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. + -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: + -- Do not allow anonymous access types in equality operators. - if not Extensions_Allowed + if Ada_Version < Ada_05 and then Ekind (T1) = E_Anonymous_Access_Type then return; @@ -4406,7 +4406,7 @@ package body Sem_Ch4 is and then Is_Abstract (It.Nam) and then not Is_Dispatching_Operation (It.Nam) and then - (Extensions_Allowed + (Ada_Version >= Ada_05 or else Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (It.Nam)))) @@ -4448,7 +4448,10 @@ package body Sem_Ch4 is Get_First_Interp (N, I, It); while Present (It.Nam) loop - if Scope (It.Nam) = Standard_Standard then + if Scope (It.Nam) = Standard_Standard + and then Base_Type (It.Typ) = + Base_Type (Etype (Abstract_Op)) + then Remove_Interp (I); end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index c43aee8cf0a..6b799ee5979 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -397,9 +397,9 @@ package body Sem_Ch5 is Propagate_Tag (Lhs, Rhs); end if; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Nkind (Rhs) = N_Null and then Is_Access_Type (T1) and then not Assignment_OK (Lhs) @@ -408,7 +408,7 @@ package body Sem_Ch5 is or else Can_Never_Be_Null (Etype (Lhs))) then Error_Msg_N - ("(Ada 0Y) NULL not allowed in null-excluding objects", Lhs); + ("(Ada 2005) NULL not allowed in null-excluding objects", Lhs); end if; if Is_Scalar_Type (T1) then @@ -685,7 +685,7 @@ package body Sem_Ch5 is ("character literal as case expression is ambiguous", Exp); return; - elsif Ada_83 + elsif Ada_Version = Ada_83 and then (Is_Generic_Type (Exp_Btype) or else Is_Generic_Type (Root_Type (Exp_Btype))) then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 69cc4d097f5..8d2b53c50d5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1182,7 +1182,7 @@ package body Sem_Ch6 is end if; end if; - -- Ada 0Y (AI-262): In library subprogram bodies, after the analysis + -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis -- if its specification we have to install the private withed units. if Is_Compilation_Unit (Body_Id) @@ -2163,7 +2163,7 @@ package body Sem_Ch6 is -- skipped if either entity is an operator in package Standard. -- or if either old or new instance is not from the source program. - if Ada_83 + if Ada_Version = Ada_83 and then Sloc (Old_Id) > Standard_Location and then Sloc (New_Id) > Standard_Location and then Comes_From_Source (Old_Id) @@ -2406,7 +2406,7 @@ package body Sem_Ch6 is -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X) - if Ada_83 then + if Ada_Version = Ada_83 then declare Old_Disc : constant Node_Id := Declaration_Node (Old_Discr); @@ -3087,7 +3087,7 @@ package body Sem_Ch6 is or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); end if; - -- Ada 0Y (AI-254): Detect anonymous access to subprogram types. + -- Ada 2005 (AI-254): Detect anonymous access to subprogram types Are_Anonymous_Access_To_Subprogram_Types := @@ -3118,7 +3118,7 @@ package body Sem_Ch6 is if (Ekind (Type_1) = E_Anonymous_Access_Type and then Ekind (Type_2) = E_Anonymous_Access_Type) - or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 0Y (AI-254) + or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254) then declare Desig_1 : Entity_Id; @@ -4952,9 +4952,8 @@ package body Sem_Ch6 is and then Ekind (Root_Type (Formal_Type)) = E_Incomplete_Type) then - -- Ada 0Y (AI-50217): Incomplete tagged types that are made - -- visible through a limited with_clause are valid formal - -- types. + -- Ada 2005 (AI-50217): Incomplete tagged types that are made + -- visible by a limited with_clause are valid formal types. if From_With_Type (Formal_Type) and then Is_Tagged_Type (Formal_Type) @@ -4972,7 +4971,7 @@ package body Sem_Ch6 is Parameter_Type (Param_Spec), Formal_Type); end if; - -- Ada 0Y (AI-231): Create and decorate an internal subtype + -- Ada 2005 (AI-231): Create and decorate an internal subtype -- declaration corresponding to the null-excluding type of the -- formal in the enclosing scope. In addition, replace the -- parameter type of the formal to this internal subtype. @@ -5033,7 +5032,7 @@ package body Sem_Ch6 is end; end if; - -- Ada 0Y (AI-231): Static checks + -- Ada 2005 (AI-231): Static checks if Null_Exclusion_Present (Param_Spec) or else Can_Never_Be_Null (Entity (Ptype)) @@ -5047,7 +5046,7 @@ package body Sem_Ch6 is Formal_Type := Access_Definition (Related_Nod, Parameter_Type (Param_Spec)); - -- Ada 0Y (AI-254) + -- Ada 2005 (AI-254) declare AD : constant Node_Id := @@ -5332,10 +5331,10 @@ package body Sem_Ch6 is if Nkind (Parameter_Type (Spec)) = N_Access_Definition then - -- Ada 0Y (AI-231): This behaviour has been modified in Ada 0Y. + -- Ada 2005 (AI-231): This behaviour has been modified in Ada 2005. -- It is only forced if the null_exclusion appears. - if not Extensions_Allowed + if Ada_Version < Ada_05 or else Null_Exclusion_Present (Spec) then Set_Is_Known_Non_Null (Formal_Id); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index c83e2360fa7..e6973652360 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -219,7 +219,7 @@ package body Sem_Ch7 is or else Is_Child_Unit (Spec_Id)) and then not Unit_Requires_Body (Spec_Id) then - if Ada_83 then + if Ada_Version = Ada_83 then Error_Msg_N ("optional package body (not allowed in Ada 95)?", N); else diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 2ec768d3716..1b0d7b17511 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -429,7 +429,7 @@ package body Sem_Ch8 is -- Used to resolved qualified names whose selector is a character literal. function Has_Private_With (E : Entity_Id) return Boolean; - -- Ada 0Y (AI-262): Determines if the current compilation unit has a + -- Ada 2005 (AI-262): Determines if the current compilation unit has a -- private with on E procedure Find_Expanded_Name (N : Node_Id); @@ -687,7 +687,7 @@ package body Sem_Ch8 is T := Entity (Subtype_Mark (N)); Analyze_And_Resolve (Nam, T); - -- Ada 0Y (AI-230/AI-254): Access renaming + -- Ada 2005 (AI-230/AI-254): Access renaming else pragma Assert (Present (Access_Definition (N))); T := Access_Definition @@ -696,7 +696,7 @@ package body Sem_Ch8 is Analyze_And_Resolve (Nam, T); - -- Ada 0Y (AI-231): "In the case where the type is defined by an + -- Ada 2005 (AI-231): "In the case where the type is defined by an -- access_definition, the renamed entity shall be of an access-to- -- constant type if and only if the access_definition defines an -- access-to-constant type" ARM 8.5.1(4) @@ -704,11 +704,11 @@ package body Sem_Ch8 is 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 " + Error_Msg_N ("(Ada 2005): 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 " + Error_Msg_N ("(Ada 2005): null-excluding attribute ignored " & "('R'M 8.5.1(6))?", N); end if; end if; @@ -820,7 +820,7 @@ package body Sem_Ch8 is Error_Msg_N ("expect package name in renaming", Name (N)); - -- Ada 0Y (AI-50217): Limited withed packages can not be renamed + -- Ada 2005 (AI-50217): Limited withed packages can not be renamed elsif Ekind (Old_P) = E_Package and then From_With_Type (Old_P) @@ -1096,9 +1096,9 @@ package body Sem_Ch8 is --------------------------------- procedure Analyze_Subprogram_Renaming (N : Node_Id) is - Spec : constant Node_Id := Specification (N); - Save_83 : constant Boolean := Ada_83; - Nam : constant Node_Id := Name (N); + Spec : constant Node_Id := Specification (N); + Save_AV : constant Ada_Version_Type := Ada_Version; + Nam : constant Node_Id := Name (N); New_S : Entity_Id; Old_S : Entity_Id := Empty; Rename_Spec : Entity_Id; @@ -1279,7 +1279,7 @@ package body Sem_Ch8 is Set_Has_Completion (Rename_Spec, Inside_A_Generic); - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N); end if; @@ -1363,14 +1363,13 @@ package body Sem_Ch8 is -- between renamed entity and new entity, even though the same circuit -- is used. - Ada_83 := False; + Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95); if No (Old_S) then Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); end if; if Old_S /= Any_Id then - if Is_Actual and then From_Default (N) then @@ -1552,7 +1551,7 @@ package body Sem_Ch8 is end if; end if; - Ada_83 := Save_83; + Ada_Version := Save_AV; end Analyze_Subprogram_Renaming; ------------------------- @@ -2409,7 +2408,7 @@ package body Sem_Ch8 is -- rather than undefined. Nvis_Is_Private_Subprg : Boolean := False; - -- Ada 0Y (AI-262): Set True to indicate that a form of Beaujolais + -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais -- effect concerning library subprograms has been detected. Used to -- generate the precise error message. @@ -2579,7 +2578,7 @@ package body Sem_Ch8 is Item : Node_Id; begin - -- Ada 0Y (AI-262): Generate a precise error concerning the + -- Ada 2005 (AI-262): Generate a precise error concerning the -- Beaujolais effect that was previously detected if Nvis_Is_Private_Subprg then @@ -2609,7 +2608,7 @@ package body Sem_Ch8 is pragma Assert (Error_Msg_Sloc /= No_Location); - Error_Msg_N ("(Ada 0Y): hidden by private with clause #", N); + Error_Msg_N ("(Ada 2005): hidden by private with clause #", N); return; end if; @@ -2993,7 +2992,7 @@ package body Sem_Ch8 is Only_One_Visible := False; All_Overloadable := All_Overloadable and Is_Overloadable (E2); - -- Ada 0Y (AI-262): Protect against a form of Beujolais effect + -- Ada 2005 (AI-262): Protect against a form of Beujolais effect -- that can occurr in private_with clauses. Example: -- with A; @@ -3521,7 +3520,7 @@ package body Sem_Ch8 is Set_Chars (Selector, Chars (Id)); end if; - -- Ada 0Y (AI-50217): Check usage of entities in limited withed units + -- Ada 2005 (AI-50217): Check usage of entities in limited withed units if Ekind (P_Name) = E_Package and then From_With_Type (P_Name) @@ -4307,10 +4306,10 @@ package body Sem_Ch8 is Set_Etype (N, C); end if; - -- Base attribute, allowed in Ada 95 mode only + -- Base attribute, not allowed in Ada 83 elsif Attribute_Name (N) = Name_Base then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) Base attribute not allowed in subtype mark", N); @@ -4318,7 +4317,7 @@ package body Sem_Ch8 is Find_Type (Prefix (N)); Typ := Entity (Prefix (N)); - if Ada_95 + if Ada_Version >= Ada_95 and then not Is_Scalar_Type (Typ) and then not Is_Generic_Type (Typ) then @@ -5456,7 +5455,7 @@ package body Sem_Ch8 is Set_In_Use (P); - -- Ada 0Y (AI-50217): Check restriction. + -- Ada 2005 (AI-50217): Check restriction if From_With_Type (P) then Error_Msg_N ("limited withed package cannot appear in use clause", N); @@ -5488,7 +5487,7 @@ package body Sem_Ch8 is Real_P := P; end if; - -- Ada 0Y (AI-262): Check the use_clause of a private withed package + -- Ada 2005 (AI-262): Check the use_clause of a private withed package -- found in the private part of a package specification if In_Private_Part (Current_Scope) @@ -5506,7 +5505,7 @@ package body Sem_Ch8 is Id := First_Entity (P); while Present (Id) and then (Id /= First_Private_Entity (P) - or else Private_With_OK) -- Ada 0Y (AI-262) + or else Private_With_OK) -- Ada 2005 (AI-262) loop Prev := Current_Entity (Id); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 5dba0ae3f85..c81be0ec353 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1715,7 +1715,7 @@ package body Sem_Ch9 is New_Scope (T); if Present (Discriminant_Specifications (N)) then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index b33973f2051..d248f07c7d2 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1241,7 +1241,7 @@ package body Sem_Eval is -- Concatenation is never static in Ada 83, so if Ada 83 -- check operand non-static context - if Ada_83 + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Check_Non_Static_Context (Left); @@ -2226,7 +2226,7 @@ package body Sem_Eval is begin -- Short circuit operations are never static in Ada 83 - if Ada_83 + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Check_Non_Static_Context (Left); @@ -2379,7 +2379,7 @@ package body Sem_Eval is -- bound is type'First. In either case it is the upper bound that -- is out of range of the index type. - if Ada_95 then + if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String or else Root_Type (Bas) = Standard_Wide_String @@ -3556,7 +3556,7 @@ package body Sem_Eval is if Is_Static_Expression (N) and then not In_Instance and then not In_Inlined_Body - and then Ada_95 + and then Ada_Version >= Ada_95 then if Nkind (Parent (N)) = N_Defining_Identifier and then Is_Array_Type (Parent (N)) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a48a6ca0479..c5ee33c867f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -573,7 +573,7 @@ package body Sem_Prag is procedure Check_Ada_83_Warning is begin - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) pragma& is non-standard?", N); end if; end Check_Ada_83_Warning; @@ -762,7 +762,9 @@ package body Sem_Prag is -- pragmas like Import in Ada 83 mode. They will of course be -- flagged with warnings as usual, but will not cause errors. - elsif Ada_83 and then Nkind (Argx) = N_String_Literal then + elsif Ada_Version = Ada_83 + and then Nkind (Argx) = N_String_Literal + then return; -- Static expression that raises Constraint_Error. This has @@ -3973,12 +3975,11 @@ package body Sem_Prag is -- pragma Ada_83; -- Note: this pragma also has some specific processing in Par.Prag - -- because we want to set the Ada 83 mode switch during parsing. + -- because we want to set the Ada version mode during parsing. when Pragma_Ada_83 => GNAT_Pragma; - Ada_83 := True; - Ada_95 := False; + Ada_Version := Ada_83; Check_Arg_Count (0); ------------ @@ -3988,12 +3989,25 @@ package body Sem_Prag is -- pragma Ada_95; -- Note: this pragma also has some specific processing in Par.Prag - -- because we want to set the Ada 83 mode switch during parsing. + -- because we want to set the Ada 83 version mode during parsing. when Pragma_Ada_95 => GNAT_Pragma; - Ada_83 := False; - Ada_95 := True; + Ada_Version := Ada_95; + Check_Arg_Count (0); + + ------------ + -- Ada_05 -- + ------------ + + -- pragma Ada_05; + + -- Note: this pragma also has some specific processing in Par.Prag + -- because we want to set the Ada 83 version mode during parsing. + + when Pragma_Ada_05 => + GNAT_Pragma; + Ada_Version := Ada_05; Check_Arg_Count (0); ---------------------- @@ -5265,7 +5279,7 @@ package body Sem_Prag is -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this -- placement rule does not apply. - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Citem := Next (N); while Present (Citem) loop @@ -5934,7 +5948,14 @@ package body Sem_Prag is Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); - Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On); + + if Chars (Expression (Arg1)) = Name_On then + Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + else + Extensions_Allowed := False; + Ada_Version := Ada_Version_Type'Min (Ada_Version, Ada_95); + end if; -------------- -- External -- @@ -10040,6 +10061,7 @@ package body Sem_Prag is Pragma_Abort_Defer => -1, Pragma_Ada_83 => -1, Pragma_Ada_95 => -1, + Pragma_Ada_05 => -1, Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 275e9584993..0dcea1dfa9a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -163,8 +163,7 @@ package body Sem_Res is function Operator_Kind (Op_Name : Name_Id; - Is_Binary : Boolean) - return Node_Kind; + Is_Binary : Boolean) return Node_Kind; -- Utility to map the name of an operator into the corresponding Node. Used -- by other node rewriting procedures. @@ -198,9 +197,12 @@ package body Sem_Res is -- that operands are resolved properly. Recall that predefined operators -- do not have a full signature and special resolution rules apply. - procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id); + procedure Rewrite_Renamed_Operator + (N : Node_Id; + Op : Entity_Id; + Typ : Entity_Id); -- An operator can rename another, e.g. in an instantiation. In that - -- case, the proper operator node must be constructed. + -- case, the proper operator node must be constructed and resolved. procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); -- The String_Literal_Subtype is built for all strings that are not @@ -219,8 +221,7 @@ package body Sem_Res is function Valid_Conversion (N : Node_Id; Target : Entity_Id; - Operand : Node_Id) - return Boolean; + Operand : Node_Id) return Boolean; -- Verify legality rules given in 4.6 (8-23). Target is the target -- type of the conversion, which may be an implicit conversion of -- an actual parameter to an anonymous access type (in which case @@ -1252,8 +1253,7 @@ package body Sem_Res is function Operator_Kind (Op_Name : Name_Id; - Is_Binary : Boolean) - return Node_Kind + Is_Binary : Boolean) return Node_Kind is Kind : Node_Kind; @@ -2067,28 +2067,6 @@ package body Sem_Res is -- Here we have an acceptable interpretation for the context else - -- A user-defined operator is tranformed into a function call at - -- this point, so that further processing knows that operators are - -- really operators (i.e. are predefined operators). User-defined - -- operators that are intrinsic are just renamings of the predefined - -- ones, and need not be turned into calls either, but if they rename - -- a different operator, we must transform the node accordingly. - -- Instantiations of Unchecked_Conversion are intrinsic but are - -- treated as functions, even if given an operator designator. - - if Nkind (N) in N_Op - and then Present (Entity (N)) - and then Ekind (Entity (N)) /= E_Operator - then - - if not Is_Predefined_Op (Entity (N)) then - Rewrite_Operator_As_Call (N, Entity (N)); - - elsif Present (Alias (Entity (N))) then - Rewrite_Renamed_Operator (N, Alias (Entity (N))); - end if; - end if; - -- Propagate type information and normalize tree for various -- predefined operations. If the context only imposes a class of -- types, rather than a specific type, propagate the actual type @@ -2115,6 +2093,35 @@ package body Sem_Res is end if; end if; + -- A user-defined operator is tranformed into a function call at + -- this point, so that further processing knows that operators are + -- really operators (i.e. are predefined operators). User-defined + -- operators that are intrinsic are just renamings of the predefined + -- ones, and need not be turned into calls either, but if they rename + -- a different operator, we must transform the node accordingly. + -- Instantiations of Unchecked_Conversion are intrinsic but are + -- treated as functions, even if given an operator designator. + + if Nkind (N) in N_Op + and then Present (Entity (N)) + and then Ekind (Entity (N)) /= E_Operator + then + + if not Is_Predefined_Op (Entity (N)) then + Rewrite_Operator_As_Call (N, Entity (N)); + + elsif Present (Alias (Entity (N))) then + Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); + + -- If the node is rewritten, it will be fully resolved in + -- Rewrite_Renamed_Operator. + + if Analyzed (N) then + return; + end if; + end if; + end if; + case N_Subexpr'(Nkind (N)) is when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); @@ -2629,7 +2636,7 @@ package body Sem_Res is -- or IN OUT actual to a nested call, since this is a -- case of reading an out parameter, which is not allowed. - if Ada_83 + if Ada_Version = Ada_83 and then Is_Entity_Name (A) and then Ekind (Entity (A)) = E_Out_Parameter then @@ -2698,16 +2705,17 @@ package body Sem_Res is Apply_Range_Check (A, F_Typ); end if; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) - if Extensions_Allowed + if Ada_Version >= Ada_05 and then Is_Access_Type (F_Typ) and then (Can_Never_Be_Null (F) or else Can_Never_Be_Null (F_Typ)) then if Nkind (A) = N_Null then - Error_Msg_NE ("(Ada 0Y) not allowed for null-exclusion " & - "formal", A, F_Typ); + Error_Msg_NE + ("(Ada 2005) not allowed for " & + "null-exclusion formal", A, F_Typ); end if; end if; end if; @@ -3164,14 +3172,33 @@ package body Sem_Res is end loop; -- Reanalyze the literal with the fixed type of the context. + -- If context is Universal_Fixed, we are within a conversion, + -- leave the literal as a universal real because there is no + -- usable fixed type, and the target of the conversion plays + -- no role in the resolution. - if N = L then - Set_Analyzed (R, False); - Resolve (R, B_Typ); - else - Set_Analyzed (L, False); - Resolve (L, B_Typ); - end if; + declare + Op2 : Node_Id; + T2 : Entity_Id; + + begin + if N = L then + Op2 := R; + else + Op2 := L; + end if; + + if B_Typ = Universal_Fixed + and then Nkind (Op2) = N_Real_Literal + then + T2 := Universal_Real; + else + T2 := B_Typ; + end if; + + Set_Analyzed (Op2, False); + Resolve (Op2, T2); + end; else Resolve (N); @@ -3271,7 +3298,7 @@ package body Sem_Res is Set_Etype (R, Any_Type); else - if Ada_83 + if Ada_Version = Ada_83 and then Etype (N) = Universal_Fixed and then Nkind (Parent (N)) /= N_Type_Conversion and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion @@ -4161,7 +4188,7 @@ package body Sem_Res is Error_Msg_N ("illegal use of generic function", N); elsif Ekind (E) = E_Out_Parameter - and then Ada_83 + and then Ada_Version = Ada_83 and then (Nkind (Parent (N)) in N_Op or else (Nkind (Parent (N)) = N_Assignment_Statement and then N = Expression (Parent (N))) @@ -5009,7 +5036,7 @@ package body Sem_Res is if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); else - Save_Interps (Right_Opnd (N), Arg1); + Save_Interps (Right_Opnd (N), Arg2); end if; Rewrite (Left_Opnd (N), Arg1); @@ -5170,13 +5197,12 @@ package body Sem_Res is procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin - -- For now allow circumvention of the restriction against - -- anonymous null access values via a debug switch to allow - -- for easier transition. + -- Handle restriction against anonymous null access values + -- This restriction can be turned off using -gnatdh. - -- Ada 0Y (AI-231): Remove restriction + -- Ada 2005 (AI-231): Remove restriction - if not Extensions_Allowed + if Ada_Version < Ada_05 and then not Debug_Flag_J and then Ekind (Typ) = E_Anonymous_Access_Type and then Comes_From_Source (N) @@ -6486,17 +6512,23 @@ package body Sem_Res is -- Rewrite_Renamed_Operator -- ------------------------------ - procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is + procedure Rewrite_Renamed_Operator + (N : Node_Id; + Op : Entity_Id; + Typ : Entity_Id) + is Nam : constant Name_Id := Chars (Op); Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; Op_Node : Node_Id; begin -- Rewrite the operator node using the real operator, not its - -- renaming. Exclude user-defined intrinsic operations, which - -- are treated separately. + -- renaming. Exclude user-defined intrinsic operations of the same + -- name, which are treated separately and rewritten as calls. - if Ekind (Op) /= E_Function then + if Ekind (Op) /= E_Function + or else Chars (N) /= Nam + then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); @@ -6514,6 +6546,36 @@ package body Sem_Res is end if; Rewrite (N, Op_Node); + + -- If the context type is private, add the appropriate conversions + -- so that the operator is applied to the full view. This is done + -- in the routines that resolve intrinsic operators, + + if Is_Intrinsic_Subprogram (Op) + and then Is_Private_Type (Typ) + then + case Nkind (N) is + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | + N_Op_Expon | N_Op_Mod | N_Op_Rem => + Resolve_Intrinsic_Operator (N, Typ); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + Resolve_Intrinsic_Unary_Operator (N, Typ); + + when others => + Resolve (N, Typ); + end case; + end if; + + elsif Ekind (Op) = E_Function + and then Is_Intrinsic_Subprogram (Op) + then + -- Operator renames a user-defined operator of the same name. Use + -- the original operator in the node, which is the one that gigi + -- knows about. + + Set_Entity (N, Op); + Set_Is_Overloaded (N, False); end if; end Rewrite_Renamed_Operator; @@ -6677,7 +6739,6 @@ package body Sem_Res is -- Look for visible fixed type declarations in the context. Item := First (Context_Items (Cunit (Current_Sem_Unit))); - while Present (Item) loop if Nkind (Item) = N_With_Clause then Scop := Entity (Name (Item)); @@ -6721,22 +6782,19 @@ package body Sem_Res is function Valid_Conversion (N : Node_Id; Target : Entity_Id; - Operand : Node_Id) - return Boolean + Operand : Node_Id) return Boolean is Target_Type : constant Entity_Id := Base_Type (Target); Opnd_Type : Entity_Id := Etype (Operand); function Conversion_Check (Valid : Boolean; - Msg : String) - return Boolean; + Msg : String) return Boolean; -- Little routine to post Msg if Valid is False, returns Valid value function Valid_Tagged_Conversion (Target_Type : Entity_Id; - Opnd_Type : Entity_Id) - return Boolean; + Opnd_Type : Entity_Id) return Boolean; -- Specifically test for validity of tagged conversions ---------------------- @@ -6745,8 +6803,7 @@ package body Sem_Res is function Conversion_Check (Valid : Boolean; - Msg : String) - return Boolean + Msg : String) return Boolean is begin if not Valid then @@ -6762,8 +6819,7 @@ package body Sem_Res is function Valid_Tagged_Conversion (Target_Type : Entity_Id; - Opnd_Type : Entity_Id) - return Boolean + Opnd_Type : Entity_Id) return Boolean is begin -- Upward conversions are allowed (RM 4.6(22)). diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 5da129f9294..cc3f63f65f5 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -731,8 +731,8 @@ package body Sem_Type is then return True; - -- Ada 0Y (AI-254): An Anonymous_Access_To_Subprogram is compatible with - -- itself, or with an anonymous type created for an attribute + -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible + -- with itself, or with an anonymous type created for an attribute -- reference Access. elsif (Ekind (Base_Type (T1)) = E_Anonymous_Access_Subprogram_Type @@ -845,7 +845,7 @@ package body Sem_Type is then return True; - -- Ada 0Y (AI-50217): Additional branches to make the shadow entity + -- Ada 2005 (AI-50217): Additional branches to make the shadow entity -- compatible with its real entity. elsif From_With_Type (T1) then @@ -1375,11 +1375,10 @@ package body Sem_Type is if Is_Fixed_Point_Type (Typ) and then (Chars (Nam1) = Name_Op_Multiply or else Chars (Nam1) = Name_Op_Divide) - and then Ada_83 + and then Ada_Version = Ada_83 then if It2.Nam = Predef_Subp then return It1; - else return It2; end if; @@ -1491,18 +1490,18 @@ package body Sem_Type is elsif T = Universal_Fixed then return Etype (R); - -- Ada 0Y (AI-230): Support the following operators: + -- Ada 2005 (AI-230): Support the following operators: -- function "=" (L, R : universal_access) return Boolean; -- function "/=" (L, R : universal_access) return Boolean; - elsif Extensions_Allowed + elsif Ada_Version >= Ada_05 and then Ekind (Etype (L)) = E_Anonymous_Access_Type and then Is_Access_Type (Etype (R)) then return Etype (L); - elsif Extensions_Allowed + elsif Ada_Version >= Ada_05 and then Ekind (Etype (R)) = E_Anonymous_Access_Type and then Is_Access_Type (Etype (L)) then @@ -2019,9 +2018,9 @@ package body Sem_Type is and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T) and then (not Is_Fixed_Point_Type (T) - or else Ada_83)) + or else Ada_Version = Ada_83)) - -- Mixed_Mode operations on fixed-point types. + -- Mixed_Mode operations on fixed-point types or else (Base_Type (T1) = Base_Type (T) and then Base_Type (T2) = Base_Type (Standard_Integer) @@ -2039,9 +2038,9 @@ package body Sem_Type is and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T) and then (not Is_Fixed_Point_Type (T) - or else Ada_83)) + or else Ada_Version = Ada_83)) - -- Mixed_Mode operations on fixed-point types. + -- Mixed_Mode operations on fixed-point types or else (Base_Type (T1) = Base_Type (T) and then Base_Type (T2) = Base_Type (Standard_Integer) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 446a834bed5..22c5f885dd7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -820,7 +820,7 @@ package body Sem_Util is begin if Ekind (T) = E_Incomplete_Type then - -- Ada0Y (AI-50217): If the type is available through a limited + -- Ada 2005 (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) @@ -1093,7 +1093,9 @@ package body Sem_Util is -- the body of an instance, constraint_checks are only warnings. -- We also make this a warning if the Warn parameter is set. - elsif Warn or else (Ada_83 and then Comes_From_Source (N)) then + elsif Warn + or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) + then Msgl := Msgl + 1; Msgc (Msgl) := '?'; Wmsg := True; @@ -6219,15 +6221,15 @@ 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 + -- Ada 2005 (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 - and then not Is_Array_Type (Scope (Btyp)) -- Ada 0Y (AI-230) - and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 0Y (AI-230) + and then not Is_Array_Type (Scope (Btyp)) -- Ada 2005 (AI-230) + and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 2005 (AI-230) then return Scope_Depth (Standard_Standard); end if; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 970213e7905..34561de049c 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1483,6 +1483,23 @@ package body Sem_Warn is then if Warn_On_Modified_Unread and then not Is_Imported (E) + + -- Suppress the message for aliased, renamed + -- and access variables since there may be + -- other entities that read the memory location. + + and then not Is_Aliased (E) + and then No (Renamed_Object (E)) + and then not (Is_Access_Type (Etype (E)) + or else + + -- Case of private access type, must examine the + -- full view due to visibility issues. + + (Is_Private_Type (Etype (E)) + and then + Is_Access_Type + (Full_View (Etype (E))))) then Error_Msg_N ("variable & is assigned but never read?", E); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 63a6e0c243e..04853f28f1d 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1898,8 +1898,8 @@ package Sinfo is -- directly in the tree as a subtype mark. The N_Subtype_Indication -- node is used only if a constraint is present. - -- Note: [For Ada 0Y (AI-231)]: Because Ada 0Y extends this rule with - -- the null-exclusion part (see AI-231), we had to introduce a new + -- Note: [For Ada 2005 (AI-231)]: Because Ada 2005 extends this rule + -- with the null-exclusion part (see AI-231), we had to introduce a new -- attribute in all the parents of subtype_indication nodes to indicate -- if the null-exclusion is present. @@ -2340,8 +2340,8 @@ package Sinfo is -- 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 + -- Access_Definition is an optional field that gives support to + -- Ada 2005 (AI-230). The parser generates nodes that have either the -- Subtype_Indication field or else the Access_Definition field. -- N_Component_Definition @@ -2707,7 +2707,7 @@ package Sinfo is -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK -- | ACCESS_TO_SUBPROGRAM_DEFINITION - -- Note: access to subprograms are an Ada 0Y (AI-254) extension + -- Note: access to subprograms are an Ada 2005 (AI-254) extension -- N_Access_Definition -- Sloc points to ACCESS @@ -3063,7 +3063,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 Ada 0Y (AI-287). + -- to Ada 2005 (AI-287). ------------------------------------ -- 4.3.1 Commponent Choice List -- @@ -4331,7 +4331,7 @@ package Sinfo is -- | 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 + -- Ada 2005 (AI-230). The parser generates nodes that have either the -- Subtype_Indication field or else the Access_Definition field. -- N_Object_Renaming_Declaration @@ -5151,7 +5151,7 @@ package Sinfo is -- No_Entities_Ref_In_Spec (Flag8-Sem) -- Note: Limited_Present and Limited_View_Installed give support to - -- Ada 0Y (AI-50217). + -- Ada 2005 (AI-50217). -- Similarly, Private_Present gives support to AI-50262. ---------------------- diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index ca49ae76de4..b8c20bba92b 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -166,6 +166,7 @@ package body Snames is "Oexpon#" & "ada_83#" & "ada_95#" & + "ada_05#" & "c_pass_by_copy#" & "compile_time_warning#" & "component_alignment#" & @@ -652,6 +653,7 @@ package body Snames is "linker#" & "local_configuration_pragmas#" & "locally_removed_files#" & + "metrics#" & "naming#" & "object_dir#" & "pretty_printer#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index d4a5ad4dc12..ceaa7239fb8 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -318,55 +318,56 @@ package Snames is Name_Ada_83 : constant Name_Id := N + 107; -- GNAT Name_Ada_95 : constant Name_Id := N + 108; -- GNAT - Name_C_Pass_By_Copy : constant Name_Id := N + 109; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 110; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 111; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 112; -- GNAT - Name_Discard_Names : constant Name_Id := N + 113; - Name_Elaboration_Checks : constant Name_Id := N + 114; -- GNAT - Name_Eliminate : constant Name_Id := N + 115; -- GNAT - Name_Explicit_Overriding : constant Name_Id := N + 116; - Name_Extend_System : constant Name_Id := N + 117; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 118; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 119; -- GNAT - Name_Float_Representation : constant Name_Id := N + 120; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 121; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 122; -- GNAT - Name_License : constant Name_Id := N + 123; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 124; - Name_Long_Float : constant Name_Id := N + 125; -- VMS - Name_No_Run_Time : constant Name_Id := N + 126; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 127; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 128; - Name_Polling : constant Name_Id := N + 129; -- GNAT - Name_Persistent_Data : constant Name_Id := N + 130; -- GNAT - Name_Persistent_Object : constant Name_Id := N + 131; -- GNAT - Name_Profile : constant Name_Id := N + 132; -- Ada0Y - Name_Propagate_Exceptions : constant Name_Id := N + 133; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 134; - Name_Ravenscar : constant Name_Id := N + 135; - Name_Restricted_Run_Time : constant Name_Id := N + 136; - Name_Restrictions : constant Name_Id := N + 137; - Name_Restriction_Warnings : constant Name_Id := N + 138; -- GNAT - Name_Reviewable : constant Name_Id := N + 139; - Name_Source_File_Name : constant Name_Id := N + 140; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 141; -- GNAT - Name_Style_Checks : constant Name_Id := N + 142; -- GNAT - Name_Suppress : constant Name_Id := N + 143; - Name_Suppress_Exception_Locations : constant Name_Id := N + 144; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 145; - Name_Universal_Data : constant Name_Id := N + 146; -- AAMP - Name_Unsuppress : constant Name_Id := N + 147; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 148; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 149; -- GNAT - Name_Warnings : constant Name_Id := N + 150; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 150; + Name_Ada_05 : constant Name_Id := N + 109; -- GNAT + Name_C_Pass_By_Copy : constant Name_Id := N + 110; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 111; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 112; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 113; -- GNAT + Name_Discard_Names : constant Name_Id := N + 114; + Name_Elaboration_Checks : constant Name_Id := N + 115; -- GNAT + Name_Eliminate : constant Name_Id := N + 116; -- GNAT + Name_Explicit_Overriding : constant Name_Id := N + 117; + Name_Extend_System : constant Name_Id := N + 118; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 119; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 120; -- GNAT + Name_Float_Representation : constant Name_Id := N + 121; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 122; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 123; -- GNAT + Name_License : constant Name_Id := N + 124; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 125; + Name_Long_Float : constant Name_Id := N + 126; -- VMS + Name_No_Run_Time : constant Name_Id := N + 127; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 128; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 129; + Name_Polling : constant Name_Id := N + 130; -- GNAT + Name_Persistent_Data : constant Name_Id := N + 131; -- GNAT + Name_Persistent_Object : constant Name_Id := N + 132; -- GNAT + Name_Profile : constant Name_Id := N + 133; -- Ada0Y + Name_Propagate_Exceptions : constant Name_Id := N + 134; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 135; + Name_Ravenscar : constant Name_Id := N + 136; + Name_Restricted_Run_Time : constant Name_Id := N + 137; + Name_Restrictions : constant Name_Id := N + 138; + Name_Restriction_Warnings : constant Name_Id := N + 139; -- GNAT + Name_Reviewable : constant Name_Id := N + 140; + Name_Source_File_Name : constant Name_Id := N + 141; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 142; -- GNAT + Name_Style_Checks : constant Name_Id := N + 143; -- GNAT + Name_Suppress : constant Name_Id := N + 144; + Name_Suppress_Exception_Locations : constant Name_Id := N + 145; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 146; + Name_Universal_Data : constant Name_Id := N + 147; -- AAMP + Name_Unsuppress : constant Name_Id := N + 148; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 149; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 150; -- GNAT + Name_Warnings : constant Name_Id := N + 151; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 151; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 151; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 152; - Name_Annotate : constant Name_Id := N + 153; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 152; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 153; + Name_Annotate : constant Name_Id := N + 154; -- 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 @@ -374,78 +375,78 @@ package Snames is -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. -- AST_Entry is a VMS specific pragma. - Name_Assert : constant Name_Id := N + 154; -- GNAT - Name_Asynchronous : constant Name_Id := N + 155; - Name_Atomic : constant Name_Id := N + 156; - Name_Atomic_Components : constant Name_Id := N + 157; - Name_Attach_Handler : constant Name_Id := N + 158; - Name_Comment : constant Name_Id := N + 159; -- GNAT - Name_Common_Object : constant Name_Id := N + 160; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 161; -- GNAT - Name_Controlled : constant Name_Id := N + 162; - Name_Convention : constant Name_Id := N + 163; - Name_CPP_Class : constant Name_Id := N + 164; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 165; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 166; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 167; -- GNAT - Name_Debug : constant Name_Id := N + 168; -- GNAT - Name_Elaborate : constant Name_Id := N + 169; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 170; - Name_Elaborate_Body : constant Name_Id := N + 171; - Name_Export : constant Name_Id := N + 172; - Name_Export_Exception : constant Name_Id := N + 173; -- VMS - Name_Export_Function : constant Name_Id := N + 174; -- GNAT - Name_Export_Object : constant Name_Id := N + 175; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 176; -- GNAT - Name_Export_Value : constant Name_Id := N + 177; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 178; -- GNAT - Name_External : constant Name_Id := N + 179; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 180; -- GNAT - Name_Ident : constant Name_Id := N + 181; -- VMS - Name_Import : constant Name_Id := N + 182; - Name_Import_Exception : constant Name_Id := N + 183; -- VMS - Name_Import_Function : constant Name_Id := N + 184; -- GNAT - Name_Import_Object : constant Name_Id := N + 185; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 186; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 187; -- GNAT - Name_Inline : constant Name_Id := N + 188; - Name_Inline_Always : constant Name_Id := N + 189; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 190; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 191; - Name_Interface : constant Name_Id := N + 192; -- Ada 83 - Name_Interface_Name : constant Name_Id := N + 193; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 194; - Name_Interrupt_Priority : constant Name_Id := N + 195; - Name_Java_Constructor : constant Name_Id := N + 196; -- GNAT - Name_Java_Interface : constant Name_Id := N + 197; -- GNAT - Name_Keep_Names : constant Name_Id := N + 198; -- GNAT - Name_Link_With : constant Name_Id := N + 199; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 200; -- GNAT - Name_Linker_Options : constant Name_Id := N + 201; - Name_Linker_Section : constant Name_Id := N + 202; -- GNAT - Name_List : constant Name_Id := N + 203; - Name_Machine_Attribute : constant Name_Id := N + 204; -- GNAT - Name_Main : constant Name_Id := N + 205; -- GNAT - Name_Main_Storage : constant Name_Id := N + 206; -- GNAT - Name_Memory_Size : constant Name_Id := N + 207; -- Ada 83 - Name_No_Return : constant Name_Id := N + 208; -- GNAT - Name_Obsolescent : constant Name_Id := N + 209; -- GNAT - Name_Optimize : constant Name_Id := N + 210; - Name_Optional_Overriding : constant Name_Id := N + 211; - Name_Overriding : constant Name_Id := N + 212; - Name_Pack : constant Name_Id := N + 213; - Name_Page : constant Name_Id := N + 214; - Name_Passive : constant Name_Id := N + 215; -- GNAT - Name_Preelaborate : constant Name_Id := N + 216; - Name_Priority : constant Name_Id := N + 217; - Name_Psect_Object : constant Name_Id := N + 218; -- VMS - Name_Pure : constant Name_Id := N + 219; - Name_Pure_Function : constant Name_Id := N + 220; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 221; - Name_Remote_Types : constant Name_Id := N + 222; - Name_Share_Generic : constant Name_Id := N + 223; -- GNAT - Name_Shared : constant Name_Id := N + 224; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 225; + Name_Assert : constant Name_Id := N + 155; -- GNAT + Name_Asynchronous : constant Name_Id := N + 156; + Name_Atomic : constant Name_Id := N + 157; + Name_Atomic_Components : constant Name_Id := N + 158; + Name_Attach_Handler : constant Name_Id := N + 159; + Name_Comment : constant Name_Id := N + 160; -- GNAT + Name_Common_Object : constant Name_Id := N + 161; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 162; -- GNAT + Name_Controlled : constant Name_Id := N + 163; + Name_Convention : constant Name_Id := N + 164; + Name_CPP_Class : constant Name_Id := N + 165; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 166; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 167; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 168; -- GNAT + Name_Debug : constant Name_Id := N + 169; -- GNAT + Name_Elaborate : constant Name_Id := N + 170; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 171; + Name_Elaborate_Body : constant Name_Id := N + 172; + Name_Export : constant Name_Id := N + 173; + Name_Export_Exception : constant Name_Id := N + 174; -- VMS + Name_Export_Function : constant Name_Id := N + 175; -- GNAT + Name_Export_Object : constant Name_Id := N + 176; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 177; -- GNAT + Name_Export_Value : constant Name_Id := N + 178; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 179; -- GNAT + Name_External : constant Name_Id := N + 180; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 181; -- GNAT + Name_Ident : constant Name_Id := N + 182; -- VMS + Name_Import : constant Name_Id := N + 183; + Name_Import_Exception : constant Name_Id := N + 184; -- VMS + Name_Import_Function : constant Name_Id := N + 185; -- GNAT + Name_Import_Object : constant Name_Id := N + 186; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 187; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 188; -- GNAT + Name_Inline : constant Name_Id := N + 189; + Name_Inline_Always : constant Name_Id := N + 190; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 191; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 192; + Name_Interface : constant Name_Id := N + 193; -- Ada 83 + Name_Interface_Name : constant Name_Id := N + 194; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 195; + Name_Interrupt_Priority : constant Name_Id := N + 196; + Name_Java_Constructor : constant Name_Id := N + 197; -- GNAT + Name_Java_Interface : constant Name_Id := N + 198; -- GNAT + Name_Keep_Names : constant Name_Id := N + 199; -- GNAT + Name_Link_With : constant Name_Id := N + 200; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 201; -- GNAT + Name_Linker_Options : constant Name_Id := N + 202; + Name_Linker_Section : constant Name_Id := N + 203; -- GNAT + Name_List : constant Name_Id := N + 204; + Name_Machine_Attribute : constant Name_Id := N + 205; -- GNAT + Name_Main : constant Name_Id := N + 206; -- GNAT + Name_Main_Storage : constant Name_Id := N + 207; -- GNAT + Name_Memory_Size : constant Name_Id := N + 208; -- Ada 83 + Name_No_Return : constant Name_Id := N + 209; -- GNAT + Name_Obsolescent : constant Name_Id := N + 210; -- GNAT + Name_Optimize : constant Name_Id := N + 211; + Name_Optional_Overriding : constant Name_Id := N + 212; + Name_Overriding : constant Name_Id := N + 213; + Name_Pack : constant Name_Id := N + 214; + Name_Page : constant Name_Id := N + 215; + Name_Passive : constant Name_Id := N + 216; -- GNAT + Name_Preelaborate : constant Name_Id := N + 217; + Name_Priority : constant Name_Id := N + 218; + Name_Psect_Object : constant Name_Id := N + 219; -- VMS + Name_Pure : constant Name_Id := N + 220; + Name_Pure_Function : constant Name_Id := N + 221; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 222; + Name_Remote_Types : constant Name_Id := N + 223; + Name_Share_Generic : constant Name_Id := N + 224; -- GNAT + Name_Shared : constant Name_Id := N + 225; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 226; -- Note: Storage_Size is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -455,27 +456,27 @@ package Snames is -- 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 + 226; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 227; -- GNAT - Name_Subtitle : constant Name_Id := N + 228; -- GNAT - Name_Suppress_All : constant Name_Id := N + 229; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 230; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 231; -- GNAT - Name_System_Name : constant Name_Id := N + 232; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 233; -- GNAT - Name_Task_Name : constant Name_Id := N + 234; -- GNAT - Name_Task_Storage : constant Name_Id := N + 235; -- VMS - Name_Thread_Body : constant Name_Id := N + 236; -- GNAT - Name_Time_Slice : constant Name_Id := N + 237; -- GNAT - Name_Title : constant Name_Id := N + 238; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 239; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 240; -- GNAT - Name_Unreferenced : constant Name_Id := N + 241; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 242; -- GNAT - Name_Volatile : constant Name_Id := N + 243; - Name_Volatile_Components : constant Name_Id := N + 244; - Name_Weak_External : constant Name_Id := N + 245; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 245; + Name_Source_Reference : constant Name_Id := N + 227; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 228; -- GNAT + Name_Subtitle : constant Name_Id := N + 229; -- GNAT + Name_Suppress_All : constant Name_Id := N + 230; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 231; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 232; -- GNAT + Name_System_Name : constant Name_Id := N + 233; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 234; -- GNAT + Name_Task_Name : constant Name_Id := N + 235; -- GNAT + Name_Task_Storage : constant Name_Id := N + 236; -- VMS + Name_Thread_Body : constant Name_Id := N + 237; -- GNAT + Name_Time_Slice : constant Name_Id := N + 238; -- GNAT + Name_Title : constant Name_Id := N + 239; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 240; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 241; -- GNAT + Name_Unreferenced : constant Name_Id := N + 242; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 243; -- GNAT + Name_Volatile : constant Name_Id := N + 244; + Name_Volatile_Components : constant Name_Id := N + 245; + Name_Weak_External : constant Name_Id := N + 246; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 246; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -486,105 +487,105 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 246; - Name_Ada : constant Name_Id := N + 246; - Name_Assembler : constant Name_Id := N + 247; - Name_COBOL : constant Name_Id := N + 248; - Name_CPP : constant Name_Id := N + 249; - Name_Fortran : constant Name_Id := N + 250; - Name_Intrinsic : constant Name_Id := N + 251; - Name_Java : constant Name_Id := N + 252; - Name_Stdcall : constant Name_Id := N + 253; - Name_Stubbed : constant Name_Id := N + 254; - Last_Convention_Name : constant Name_Id := N + 254; + First_Convention_Name : constant Name_Id := N + 247; + Name_Ada : constant Name_Id := N + 247; + Name_Assembler : constant Name_Id := N + 248; + Name_COBOL : constant Name_Id := N + 249; + Name_CPP : constant Name_Id := N + 250; + Name_Fortran : constant Name_Id := N + 251; + Name_Intrinsic : constant Name_Id := N + 252; + Name_Java : constant Name_Id := N + 253; + Name_Stdcall : constant Name_Id := N + 254; + Name_Stubbed : constant Name_Id := N + 255; + Last_Convention_Name : constant Name_Id := N + 255; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 255; - Name_Assembly : constant Name_Id := N + 256; + Name_Asm : constant Name_Id := N + 256; + Name_Assembly : constant Name_Id := N + 257; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 257; + Name_Default : constant Name_Id := N + 258; -- Name_Exernal (previously defined as pragma) -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 258; - Name_Win32 : constant Name_Id := N + 259; + Name_DLL : constant Name_Id := N + 259; + Name_Win32 : constant Name_Id := N + 260; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 260; - Name_Body_File_Name : constant Name_Id := N + 261; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 262; - Name_Casing : constant Name_Id := N + 263; - Name_Code : constant Name_Id := N + 264; - Name_Component : constant Name_Id := N + 265; - Name_Component_Size_4 : constant Name_Id := N + 266; - Name_Copy : constant Name_Id := N + 267; - Name_D_Float : constant Name_Id := N + 268; - Name_Descriptor : constant Name_Id := N + 269; - Name_Dot_Replacement : constant Name_Id := N + 270; - Name_Dynamic : constant Name_Id := N + 271; - Name_Entity : constant Name_Id := N + 272; - Name_External_Name : constant Name_Id := N + 273; - Name_First_Optional_Parameter : constant Name_Id := N + 274; - Name_Form : constant Name_Id := N + 275; - Name_G_Float : constant Name_Id := N + 276; - Name_Gcc : constant Name_Id := N + 277; - Name_Gnat : constant Name_Id := N + 278; - Name_GPL : constant Name_Id := N + 279; - Name_IEEE_Float : constant Name_Id := N + 280; - Name_Internal : constant Name_Id := N + 281; - Name_Link_Name : constant Name_Id := N + 282; - Name_Lowercase : constant Name_Id := N + 283; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 284; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 285; - Name_Max_Size : constant Name_Id := N + 286; - Name_Mechanism : constant Name_Id := N + 287; - Name_Mixedcase : constant Name_Id := N + 288; - Name_Modified_GPL : constant Name_Id := N + 289; - Name_Name : constant Name_Id := N + 290; - Name_NCA : constant Name_Id := N + 291; - Name_No : constant Name_Id := N + 292; - Name_On : constant Name_Id := N + 293; - Name_Parameter_Types : constant Name_Id := N + 294; - Name_Reference : constant Name_Id := N + 295; - Name_No_Dynamic_Attachment : constant Name_Id := N + 296; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 297; - Name_No_Requeue : constant Name_Id := N + 298; - Name_No_Requeue_Statements : constant Name_Id := N + 299; - Name_No_Task_Attributes : constant Name_Id := N + 300; - Name_No_Task_Attributes_Package : constant Name_Id := N + 301; - Name_Restricted : constant Name_Id := N + 302; - Name_Result_Mechanism : constant Name_Id := N + 303; - Name_Result_Type : constant Name_Id := N + 304; - Name_Runtime : constant Name_Id := N + 305; - Name_SB : constant Name_Id := N + 306; - Name_Secondary_Stack_Size : constant Name_Id := N + 307; - Name_Section : constant Name_Id := N + 308; - Name_Semaphore : constant Name_Id := N + 309; - Name_Simple_Barriers : constant Name_Id := N + 310; - Name_Spec_File_Name : constant Name_Id := N + 311; - Name_Static : constant Name_Id := N + 312; - Name_Stack_Size : constant Name_Id := N + 313; - Name_Subunit_File_Name : constant Name_Id := N + 314; - Name_Task_Stack_Size_Default : constant Name_Id := N + 315; - Name_Task_Type : constant Name_Id := N + 316; - Name_Time_Slicing_Enabled : constant Name_Id := N + 317; - Name_Top_Guard : constant Name_Id := N + 318; - Name_UBA : constant Name_Id := N + 319; - Name_UBS : constant Name_Id := N + 320; - Name_UBSB : constant Name_Id := N + 321; - Name_Unit_Name : constant Name_Id := N + 322; - Name_Unknown : constant Name_Id := N + 323; - Name_Unrestricted : constant Name_Id := N + 324; - Name_Uppercase : constant Name_Id := N + 325; - Name_User : constant Name_Id := N + 326; - Name_VAX_Float : constant Name_Id := N + 327; - Name_VMS : constant Name_Id := N + 328; - Name_Working_Storage : constant Name_Id := N + 329; + Name_As_Is : constant Name_Id := N + 261; + Name_Body_File_Name : constant Name_Id := N + 262; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 263; + Name_Casing : constant Name_Id := N + 264; + Name_Code : constant Name_Id := N + 265; + Name_Component : constant Name_Id := N + 266; + Name_Component_Size_4 : constant Name_Id := N + 267; + Name_Copy : constant Name_Id := N + 268; + Name_D_Float : constant Name_Id := N + 269; + Name_Descriptor : constant Name_Id := N + 270; + Name_Dot_Replacement : constant Name_Id := N + 271; + Name_Dynamic : constant Name_Id := N + 272; + Name_Entity : constant Name_Id := N + 273; + Name_External_Name : constant Name_Id := N + 274; + Name_First_Optional_Parameter : constant Name_Id := N + 275; + Name_Form : constant Name_Id := N + 276; + Name_G_Float : constant Name_Id := N + 277; + Name_Gcc : constant Name_Id := N + 278; + Name_Gnat : constant Name_Id := N + 279; + Name_GPL : constant Name_Id := N + 280; + Name_IEEE_Float : constant Name_Id := N + 281; + Name_Internal : constant Name_Id := N + 282; + Name_Link_Name : constant Name_Id := N + 283; + Name_Lowercase : constant Name_Id := N + 284; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 285; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 286; + Name_Max_Size : constant Name_Id := N + 287; + Name_Mechanism : constant Name_Id := N + 288; + Name_Mixedcase : constant Name_Id := N + 289; + Name_Modified_GPL : constant Name_Id := N + 290; + Name_Name : constant Name_Id := N + 291; + Name_NCA : constant Name_Id := N + 292; + Name_No : constant Name_Id := N + 293; + Name_On : constant Name_Id := N + 294; + Name_Parameter_Types : constant Name_Id := N + 295; + Name_Reference : constant Name_Id := N + 296; + Name_No_Dynamic_Attachment : constant Name_Id := N + 297; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 298; + Name_No_Requeue : constant Name_Id := N + 299; + Name_No_Requeue_Statements : constant Name_Id := N + 300; + Name_No_Task_Attributes : constant Name_Id := N + 301; + Name_No_Task_Attributes_Package : constant Name_Id := N + 302; + Name_Restricted : constant Name_Id := N + 303; + Name_Result_Mechanism : constant Name_Id := N + 304; + Name_Result_Type : constant Name_Id := N + 305; + Name_Runtime : constant Name_Id := N + 306; + Name_SB : constant Name_Id := N + 307; + Name_Secondary_Stack_Size : constant Name_Id := N + 308; + Name_Section : constant Name_Id := N + 309; + Name_Semaphore : constant Name_Id := N + 310; + Name_Simple_Barriers : constant Name_Id := N + 311; + Name_Spec_File_Name : constant Name_Id := N + 312; + Name_Static : constant Name_Id := N + 313; + Name_Stack_Size : constant Name_Id := N + 314; + Name_Subunit_File_Name : constant Name_Id := N + 315; + Name_Task_Stack_Size_Default : constant Name_Id := N + 316; + Name_Task_Type : constant Name_Id := N + 317; + Name_Time_Slicing_Enabled : constant Name_Id := N + 318; + Name_Top_Guard : constant Name_Id := N + 319; + Name_UBA : constant Name_Id := N + 320; + Name_UBS : constant Name_Id := N + 321; + Name_UBSB : constant Name_Id := N + 322; + Name_Unit_Name : constant Name_Id := N + 323; + Name_Unknown : constant Name_Id := N + 324; + Name_Unrestricted : constant Name_Id := N + 325; + Name_Uppercase : constant Name_Id := N + 326; + Name_User : constant Name_Id := N + 327; + Name_VAX_Float : constant Name_Id := N + 328; + Name_VMS : constant Name_Id := N + 329; + Name_Working_Storage : constant Name_Id := N + 330; -- 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 @@ -598,158 +599,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 + 330; - Name_Abort_Signal : constant Name_Id := N + 330; -- GNAT - Name_Access : constant Name_Id := N + 331; - Name_Address : constant Name_Id := N + 332; - Name_Address_Size : constant Name_Id := N + 333; -- GNAT - Name_Aft : constant Name_Id := N + 334; - Name_Alignment : constant Name_Id := N + 335; - Name_Asm_Input : constant Name_Id := N + 336; -- GNAT - Name_Asm_Output : constant Name_Id := N + 337; -- GNAT - Name_AST_Entry : constant Name_Id := N + 338; -- VMS - Name_Bit : constant Name_Id := N + 339; -- GNAT - Name_Bit_Order : constant Name_Id := N + 340; - Name_Bit_Position : constant Name_Id := N + 341; -- GNAT - Name_Body_Version : constant Name_Id := N + 342; - Name_Callable : constant Name_Id := N + 343; - Name_Caller : constant Name_Id := N + 344; - Name_Code_Address : constant Name_Id := N + 345; -- GNAT - Name_Component_Size : constant Name_Id := N + 346; - Name_Compose : constant Name_Id := N + 347; - Name_Constrained : constant Name_Id := N + 348; - Name_Count : constant Name_Id := N + 349; - Name_Default_Bit_Order : constant Name_Id := N + 350; -- GNAT - Name_Definite : constant Name_Id := N + 351; - Name_Delta : constant Name_Id := N + 352; - Name_Denorm : constant Name_Id := N + 353; - Name_Digits : constant Name_Id := N + 354; - Name_Elaborated : constant Name_Id := N + 355; -- GNAT - Name_Emax : constant Name_Id := N + 356; -- Ada 83 - Name_Enum_Rep : constant Name_Id := N + 357; -- GNAT - Name_Epsilon : constant Name_Id := N + 358; -- Ada 83 - Name_Exponent : constant Name_Id := N + 359; - Name_External_Tag : constant Name_Id := N + 360; - Name_First : constant Name_Id := N + 361; - Name_First_Bit : constant Name_Id := N + 362; - Name_Fixed_Value : constant Name_Id := N + 363; -- GNAT - Name_Fore : constant Name_Id := N + 364; - Name_Has_Discriminants : constant Name_Id := N + 365; -- GNAT - Name_Identity : constant Name_Id := N + 366; - Name_Img : constant Name_Id := N + 367; -- GNAT - Name_Integer_Value : constant Name_Id := N + 368; -- GNAT - Name_Large : constant Name_Id := N + 369; -- Ada 83 - Name_Last : constant Name_Id := N + 370; - Name_Last_Bit : constant Name_Id := N + 371; - Name_Leading_Part : constant Name_Id := N + 372; - Name_Length : constant Name_Id := N + 373; - Name_Machine_Emax : constant Name_Id := N + 374; - Name_Machine_Emin : constant Name_Id := N + 375; - Name_Machine_Mantissa : constant Name_Id := N + 376; - Name_Machine_Overflows : constant Name_Id := N + 377; - Name_Machine_Radix : constant Name_Id := N + 378; - Name_Machine_Rounds : constant Name_Id := N + 379; - Name_Machine_Size : constant Name_Id := N + 380; -- GNAT - Name_Mantissa : constant Name_Id := N + 381; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 382; - Name_Maximum_Alignment : constant Name_Id := N + 383; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 384; -- GNAT - Name_Model_Emin : constant Name_Id := N + 385; - Name_Model_Epsilon : constant Name_Id := N + 386; - Name_Model_Mantissa : constant Name_Id := N + 387; - Name_Model_Small : constant Name_Id := N + 388; - Name_Modulus : constant Name_Id := N + 389; - Name_Null_Parameter : constant Name_Id := N + 390; -- GNAT - Name_Object_Size : constant Name_Id := N + 391; -- GNAT - Name_Partition_ID : constant Name_Id := N + 392; - Name_Passed_By_Reference : constant Name_Id := N + 393; -- GNAT - Name_Pool_Address : constant Name_Id := N + 394; - Name_Pos : constant Name_Id := N + 395; - Name_Position : constant Name_Id := N + 396; - Name_Range : constant Name_Id := N + 397; - Name_Range_Length : constant Name_Id := N + 398; -- GNAT - Name_Round : constant Name_Id := N + 399; - Name_Safe_Emax : constant Name_Id := N + 400; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 401; - Name_Safe_Large : constant Name_Id := N + 402; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 403; - Name_Safe_Small : constant Name_Id := N + 404; -- Ada 83 - Name_Scale : constant Name_Id := N + 405; - Name_Scaling : constant Name_Id := N + 406; - Name_Signed_Zeros : constant Name_Id := N + 407; - Name_Size : constant Name_Id := N + 408; - Name_Small : constant Name_Id := N + 409; - Name_Storage_Size : constant Name_Id := N + 410; - Name_Storage_Unit : constant Name_Id := N + 411; -- GNAT - Name_Tag : constant Name_Id := N + 412; - Name_Target_Name : constant Name_Id := N + 413; -- GNAT - Name_Terminated : constant Name_Id := N + 414; - Name_To_Address : constant Name_Id := N + 415; -- GNAT - Name_Type_Class : constant Name_Id := N + 416; -- GNAT - Name_UET_Address : constant Name_Id := N + 417; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 418; - Name_Unchecked_Access : constant Name_Id := N + 419; - Name_Unconstrained_Array : constant Name_Id := N + 420; - Name_Universal_Literal_String : constant Name_Id := N + 421; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 422; -- GNAT - Name_VADS_Size : constant Name_Id := N + 423; -- GNAT - Name_Val : constant Name_Id := N + 424; - Name_Valid : constant Name_Id := N + 425; - Name_Value_Size : constant Name_Id := N + 426; -- GNAT - Name_Version : constant Name_Id := N + 427; - Name_Wchar_T_Size : constant Name_Id := N + 428; -- GNAT - Name_Wide_Width : constant Name_Id := N + 429; - Name_Width : constant Name_Id := N + 430; - Name_Word_Size : constant Name_Id := N + 431; -- GNAT + First_Attribute_Name : constant Name_Id := N + 331; + Name_Abort_Signal : constant Name_Id := N + 331; -- GNAT + Name_Access : constant Name_Id := N + 332; + Name_Address : constant Name_Id := N + 333; + Name_Address_Size : constant Name_Id := N + 334; -- GNAT + Name_Aft : constant Name_Id := N + 335; + Name_Alignment : constant Name_Id := N + 336; + Name_Asm_Input : constant Name_Id := N + 337; -- GNAT + Name_Asm_Output : constant Name_Id := N + 338; -- GNAT + Name_AST_Entry : constant Name_Id := N + 339; -- VMS + Name_Bit : constant Name_Id := N + 340; -- GNAT + Name_Bit_Order : constant Name_Id := N + 341; + Name_Bit_Position : constant Name_Id := N + 342; -- GNAT + Name_Body_Version : constant Name_Id := N + 343; + Name_Callable : constant Name_Id := N + 344; + Name_Caller : constant Name_Id := N + 345; + Name_Code_Address : constant Name_Id := N + 346; -- GNAT + Name_Component_Size : constant Name_Id := N + 347; + Name_Compose : constant Name_Id := N + 348; + Name_Constrained : constant Name_Id := N + 349; + Name_Count : constant Name_Id := N + 350; + Name_Default_Bit_Order : constant Name_Id := N + 351; -- GNAT + Name_Definite : constant Name_Id := N + 352; + Name_Delta : constant Name_Id := N + 353; + Name_Denorm : constant Name_Id := N + 354; + Name_Digits : constant Name_Id := N + 355; + Name_Elaborated : constant Name_Id := N + 356; -- GNAT + Name_Emax : constant Name_Id := N + 357; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 358; -- GNAT + Name_Epsilon : constant Name_Id := N + 359; -- Ada 83 + Name_Exponent : constant Name_Id := N + 360; + Name_External_Tag : constant Name_Id := N + 361; + Name_First : constant Name_Id := N + 362; + Name_First_Bit : constant Name_Id := N + 363; + Name_Fixed_Value : constant Name_Id := N + 364; -- GNAT + Name_Fore : constant Name_Id := N + 365; + Name_Has_Discriminants : constant Name_Id := N + 366; -- GNAT + Name_Identity : constant Name_Id := N + 367; + Name_Img : constant Name_Id := N + 368; -- GNAT + Name_Integer_Value : constant Name_Id := N + 369; -- GNAT + Name_Large : constant Name_Id := N + 370; -- Ada 83 + Name_Last : constant Name_Id := N + 371; + Name_Last_Bit : constant Name_Id := N + 372; + Name_Leading_Part : constant Name_Id := N + 373; + Name_Length : constant Name_Id := N + 374; + Name_Machine_Emax : constant Name_Id := N + 375; + Name_Machine_Emin : constant Name_Id := N + 376; + Name_Machine_Mantissa : constant Name_Id := N + 377; + Name_Machine_Overflows : constant Name_Id := N + 378; + Name_Machine_Radix : constant Name_Id := N + 379; + Name_Machine_Rounds : constant Name_Id := N + 380; + Name_Machine_Size : constant Name_Id := N + 381; -- GNAT + Name_Mantissa : constant Name_Id := N + 382; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 383; + Name_Maximum_Alignment : constant Name_Id := N + 384; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 385; -- GNAT + Name_Model_Emin : constant Name_Id := N + 386; + Name_Model_Epsilon : constant Name_Id := N + 387; + Name_Model_Mantissa : constant Name_Id := N + 388; + Name_Model_Small : constant Name_Id := N + 389; + Name_Modulus : constant Name_Id := N + 390; + Name_Null_Parameter : constant Name_Id := N + 391; -- GNAT + Name_Object_Size : constant Name_Id := N + 392; -- GNAT + Name_Partition_ID : constant Name_Id := N + 393; + Name_Passed_By_Reference : constant Name_Id := N + 394; -- GNAT + Name_Pool_Address : constant Name_Id := N + 395; + Name_Pos : constant Name_Id := N + 396; + Name_Position : constant Name_Id := N + 397; + Name_Range : constant Name_Id := N + 398; + Name_Range_Length : constant Name_Id := N + 399; -- GNAT + Name_Round : constant Name_Id := N + 400; + Name_Safe_Emax : constant Name_Id := N + 401; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 402; + Name_Safe_Large : constant Name_Id := N + 403; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 404; + Name_Safe_Small : constant Name_Id := N + 405; -- Ada 83 + Name_Scale : constant Name_Id := N + 406; + Name_Scaling : constant Name_Id := N + 407; + Name_Signed_Zeros : constant Name_Id := N + 408; + Name_Size : constant Name_Id := N + 409; + Name_Small : constant Name_Id := N + 410; + Name_Storage_Size : constant Name_Id := N + 411; + Name_Storage_Unit : constant Name_Id := N + 412; -- GNAT + Name_Tag : constant Name_Id := N + 413; + Name_Target_Name : constant Name_Id := N + 414; -- GNAT + Name_Terminated : constant Name_Id := N + 415; + Name_To_Address : constant Name_Id := N + 416; -- GNAT + Name_Type_Class : constant Name_Id := N + 417; -- GNAT + Name_UET_Address : constant Name_Id := N + 418; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 419; + Name_Unchecked_Access : constant Name_Id := N + 420; + Name_Unconstrained_Array : constant Name_Id := N + 421; + Name_Universal_Literal_String : constant Name_Id := N + 422; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 423; -- GNAT + Name_VADS_Size : constant Name_Id := N + 424; -- GNAT + Name_Val : constant Name_Id := N + 425; + Name_Valid : constant Name_Id := N + 426; + Name_Value_Size : constant Name_Id := N + 427; -- GNAT + Name_Version : constant Name_Id := N + 428; + Name_Wchar_T_Size : constant Name_Id := N + 429; -- GNAT + Name_Wide_Width : constant Name_Id := N + 430; + Name_Width : constant Name_Id := N + 431; + Name_Word_Size : constant Name_Id := N + 432; -- 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 + 432; - Name_Adjacent : constant Name_Id := N + 432; - Name_Ceiling : constant Name_Id := N + 433; - Name_Copy_Sign : constant Name_Id := N + 434; - Name_Floor : constant Name_Id := N + 435; - Name_Fraction : constant Name_Id := N + 436; - Name_Image : constant Name_Id := N + 437; - Name_Input : constant Name_Id := N + 438; - Name_Machine : constant Name_Id := N + 439; - Name_Max : constant Name_Id := N + 440; - Name_Min : constant Name_Id := N + 441; - Name_Model : constant Name_Id := N + 442; - Name_Pred : constant Name_Id := N + 443; - Name_Remainder : constant Name_Id := N + 444; - Name_Rounding : constant Name_Id := N + 445; - Name_Succ : constant Name_Id := N + 446; - Name_Truncation : constant Name_Id := N + 447; - Name_Value : constant Name_Id := N + 448; - Name_Wide_Image : constant Name_Id := N + 449; - Name_Wide_Value : constant Name_Id := N + 450; - Last_Renamable_Function_Attribute : constant Name_Id := N + 450; + First_Renamable_Function_Attribute : constant Name_Id := N + 433; + Name_Adjacent : constant Name_Id := N + 433; + Name_Ceiling : constant Name_Id := N + 434; + Name_Copy_Sign : constant Name_Id := N + 435; + Name_Floor : constant Name_Id := N + 436; + Name_Fraction : constant Name_Id := N + 437; + Name_Image : constant Name_Id := N + 438; + Name_Input : constant Name_Id := N + 439; + Name_Machine : constant Name_Id := N + 440; + Name_Max : constant Name_Id := N + 441; + Name_Min : constant Name_Id := N + 442; + Name_Model : constant Name_Id := N + 443; + Name_Pred : constant Name_Id := N + 444; + Name_Remainder : constant Name_Id := N + 445; + Name_Rounding : constant Name_Id := N + 446; + Name_Succ : constant Name_Id := N + 447; + Name_Truncation : constant Name_Id := N + 448; + Name_Value : constant Name_Id := N + 449; + Name_Wide_Image : constant Name_Id := N + 450; + Name_Wide_Value : constant Name_Id := N + 451; + Last_Renamable_Function_Attribute : constant Name_Id := N + 451; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 451; - Name_Output : constant Name_Id := N + 451; - Name_Read : constant Name_Id := N + 452; - Name_Write : constant Name_Id := N + 453; - Last_Procedure_Attribute : constant Name_Id := N + 453; + First_Procedure_Attribute : constant Name_Id := N + 452; + Name_Output : constant Name_Id := N + 452; + Name_Read : constant Name_Id := N + 453; + Name_Write : constant Name_Id := N + 454; + Last_Procedure_Attribute : constant Name_Id := N + 454; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 454; - Name_Elab_Body : constant Name_Id := N + 454; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 455; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 456; + First_Entity_Attribute_Name : constant Name_Id := N + 455; + Name_Elab_Body : constant Name_Id := N + 455; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 456; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 457; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 457; - Name_Base : constant Name_Id := N + 457; - Name_Class : constant Name_Id := N + 458; - Last_Type_Attribute_Name : constant Name_Id := N + 458; - Last_Entity_Attribute_Name : constant Name_Id := N + 458; - Last_Attribute_Name : constant Name_Id := N + 458; + First_Type_Attribute_Name : constant Name_Id := N + 458; + Name_Base : constant Name_Id := N + 458; + Name_Class : constant Name_Id := N + 459; + Last_Type_Attribute_Name : constant Name_Id := N + 459; + Last_Entity_Attribute_Name : constant Name_Id := N + 459; + Last_Attribute_Name : constant Name_Id := N + 459; -- Names of recognized locking policy identifiers @@ -757,10 +758,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 + 459; - Name_Ceiling_Locking : constant Name_Id := N + 459; - Name_Inheritance_Locking : constant Name_Id := N + 460; - Last_Locking_Policy_Name : constant Name_Id := N + 460; + First_Locking_Policy_Name : constant Name_Id := N + 460; + Name_Ceiling_Locking : constant Name_Id := N + 460; + Name_Inheritance_Locking : constant Name_Id := N + 461; + Last_Locking_Policy_Name : constant Name_Id := N + 461; -- Names of recognized queuing policy identifiers. @@ -768,10 +769,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 + 461; - Name_FIFO_Queuing : constant Name_Id := N + 461; - Name_Priority_Queuing : constant Name_Id := N + 462; - Last_Queuing_Policy_Name : constant Name_Id := N + 462; + First_Queuing_Policy_Name : constant Name_Id := N + 462; + Name_FIFO_Queuing : constant Name_Id := N + 462; + Name_Priority_Queuing : constant Name_Id := N + 463; + Last_Queuing_Policy_Name : constant Name_Id := N + 463; -- Names of recognized task dispatching policy identifiers @@ -779,193 +780,194 @@ 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 + 463; - Name_FIFO_Within_Priorities : constant Name_Id := N + 463; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 463; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 464; + Name_FIFO_Within_Priorities : constant Name_Id := N + 464; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 464; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 464; - Name_Access_Check : constant Name_Id := N + 464; - Name_Accessibility_Check : constant Name_Id := N + 465; - Name_Discriminant_Check : constant Name_Id := N + 466; - Name_Division_Check : constant Name_Id := N + 467; - Name_Elaboration_Check : constant Name_Id := N + 468; - Name_Index_Check : constant Name_Id := N + 469; - Name_Length_Check : constant Name_Id := N + 470; - Name_Overflow_Check : constant Name_Id := N + 471; - Name_Range_Check : constant Name_Id := N + 472; - Name_Storage_Check : constant Name_Id := N + 473; - Name_Tag_Check : constant Name_Id := N + 474; - Name_All_Checks : constant Name_Id := N + 475; - Last_Check_Name : constant Name_Id := N + 475; + First_Check_Name : constant Name_Id := N + 465; + Name_Access_Check : constant Name_Id := N + 465; + Name_Accessibility_Check : constant Name_Id := N + 466; + Name_Discriminant_Check : constant Name_Id := N + 467; + Name_Division_Check : constant Name_Id := N + 468; + Name_Elaboration_Check : constant Name_Id := N + 469; + Name_Index_Check : constant Name_Id := N + 470; + Name_Length_Check : constant Name_Id := N + 471; + Name_Overflow_Check : constant Name_Id := N + 472; + Name_Range_Check : constant Name_Id := N + 473; + Name_Storage_Check : constant Name_Id := N + 474; + Name_Tag_Check : constant Name_Id := N + 475; + Name_All_Checks : constant Name_Id := N + 476; + Last_Check_Name : constant Name_Id := N + 476; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Range). - Name_Abort : constant Name_Id := N + 476; - Name_Abs : constant Name_Id := N + 477; - Name_Accept : constant Name_Id := N + 478; - Name_And : constant Name_Id := N + 479; - Name_All : constant Name_Id := N + 480; - Name_Array : constant Name_Id := N + 481; - Name_At : constant Name_Id := N + 482; - Name_Begin : constant Name_Id := N + 483; - Name_Body : constant Name_Id := N + 484; - Name_Case : constant Name_Id := N + 485; - Name_Constant : constant Name_Id := N + 486; - Name_Declare : constant Name_Id := N + 487; - Name_Delay : constant Name_Id := N + 488; - Name_Do : constant Name_Id := N + 489; - Name_Else : constant Name_Id := N + 490; - Name_Elsif : constant Name_Id := N + 491; - Name_End : constant Name_Id := N + 492; - Name_Entry : constant Name_Id := N + 493; - Name_Exception : constant Name_Id := N + 494; - Name_Exit : constant Name_Id := N + 495; - Name_For : constant Name_Id := N + 496; - Name_Function : constant Name_Id := N + 497; - Name_Generic : constant Name_Id := N + 498; - Name_Goto : constant Name_Id := N + 499; - Name_If : constant Name_Id := N + 500; - Name_In : constant Name_Id := N + 501; - Name_Is : constant Name_Id := N + 502; - Name_Limited : constant Name_Id := N + 503; - Name_Loop : constant Name_Id := N + 504; - Name_Mod : constant Name_Id := N + 505; - Name_New : constant Name_Id := N + 506; - Name_Not : constant Name_Id := N + 507; - Name_Null : constant Name_Id := N + 508; - Name_Of : constant Name_Id := N + 509; - Name_Or : constant Name_Id := N + 510; - Name_Others : constant Name_Id := N + 511; - Name_Out : constant Name_Id := N + 512; - Name_Package : constant Name_Id := N + 513; - Name_Pragma : constant Name_Id := N + 514; - Name_Private : constant Name_Id := N + 515; - Name_Procedure : constant Name_Id := N + 516; - Name_Raise : constant Name_Id := N + 517; - Name_Record : constant Name_Id := N + 518; - Name_Rem : constant Name_Id := N + 519; - Name_Renames : constant Name_Id := N + 520; - Name_Return : constant Name_Id := N + 521; - Name_Reverse : constant Name_Id := N + 522; - Name_Select : constant Name_Id := N + 523; - Name_Separate : constant Name_Id := N + 524; - Name_Subtype : constant Name_Id := N + 525; - Name_Task : constant Name_Id := N + 526; - Name_Terminate : constant Name_Id := N + 527; - Name_Then : constant Name_Id := N + 528; - Name_Type : constant Name_Id := N + 529; - Name_Use : constant Name_Id := N + 530; - Name_When : constant Name_Id := N + 531; - Name_While : constant Name_Id := N + 532; - Name_With : constant Name_Id := N + 533; - Name_Xor : constant Name_Id := N + 534; + Name_Abort : constant Name_Id := N + 477; + Name_Abs : constant Name_Id := N + 478; + Name_Accept : constant Name_Id := N + 479; + Name_And : constant Name_Id := N + 480; + Name_All : constant Name_Id := N + 481; + Name_Array : constant Name_Id := N + 482; + Name_At : constant Name_Id := N + 483; + Name_Begin : constant Name_Id := N + 484; + Name_Body : constant Name_Id := N + 485; + Name_Case : constant Name_Id := N + 486; + Name_Constant : constant Name_Id := N + 487; + Name_Declare : constant Name_Id := N + 488; + Name_Delay : constant Name_Id := N + 489; + Name_Do : constant Name_Id := N + 490; + Name_Else : constant Name_Id := N + 491; + Name_Elsif : constant Name_Id := N + 492; + Name_End : constant Name_Id := N + 493; + Name_Entry : constant Name_Id := N + 494; + Name_Exception : constant Name_Id := N + 495; + Name_Exit : constant Name_Id := N + 496; + Name_For : constant Name_Id := N + 497; + Name_Function : constant Name_Id := N + 498; + Name_Generic : constant Name_Id := N + 499; + Name_Goto : constant Name_Id := N + 500; + Name_If : constant Name_Id := N + 501; + Name_In : constant Name_Id := N + 502; + Name_Is : constant Name_Id := N + 503; + Name_Limited : constant Name_Id := N + 504; + Name_Loop : constant Name_Id := N + 505; + Name_Mod : constant Name_Id := N + 506; + Name_New : constant Name_Id := N + 507; + Name_Not : constant Name_Id := N + 508; + Name_Null : constant Name_Id := N + 509; + Name_Of : constant Name_Id := N + 510; + Name_Or : constant Name_Id := N + 511; + Name_Others : constant Name_Id := N + 512; + Name_Out : constant Name_Id := N + 513; + Name_Package : constant Name_Id := N + 514; + Name_Pragma : constant Name_Id := N + 515; + Name_Private : constant Name_Id := N + 516; + Name_Procedure : constant Name_Id := N + 517; + Name_Raise : constant Name_Id := N + 518; + Name_Record : constant Name_Id := N + 519; + Name_Rem : constant Name_Id := N + 520; + Name_Renames : constant Name_Id := N + 521; + Name_Return : constant Name_Id := N + 522; + Name_Reverse : constant Name_Id := N + 523; + Name_Select : constant Name_Id := N + 524; + Name_Separate : constant Name_Id := N + 525; + Name_Subtype : constant Name_Id := N + 526; + Name_Task : constant Name_Id := N + 527; + Name_Terminate : constant Name_Id := N + 528; + Name_Then : constant Name_Id := N + 529; + Name_Type : constant Name_Id := N + 530; + Name_Use : constant Name_Id := N + 531; + Name_When : constant Name_Id := N + 532; + Name_While : constant Name_Id := N + 533; + Name_With : constant Name_Id := N + 534; + Name_Xor : constant Name_Id := N + 535; -- 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 + 535; - Name_Divide : constant Name_Id := N + 535; - Name_Enclosing_Entity : constant Name_Id := N + 536; - Name_Exception_Information : constant Name_Id := N + 537; - Name_Exception_Message : constant Name_Id := N + 538; - Name_Exception_Name : constant Name_Id := N + 539; - Name_File : constant Name_Id := N + 540; - Name_Import_Address : constant Name_Id := N + 541; - Name_Import_Largest_Value : constant Name_Id := N + 542; - Name_Import_Value : constant Name_Id := N + 543; - Name_Is_Negative : constant Name_Id := N + 544; - Name_Line : constant Name_Id := N + 545; - Name_Rotate_Left : constant Name_Id := N + 546; - Name_Rotate_Right : constant Name_Id := N + 547; - Name_Shift_Left : constant Name_Id := N + 548; - Name_Shift_Right : constant Name_Id := N + 549; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 550; - Name_Source_Location : constant Name_Id := N + 551; - Name_Unchecked_Conversion : constant Name_Id := N + 552; - Name_Unchecked_Deallocation : constant Name_Id := N + 553; - Name_To_Pointer : constant Name_Id := N + 554; - Last_Intrinsic_Name : constant Name_Id := N + 554; + First_Intrinsic_Name : constant Name_Id := N + 536; + Name_Divide : constant Name_Id := N + 536; + Name_Enclosing_Entity : constant Name_Id := N + 537; + Name_Exception_Information : constant Name_Id := N + 538; + Name_Exception_Message : constant Name_Id := N + 539; + Name_Exception_Name : constant Name_Id := N + 540; + Name_File : constant Name_Id := N + 541; + Name_Import_Address : constant Name_Id := N + 542; + Name_Import_Largest_Value : constant Name_Id := N + 543; + Name_Import_Value : constant Name_Id := N + 544; + Name_Is_Negative : constant Name_Id := N + 545; + Name_Line : constant Name_Id := N + 546; + Name_Rotate_Left : constant Name_Id := N + 547; + Name_Rotate_Right : constant Name_Id := N + 548; + Name_Shift_Left : constant Name_Id := N + 549; + Name_Shift_Right : constant Name_Id := N + 550; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 551; + Name_Source_Location : constant Name_Id := N + 552; + Name_Unchecked_Conversion : constant Name_Id := N + 553; + Name_Unchecked_Deallocation : constant Name_Id := N + 554; + Name_To_Pointer : constant Name_Id := N + 555; + Last_Intrinsic_Name : constant Name_Id := N + 555; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 555; - Name_Abstract : constant Name_Id := N + 555; - Name_Aliased : constant Name_Id := N + 556; - Name_Protected : constant Name_Id := N + 557; - Name_Until : constant Name_Id := N + 558; - Name_Requeue : constant Name_Id := N + 559; - Name_Tagged : constant Name_Id := N + 560; - Last_95_Reserved_Word : constant Name_Id := N + 560; + First_95_Reserved_Word : constant Name_Id := N + 556; + Name_Abstract : constant Name_Id := N + 556; + Name_Aliased : constant Name_Id := N + 557; + Name_Protected : constant Name_Id := N + 558; + Name_Until : constant Name_Id := N + 559; + Name_Requeue : constant Name_Id := N + 560; + Name_Tagged : constant Name_Id := N + 561; + Last_95_Reserved_Word : constant Name_Id := N + 561; 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 + 561; + Name_Raise_Exception : constant Name_Id := N + 562; -- Additional reserved words in GNAT Project Files -- Note that Name_External is already previously declared - Name_Binder : constant Name_Id := N + 562; - Name_Body_Suffix : constant Name_Id := N + 563; - Name_Builder : constant Name_Id := N + 564; - Name_Compiler : constant Name_Id := N + 565; - Name_Cross_Reference : constant Name_Id := N + 566; - Name_Default_Switches : constant Name_Id := N + 567; - Name_Exec_Dir : constant Name_Id := N + 568; - Name_Executable : constant Name_Id := N + 569; - Name_Executable_Suffix : constant Name_Id := N + 570; - Name_Extends : constant Name_Id := N + 571; - Name_Finder : constant Name_Id := N + 572; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 573; - Name_Gnatls : constant Name_Id := N + 574; - Name_Gnatstub : constant Name_Id := N + 575; - Name_Implementation : constant Name_Id := N + 576; - Name_Implementation_Exceptions : constant Name_Id := N + 577; - Name_Implementation_Suffix : constant Name_Id := N + 578; - Name_Languages : constant Name_Id := N + 579; - Name_Library_Dir : constant Name_Id := N + 580; - Name_Library_Auto_Init : constant Name_Id := N + 581; - Name_Library_GCC : constant Name_Id := N + 582; - Name_Library_Interface : constant Name_Id := N + 583; - Name_Library_Kind : constant Name_Id := N + 584; - Name_Library_Name : constant Name_Id := N + 585; - Name_Library_Options : constant Name_Id := N + 586; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 587; - Name_Library_Src_Dir : constant Name_Id := N + 588; - Name_Library_Symbol_File : constant Name_Id := N + 589; - Name_Library_Symbol_Policy : constant Name_Id := N + 590; - Name_Library_Version : constant Name_Id := N + 591; - Name_Linker : constant Name_Id := N + 592; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 593; - Name_Locally_Removed_Files : constant Name_Id := N + 594; - Name_Naming : constant Name_Id := N + 595; - Name_Object_Dir : constant Name_Id := N + 596; - Name_Pretty_Printer : constant Name_Id := N + 597; - Name_Project : constant Name_Id := N + 598; - Name_Separate_Suffix : constant Name_Id := N + 599; - Name_Source_Dirs : constant Name_Id := N + 600; - Name_Source_Files : constant Name_Id := N + 601; - Name_Source_List_File : constant Name_Id := N + 602; - Name_Spec : constant Name_Id := N + 603; - Name_Spec_Suffix : constant Name_Id := N + 604; - Name_Specification : constant Name_Id := N + 605; - Name_Specification_Exceptions : constant Name_Id := N + 606; - Name_Specification_Suffix : constant Name_Id := N + 607; - Name_Switches : constant Name_Id := N + 608; + Name_Binder : constant Name_Id := N + 563; + Name_Body_Suffix : constant Name_Id := N + 564; + Name_Builder : constant Name_Id := N + 565; + Name_Compiler : constant Name_Id := N + 566; + Name_Cross_Reference : constant Name_Id := N + 567; + Name_Default_Switches : constant Name_Id := N + 568; + Name_Exec_Dir : constant Name_Id := N + 569; + Name_Executable : constant Name_Id := N + 570; + Name_Executable_Suffix : constant Name_Id := N + 571; + Name_Extends : constant Name_Id := N + 572; + Name_Finder : constant Name_Id := N + 573; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 574; + Name_Gnatls : constant Name_Id := N + 575; + Name_Gnatstub : constant Name_Id := N + 576; + Name_Implementation : constant Name_Id := N + 577; + Name_Implementation_Exceptions : constant Name_Id := N + 578; + Name_Implementation_Suffix : constant Name_Id := N + 579; + Name_Languages : constant Name_Id := N + 580; + Name_Library_Dir : constant Name_Id := N + 581; + Name_Library_Auto_Init : constant Name_Id := N + 582; + Name_Library_GCC : constant Name_Id := N + 583; + Name_Library_Interface : constant Name_Id := N + 584; + Name_Library_Kind : constant Name_Id := N + 585; + Name_Library_Name : constant Name_Id := N + 586; + Name_Library_Options : constant Name_Id := N + 587; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 588; + Name_Library_Src_Dir : constant Name_Id := N + 589; + Name_Library_Symbol_File : constant Name_Id := N + 590; + Name_Library_Symbol_Policy : constant Name_Id := N + 591; + Name_Library_Version : constant Name_Id := N + 592; + Name_Linker : constant Name_Id := N + 593; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 594; + Name_Locally_Removed_Files : constant Name_Id := N + 595; + Name_Metrics : constant Name_Id := N + 596; + Name_Naming : constant Name_Id := N + 597; + Name_Object_Dir : constant Name_Id := N + 598; + Name_Pretty_Printer : constant Name_Id := N + 599; + Name_Project : constant Name_Id := N + 600; + Name_Separate_Suffix : constant Name_Id := N + 601; + Name_Source_Dirs : constant Name_Id := N + 602; + Name_Source_Files : constant Name_Id := N + 603; + Name_Source_List_File : constant Name_Id := N + 604; + Name_Spec : constant Name_Id := N + 605; + Name_Spec_Suffix : constant Name_Id := N + 606; + Name_Specification : constant Name_Id := N + 607; + Name_Specification_Exceptions : constant Name_Id := N + 608; + Name_Specification_Suffix : constant Name_Id := N + 609; + Name_Switches : constant Name_Id := N + 610; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 609; + Name_Unaligned_Valid : constant Name_Id := N + 611; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 609; + Last_Predefined_Name : constant Name_Id := N + 611; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; @@ -1170,6 +1172,7 @@ package Snames is Pragma_Ada_83, Pragma_Ada_95, + Pragma_Ada_05, Pragma_C_Pass_By_Copy, Pragma_Compile_Time_Warning, Pragma_Component_Alignment, diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 58dc87f4fad..38033dae76c 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -198,152 +198,153 @@ extern unsigned char Get_Pragma_Id (int); #define Pragma_Ada_83 0 #define Pragma_Ada_95 1 -#define Pragma_C_Pass_By_Copy 2 -#define Pragma_Compile_Time_Warning 3 -#define Pragma_Component_Alignment 4 -#define Pragma_Convention_Identifier 5 -#define Pragma_Discard_Names 6 -#define Pragma_Elaboration_Checking 7 -#define Pragma_Eliminate 8 -#define Pragma_Explicit_Overriding 9 -#define Pragma_Extend_System 10 -#define Pragma_Extensions_Allowed 11 -#define Pragma_External_Name_Casing 12 -#define Pragma_Float_Representation 13 -#define Pragma_Initialize_Scalars 14 -#define Pragma_Interrupt_State 15 -#define Pragma_License 16 -#define Pragma_Locking_Policy 17 -#define Pragma_Long_Float 18 -#define Pragma_No_Run_Time 19 -#define Pragma_No_Strict_Aliasing 20 -#define Pragma_Normalize_Scalars 21 -#define Pragma_Polling 22 -#define Pragma_Persistent_Data 23 -#define Pragma_Persistent_Object 24 -#define Pragma_Profile 25 -#define Pragma_Propagate_Exceptions 26 -#define Pragma_Queuing_Policy 27 -#define Pragma_Ravenscar 28 -#define Pragma_Restricted_Run_Time 29 -#define Pragma_Restrictions 30 -#define Pragma_Restriction_Warnings 31 -#define Pragma_Reviewable 32 -#define Pragma_Source_File_Name 33 -#define Pragma_Source_File_Name_Project 34 -#define Pragma_Style_Checks 35 -#define Pragma_Suppress 36 -#define Pragma_Suppress_Exception_Locations 37 -#define Pragma_Task_Dispatching_Policy 38 -#define Pragma_Universal_Data 39 -#define Pragma_Unsuppress 40 -#define Pragma_Use_VADS_Size 41 -#define Pragma_Validity_Checks 42 -#define Pragma_Warnings 43 +#define Pragma_Ada_05 2 +#define Pragma_C_Pass_By_Copy 3 +#define Pragma_Compile_Time_Warning 4 +#define Pragma_Component_Alignment 5 +#define Pragma_Convention_Identifier 6 +#define Pragma_Discard_Names 7 +#define Pragma_Elaboration_Checking 8 +#define Pragma_Eliminate 9 +#define Pragma_Explicit_Overriding 10 +#define Pragma_Extend_System 11 +#define Pragma_Extensions_Allowed 12 +#define Pragma_External_Name_Casing 13 +#define Pragma_Float_Representation 14 +#define Pragma_Initialize_Scalars 15 +#define Pragma_Interrupt_State 16 +#define Pragma_License 17 +#define Pragma_Locking_Policy 18 +#define Pragma_Long_Float 19 +#define Pragma_No_Run_Time 20 +#define Pragma_No_Strict_Aliasing 21 +#define Pragma_Normalize_Scalars 22 +#define Pragma_Polling 23 +#define Pragma_Persistent_Data 24 +#define Pragma_Persistent_Object 25 +#define Pragma_Profile 26 +#define Pragma_Propagate_Exceptions 27 +#define Pragma_Queuing_Policy 28 +#define Pragma_Ravenscar 29 +#define Pragma_Restricted_Run_Time 30 +#define Pragma_Restrictions 31 +#define Pragma_Restriction_Warnings 32 +#define Pragma_Reviewable 33 +#define Pragma_Source_File_Name 34 +#define Pragma_Source_File_Name_Project 35 +#define Pragma_Style_Checks 36 +#define Pragma_Suppress 37 +#define Pragma_Suppress_Exception_Locations 38 +#define Pragma_Task_Dispatching_Policy 39 +#define Pragma_Universal_Data 40 +#define Pragma_Unsuppress 41 +#define Pragma_Use_VADS_Size 42 +#define Pragma_Validity_Checks 43 +#define Pragma_Warnings 44 /* Remaining pragmas */ -#define Pragma_Abort_Defer 44 -#define Pragma_All_Calls_Remote 45 -#define Pragma_Annotate 46 -#define Pragma_Assert 47 -#define Pragma_Asynchronous 48 -#define Pragma_Atomic 49 -#define Pragma_Atomic_Components 50 -#define Pragma_Attach_Handler 51 -#define Pragma_Comment 52 -#define Pragma_Common_Object 53 -#define Pragma_Complex_Representation 54 -#define Pragma_Controlled 55 -#define Pragma_Convention 56 -#define Pragma_CPP_Class 57 -#define Pragma_CPP_Constructor 58 -#define Pragma_CPP_Virtual 59 -#define Pragma_CPP_Vtable 60 -#define Pragma_Debug 61 -#define Pragma_Elaborate 62 -#define Pragma_Elaborate_All 63 -#define Pragma_Elaborate_Body 64 -#define Pragma_Export 65 -#define Pragma_Export_Exception 66 -#define Pragma_Export_Function 67 -#define Pragma_Export_Object 68 -#define Pragma_Export_Procedure 69 -#define Pragma_Export_Value 70 -#define Pragma_Export_Valued_Procedure 71 -#define Pragma_External 72 -#define Pragma_Finalize_Storage_Only 73 -#define Pragma_Ident 74 -#define Pragma_Import 75 -#define Pragma_Import_Exception 76 -#define Pragma_Import_Function 77 -#define Pragma_Import_Object 78 -#define Pragma_Import_Procedure 79 -#define Pragma_Import_Valued_Procedure 80 -#define Pragma_Inline 81 -#define Pragma_Inline_Always 82 -#define Pragma_Inline_Generic 83 -#define Pragma_Inspection_Point 84 -#define Pragma_Interface 85 -#define Pragma_Interface_Name 86 -#define Pragma_Interrupt_Handler 87 -#define Pragma_Interrupt_Priority 88 -#define Pragma_Java_Constructor 89 -#define Pragma_Java_Interface 90 -#define Pragma_Keep_Names 91 -#define Pragma_Link_With 92 -#define Pragma_Linker_Alias 93 -#define Pragma_Linker_Options 94 -#define Pragma_Linker_Section 95 -#define Pragma_List 96 -#define Pragma_Machine_Attribute 97 -#define Pragma_Main 98 -#define Pragma_Main_Storage 99 -#define Pragma_Memory_Size 100 -#define Pragma_No_Return 101 -#define Pragma_Obsolescent 102 -#define Pragma_Optimize 103 -#define Pragma_Optional_Overriding 104 -#define Pragma_Overriding 105 -#define Pragma_Pack 106 -#define Pragma_Page 107 -#define Pragma_Passive 108 -#define Pragma_Preelaborate 109 -#define Pragma_Priority 110 -#define Pragma_Psect_Object 111 -#define Pragma_Pure 112 -#define Pragma_Pure_Function 113 -#define Pragma_Remote_Call_Interface 114 -#define Pragma_Remote_Types 115 -#define Pragma_Share_Generic 116 -#define Pragma_Shared 117 -#define Pragma_Shared_Passive 118 -#define Pragma_Source_Reference 119 -#define Pragma_Stream_Convert 120 -#define Pragma_Subtitle 121 -#define Pragma_Suppress_All 122 -#define Pragma_Suppress_Debug_Info 123 -#define Pragma_Suppress_Initialization 124 -#define Pragma_System_Name 125 -#define Pragma_Task_Info 126 -#define Pragma_Task_Name 127 -#define Pragma_Task_Storage 128 -#define Pragma_Thread_Body 129 -#define Pragma_Time_Slice 130 -#define Pragma_Title 131 -#define Pragma_Unchecked_Union 132 -#define Pragma_Unimplemented_Unit 133 -#define Pragma_Unreferenced 134 -#define Pragma_Unreserve_All_Interrupts 135 -#define Pragma_Volatile 136 -#define Pragma_Volatile_Components 137 -#define Pragma_Weak_External 138 +#define Pragma_Abort_Defer 45 +#define Pragma_All_Calls_Remote 46 +#define Pragma_Annotate 47 +#define Pragma_Assert 48 +#define Pragma_Asynchronous 49 +#define Pragma_Atomic 50 +#define Pragma_Atomic_Components 51 +#define Pragma_Attach_Handler 52 +#define Pragma_Comment 53 +#define Pragma_Common_Object 54 +#define Pragma_Complex_Representation 55 +#define Pragma_Controlled 56 +#define Pragma_Convention 57 +#define Pragma_CPP_Class 58 +#define Pragma_CPP_Constructor 59 +#define Pragma_CPP_Virtual 60 +#define Pragma_CPP_Vtable 61 +#define Pragma_Debug 62 +#define Pragma_Elaborate 63 +#define Pragma_Elaborate_All 64 +#define Pragma_Elaborate_Body 65 +#define Pragma_Export 66 +#define Pragma_Export_Exception 67 +#define Pragma_Export_Function 68 +#define Pragma_Export_Object 69 +#define Pragma_Export_Procedure 70 +#define Pragma_Export_Value 71 +#define Pragma_Export_Valued_Procedure 72 +#define Pragma_External 73 +#define Pragma_Finalize_Storage_Only 74 +#define Pragma_Ident 75 +#define Pragma_Import 76 +#define Pragma_Import_Exception 77 +#define Pragma_Import_Function 78 +#define Pragma_Import_Object 79 +#define Pragma_Import_Procedure 80 +#define Pragma_Import_Valued_Procedure 81 +#define Pragma_Inline 82 +#define Pragma_Inline_Always 83 +#define Pragma_Inline_Generic 84 +#define Pragma_Inspection_Point 85 +#define Pragma_Interface 86 +#define Pragma_Interface_Name 87 +#define Pragma_Interrupt_Handler 88 +#define Pragma_Interrupt_Priority 89 +#define Pragma_Java_Constructor 90 +#define Pragma_Java_Interface 91 +#define Pragma_Keep_Names 92 +#define Pragma_Link_With 93 +#define Pragma_Linker_Alias 94 +#define Pragma_Linker_Options 95 +#define Pragma_Linker_Section 96 +#define Pragma_List 97 +#define Pragma_Machine_Attribute 98 +#define Pragma_Main 99 +#define Pragma_Main_Storage 100 +#define Pragma_Memory_Size 101 +#define Pragma_No_Return 102 +#define Pragma_Obsolescent 103 +#define Pragma_Optimize 104 +#define Pragma_Optional_Overriding 105 +#define Pragma_Overriding 106 +#define Pragma_Pack 107 +#define Pragma_Page 108 +#define Pragma_Passive 109 +#define Pragma_Preelaborate 110 +#define Pragma_Priority 111 +#define Pragma_Psect_Object 112 +#define Pragma_Pure 113 +#define Pragma_Pure_Function 114 +#define Pragma_Remote_Call_Interface 115 +#define Pragma_Remote_Types 116 +#define Pragma_Share_Generic 117 +#define Pragma_Shared 118 +#define Pragma_Shared_Passive 119 +#define Pragma_Source_Reference 120 +#define Pragma_Stream_Convert 121 +#define Pragma_Subtitle 122 +#define Pragma_Suppress_All 123 +#define Pragma_Suppress_Debug_Info 124 +#define Pragma_Suppress_Initialization 125 +#define Pragma_System_Name 126 +#define Pragma_Task_Info 127 +#define Pragma_Task_Name 128 +#define Pragma_Task_Storage 129 +#define Pragma_Thread_Body 130 +#define Pragma_Time_Slice 131 +#define Pragma_Title 132 +#define Pragma_Unchecked_Union 133 +#define Pragma_Unimplemented_Unit 134 +#define Pragma_Unreferenced 135 +#define Pragma_Unreserve_All_Interrupts 136 +#define Pragma_Volatile 137 +#define Pragma_Volatile_Components 138 +#define Pragma_Weak_External 139 /* The following are deliberately out of alphabetical order, see Snames */ -#define Pragma_AST_Entry 139 -#define Pragma_Storage_Size 140 -#define Pragma_Storage_Unit 141 +#define Pragma_AST_Entry 140 +#define Pragma_Storage_Size 141 +#define Pragma_Storage_Unit 142 /* Define the numeric values for the conventions. */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 5fe9e1c550e..13724f06114 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -693,12 +693,12 @@ package body Sprint is when N_Access_Definition => - -- Ada 0Y (AI-254) + -- Ada 2005 (AI-254) if Present (Access_To_Subprogram_Definition (Node)) then Sprint_Node (Access_To_Subprogram_Definition (Node)); else - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -717,7 +717,7 @@ package body Sprint is when N_Access_Function_Definition => - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -735,7 +735,8 @@ package body Sprint is Sprint_Node (Subtype_Mark (Node)); when N_Access_Procedure_Definition => - -- Ada 0Y (AI-231) + + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -759,7 +760,7 @@ package body Sprint is Write_Str_With_Col_Check ("constant "); end if; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -813,7 +814,8 @@ package body Sprint is when N_Allocator => Write_Str_With_Col_Check_Sloc ("new "); - -- Ada 0Y (AI-231) + + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -974,7 +976,7 @@ package body Sprint is Sprint_Bar_List (Choices (Node)); Write_Str (" => "); - -- Ada 0Y (AI-287): Print the mbox if present + -- Ada 2005 (AI-287): Print the mbox if present if Box_Present (Node) then Write_Str_With_Col_Check ("<>"); @@ -997,7 +999,7 @@ package body Sprint is when N_Component_Definition => Set_Debug_Sloc; - -- Ada 0Y (AI-230): Access definition components + -- Ada 2005 (AI-230): Access definition components if Present (Access_Definition (Node)) then Sprint_Node (Access_Definition (Node)); @@ -1007,7 +1009,7 @@ package body Sprint is Write_Str_With_Col_Check ("aliased "); end if; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str (" not null "); @@ -1136,7 +1138,7 @@ package body Sprint is Write_Str_With_Col_Check_Sloc ("new "); - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str_With_Col_Check ("not null "); @@ -1751,7 +1753,7 @@ package body Sprint is Write_Str_With_Col_Check ("constant "); end if; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str_With_Col_Check ("not null "); @@ -1773,7 +1775,7 @@ package body Sprint is Sprint_Node (Defining_Identifier (Node)); Write_Str (" : "); - -- Ada 0Y (AI-230): Access renamings + -- Ada 2005 (AI-230): Access renamings if Present (Access_Definition (Node)) then Sprint_Node (Access_Definition (Node)); @@ -2010,7 +2012,7 @@ package body Sprint is Write_Str_With_Col_Check ("out "); end if; - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -2401,7 +2403,7 @@ package body Sprint is Write_Id (Defining_Identifier (Node)); Write_Str (" is "); - -- Ada 0Y (AI-231) + -- Ada 2005 (AI-231) if Null_Exclusion_Present (Node) then Write_Str ("not null "); @@ -2598,7 +2600,7 @@ package body Sprint is else if First_Name (Node) or else not Dump_Original_Only then - -- Ada 0Y (AI-50217): Print limited with_clauses + -- Ada 2005 (AI-50217): Print limited with_clauses if Private_Present (Node) and Limited_Present (Node) then Write_Indent_Str ("limited private with "); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index a378f209d9b..42b0a16c940 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -957,6 +957,7 @@ package body Switch.C is when 'X' => Ptr := Ptr + 1; Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; -- Processing for y switch @@ -1041,7 +1042,6 @@ package body Switch.C is -- Processing for 83 switch when '8' => - if Ptr = Max then raise Bad_Switch; end if; @@ -1052,8 +1052,39 @@ package body Switch.C is raise Bad_Switch; else Ptr := Ptr + 1; - Ada_95 := False; - Ada_83 := True; + Ada_Version := Ada_83; + end if; + + -- Processing for 95 switch + + when '9' => + if Ptr = Max then + raise Bad_Switch; + end if; + + Ptr := Ptr + 1; + + if Switch_Chars (Ptr) /= '5' then + raise Bad_Switch; + else + Ptr := Ptr + 1; + Ada_Version := Ada_95; + end if; + + -- Processing for 05 switch + + when '0' => + if Ptr = Max then + raise Bad_Switch; + end if; + + Ptr := Ptr + 1; + + if Switch_Chars (Ptr) /= '5' then + raise Bad_Switch; + else + Ptr := Ptr + 1; + Ada_Version := Ada_05; end if; -- Ignore extra switch character diff --git a/gcc/ada/5qsystem.ads b/gcc/ada/system-vms_64.ads index 9052e2b16bb..9052e2b16bb 100644 --- a/gcc/ada/5qsystem.ads +++ b/gcc/ada/system-vms_64.ads diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index b32d4a63f87..51c8edc0fd4 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -113,7 +113,7 @@ static GTY(()) tree gnu_return_label_stack; static tree tree_transform (Node_Id); static rtx first_nondeleted_insn (rtx); static tree start_block_stmt (void); -static tree end_block_stmt (void); +static tree end_block_stmt (bool); static tree build_block_stmt (List_Id); static tree make_expr_stmt_from_rtl (rtx, Node_Id); static void elaborate_all_entities (Node_Id); @@ -249,7 +249,7 @@ gnat_to_code (Node_Id gnat_node) start_block_stmt (); gnu_root = tree_transform (gnat_node); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); /* If we return a statement, generate code for it. */ if (IS_STMT (gnu_root)) @@ -291,7 +291,7 @@ gnat_to_gnu (Node_Id gnat_node) start_block_stmt (); gnu_root = tree_transform (gnat_node); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); if (gnu_root == error_mark_node) { @@ -327,8 +327,7 @@ gnat_to_gnu (Node_Id gnat_node) 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; + gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt, NULL_TREE); TREE_SLOC (gnu_root) = Sloc (gnat_node); } else @@ -2212,6 +2211,8 @@ tree_transform (Node_Id gnat_node) Present (gnat_when); gnat_when = Next_Non_Pragma (gnat_when)) { + tree gnu_temp_stmt, gnu_block; + /* First compile all the different case choices for the current WHEN alternative. */ @@ -2293,17 +2294,25 @@ tree_transform (Node_Id gnat_node) set of statements instead of the block containing the Case statement. */ gnat_pushlevel (); - expand_start_bindings (0); + start_block_stmt (); + for (gnat_statement = First (Statements (gnat_when)); Present (gnat_statement); gnat_statement = Next (gnat_statement)) - gnat_to_code (gnat_statement); + add_stmt (gnat_to_gnu (gnat_statement)); /* Communicate to GCC that we are done with the current WHEN, i.e. insert a "break" statement. */ - expand_exit_something (); - expand_end_bindings (NULL_TREE, block_has_vars (), -1); - gnat_poplevel (); + gnu_temp_stmt = build_nt (BREAK_STMT); + TREE_SLOC (gnu_temp_stmt) = Sloc (gnat_when); + add_stmt (gnu_temp_stmt); + + gnu_block = gnat_poplevel (); + gnu_temp_stmt = end_block_stmt (gnu_block != 0); + if (gnu_block) + BLOCK_STMT_BLOCK (gnu_temp_stmt) = gnu_block; + + expand_expr_stmt (gnu_temp_stmt); } expand_end_case (gnu_expr); @@ -2377,7 +2386,7 @@ tree_transform (Node_Id gnat_node) /* Declare the loop index and set it to its initial value. */ start_block_stmt (); gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); - expand_expr_stmt (end_block_stmt ()); + expand_expr_stmt (end_block_stmt (false)); if (DECL_BY_REF_P (gnu_loop_var)) gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); @@ -2487,7 +2496,7 @@ tree_transform (Node_Id gnat_node) expand_start_bindings (0); start_block_stmt (); process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); gnat_to_code (Handled_Statement_Sequence (gnat_node)); expand_end_bindings (NULL_TREE, block_has_vars (), -1); gnat_poplevel (); @@ -2768,10 +2777,10 @@ tree_transform (Node_Id gnat_node) gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); } - gnat_expand_stmt (end_block_stmt()); + gnat_expand_stmt (end_block_stmt (false)); start_block_stmt (); process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); /* Generate the code of the subprogram itself. A return statement will be present and any OUT parameters will be handled there. */ @@ -3299,7 +3308,7 @@ tree_transform (Node_Id gnat_node) gnu_result = chainon (nreverse (gnu_before_list), nreverse (gnu_after_list)); if (TREE_CHAIN (gnu_result)) - gnu_result = build_nt (BLOCK_STMT, gnu_result); + gnu_result = build_nt (BLOCK_STMT, gnu_result, NULL_TREE); } break; @@ -3316,7 +3325,7 @@ tree_transform (Node_Id gnat_node) start_block_stmt (); process_decls (Visible_Declarations (gnat_node), Private_Declarations (gnat_node), Empty, 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); break; case N_Package_Body: @@ -3327,7 +3336,7 @@ tree_transform (Node_Id gnat_node) start_block_stmt (); process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); if (Present (Handled_Statement_Sequence (gnat_node))) { @@ -3384,7 +3393,7 @@ tree_transform (Node_Id gnat_node) start_block_stmt(); process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); gnat_to_code (Unit (gnat_node)); @@ -3508,7 +3517,7 @@ tree_transform (Node_Id gnat_node) start_block_stmt (); add_decl_stmt (gnu_cleanup_decl, gnat_node); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call); } @@ -3542,7 +3551,7 @@ tree_transform (Node_Id gnat_node) start_block_stmt (); add_decl_stmt (gnu_jmpsave_decl, gnat_node); add_decl_stmt (gnu_jmpbuf_decl, gnat_node); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl; @@ -3579,7 +3588,7 @@ tree_transform (Node_Id gnat_node) gnu_except_ptr_stack); start_block_stmt (); add_decl_stmt (TREE_VALUE (gnu_except_ptr_stack), gnat_node); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); /* Generate code for each handler. The N_Exception_Handler case below does the real work. We ignore the dummy exception handler @@ -3630,7 +3639,7 @@ tree_transform (Node_Id gnat_node) if (Present (First_Real_Statement (gnat_node))) process_decls (Statements (gnat_node), Empty, First_Real_Statement (gnat_node), 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); /* Generate code for each statement in the block. */ for (gnat_temp = (Present (First_Real_Statement (gnat_node)) @@ -3861,7 +3870,7 @@ tree_transform (Node_Id gnat_node) start_block_stmt (); add_decl_stmt (gnu_incoming_exc_ptr, gnat_node); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); expand_expr_stmt (build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr)); expand_decl_cleanup @@ -3993,7 +4002,7 @@ tree_transform (Node_Id gnat_node) process_freeze_entity (gnat_node); start_block_stmt (); process_decls (Actions (gnat_node), Empty, Empty, 1, 1); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); break; case N_Itype_Reference: @@ -4281,7 +4290,8 @@ start_block_stmt () TREE_TYPE (gnu_block_stmt) = void_type_node; } - BLOCK_STMT_LIST (gnu_block_stmt) = 0; + BLOCK_STMT_LIST (gnu_block_stmt) = NULL_TREE; + BLOCK_STMT_BLOCK (gnu_block_stmt) = NULL_TREE; TREE_CHAIN (gnu_block_stmt) = gnu_block_stmt_node; gnu_block_stmt_node = gnu_block_stmt; @@ -4301,6 +4311,7 @@ add_stmt (tree gnu_stmt) { TREE_CHAIN (gnu_stmt) = BLOCK_STMT_LIST (gnu_block_stmt_node); BLOCK_STMT_LIST (gnu_block_stmt_node) = gnu_stmt; + TREE_TYPE (gnu_stmt) = void_type_node; } /* If this is a DECL_STMT for a variable with DECL_INIT_BY_ASSIGN_P set, @@ -4354,10 +4365,11 @@ add_decl_stmt (tree gnu_decl, Entity_Id gnat_entity) } /* Return the BLOCK_STMT that corresponds to the statement that add_stmt - has been emitting or just a single statement if only one. */ + has been emitting or just a single statement if only one. If FORCE + is true, then always emit the BLOCK_STMT. */ static tree -end_block_stmt () +end_block_stmt (bool force) { tree gnu_block_stmt = gnu_block_stmt_node; tree gnu_retval = gnu_block_stmt; @@ -4368,12 +4380,12 @@ end_block_stmt () /* If we have only one statement, return it and free this node. Otherwise, finish setting up this node and return it. If we have no statements, return a NULL_STMT. */ - if (BLOCK_STMT_LIST (gnu_block_stmt) == 0) + if (!force && BLOCK_STMT_LIST (gnu_block_stmt) == 0) { gnu_retval = build_nt (NULL_STMT); TREE_TYPE (gnu_retval) = void_type_node; } - else if (TREE_CHAIN (BLOCK_STMT_LIST (gnu_block_stmt)) == 0) + else if (!force && TREE_CHAIN (BLOCK_STMT_LIST (gnu_block_stmt)) == 0) gnu_retval = BLOCK_STMT_LIST (gnu_block_stmt); else { @@ -4410,7 +4422,7 @@ build_block_stmt (List_Id gnat_list) gnat_node = Next (gnat_node)) add_stmt (gnat_to_gnu (gnat_node)); - gnu_result = end_block_stmt (); + gnu_result = end_block_stmt (false); return TREE_CODE (gnu_result) == NULL_STMT ? NULL_TREE : gnu_result; } @@ -4470,9 +4482,15 @@ gnat_expand_stmt (tree gnu_stmt) break; case BLOCK_STMT: + if (BLOCK_STMT_BLOCK (gnu_stmt)) + expand_start_bindings_and_block (0, BLOCK_STMT_BLOCK (gnu_stmt)); + for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt; gnu_elmt = TREE_CHAIN (gnu_elmt)) gnat_expand_stmt (gnu_elmt); + + if (BLOCK_STMT_BLOCK (gnu_stmt)) + expand_end_bindings (NULL_TREE, 1, -1); break; case IF_STMT: @@ -4541,6 +4559,10 @@ gnat_expand_stmt (tree gnu_stmt) } break; + case BREAK_STMT: + expand_exit_something (); + break; + default: abort (); } @@ -4819,7 +4841,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, { start_block_stmt (); process_freeze_entity (gnat_decl); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); process_decls (Actions (gnat_decl), Empty, Empty, 1, 0); } @@ -4867,15 +4889,14 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, /* Concurrent stubs stand for the corresponding subprogram bodies, which are deferred like other bodies. */ - else if (Nkind (gnat_decl) == N_Task_Body_Stub - || Nkind (gnat_decl) == N_Protected_Body_Stub) - ; - + else if (Nkind (gnat_decl) == N_Task_Body_Stub + || Nkind (gnat_decl) == N_Protected_Body_Stub) + ; else { start_block_stmt (); gnat_to_code (gnat_decl); - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); } } @@ -5334,7 +5355,7 @@ process_type (Entity_Id gnat_entity) TREE_TYPE (gnu_new)); } - gnat_expand_stmt (end_block_stmt ()); + gnat_expand_stmt (end_block_stmt (false)); } /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate. diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index ead346f2775..c30494f2162 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -257,9 +257,9 @@ gnat_pushlevel () current_binding_level = newlevel; } -/* Exit a binding level. */ +/* Exit a binding level. Return the BLOCK node, if any. */ -void +tree gnat_poplevel () { struct ada_binding_level *level = current_binding_level; @@ -289,13 +289,14 @@ gnat_poplevel () parent block. Otherwise, add it to the list of its parent. */ if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL) ; - else if (BLOCK_VARS (block) == 0) + else if (BLOCK_VARS (block) == NULL_TREE) { BLOCK_SUBBLOCKS (level->chain->block) = chainon (BLOCK_SUBBLOCKS (block), BLOCK_SUBBLOCKS (level->chain->block)); TREE_CHAIN (block) = free_block_chain; free_block_chain = block; + block = NULL_TREE; } else { @@ -308,6 +309,7 @@ gnat_poplevel () current_binding_level = level->chain; level->chain = free_binding_level; free_binding_level = level; + return block; } /* Insert BLOCK at the end of the list of subblocks of the diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 1bd4d6dced7..1966d96c254 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -308,6 +308,16 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), + Metric => + (Cname => new S'("METRIC"), + Usage => new S'("GNAT METRIC /qualifiers source_file"), + VMS_Only => False, + Unixcmd => new S'("gnatmetric"), + Unixsws => null, + Switches => Metric_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + Name => (Cname => new S'("NAME"), Usage => new S'("GNAT NAME /qualifiers naming-pattern " diff --git a/gcc/ada/vms_conv.ads b/gcc/ada/vms_conv.ads index e945f7fbf98..8ce7cfe4e5b 100644 --- a/gcc/ada/vms_conv.ads +++ b/gcc/ada/vms_conv.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -97,7 +97,7 @@ package VMS_Conv is type Command_Type is (Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List, - Make, Name, Preprocess, Pretty, Shared, Stub, Xref, Undefined); + Make, Name, Preprocess, Pretty, Shared, Stub, Metric, Xref, Undefined); type Alternate_Command is (Comp, Ls, Kr, Pp, Prep); -- Alternate command libel for non VMS system diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index df0211d226b..43b4fe46859 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -933,14 +933,18 @@ package VMS_Data is -- Ada 95 program. S_GCC_Ada_95 : aliased constant S := "/95 " & - "!-gnat83"; + "-gnat95"; -- /95 (D) -- - -- Same as /NO83. - -- - -- /NO95 + -- Allows GNAT to recognize the full range of Ada 95 constructs. + -- This is the normal default for GNAT Pro. + + S_GCC_Ada_05 : aliased constant S := "/05 " & + "-gnat05"; + -- /05 (D) -- - -- Same as /83. + -- Allows GNAT to recognize all implemented proposed Ada 2005 + -- extensions. See features file for list of implemented features. S_GCC_Asm : aliased constant S := "/ASM " & "-S,!-c"; @@ -948,7 +952,7 @@ package VMS_Data is -- /ASM -- -- Use to cause the assembler source file to be generated, using S as the - -- filetype, instead of the object file. This may be useful if you need + -- filetype, instead of the object file. This may be useful if you need -- to examine the generated assembly code. S_GCC_Checks : aliased constant S := "/CHECKS=" & @@ -2795,6 +2799,7 @@ package VMS_Data is GCC_Switches : aliased constant Switches := (S_GCC_Ada_83 'Access, S_GCC_Ada_95 'Access, + S_GCC_Ada_05 'Access, S_GCC_Asm 'Access, S_GCC_Checks 'Access, S_GCC_ChecksX 'Access, @@ -4014,6 +4019,174 @@ package VMS_Data is S_Make_Use_Map 'Access, S_Make_Verbose 'Access); + ------------------------------ + -- Switches for GNAT METRIC -- + ------------------------------ + + S_Metric_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & + "-gnatec>"; + -- /CONFIGURATION_PRAGMAS_FILE=file + -- + -- Specify a configuration pragmas file that need to be taken into account + + S_Metric_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- + -- Look for files in the directory where GNAT METRIC was invoked + -- + -- /NOCURRENT_DIRECTORY + -- + -- Do not look for files in the directory where GNAT METRIC was invoked + + S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " & + "-dv"; + -- /DEBUG_OUTPUT + + S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" & + "ALL " & + "!-ed,!-es,!-enl,!-eis," & + "!-eas,!-eit,!-eat,!-enu " & + "DECLARATION_TOTAL " & + "-ed " & + "STATEMENT_TOTAL " & + "-es " & + "LOOP_NESTING_MAX " & + "-enl " & + "INT_SUBPROGRAMS " & + "-eis " & + "SUBPROGRAMS_ALL " & + "-eas " & + "INT_TYPES " & + "-eit " & + "TYPES_ALL " & + "-eat " & + "PROGRAM_NESTING_MAX " & + "-enu"; + -- /ELEMENT_METRICS=(option, option ...) + + S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" & + "DEFAULT " & + "!-x,!-nt,!-sfn " & + "XML " & + "-x " & + "NO_TEXT " & + "-nt " & + "SHORT_SOURCE_FILE_NAME " & + "-sfn"; + -- /FORMAT_OUTPUT=(option, option ...) + + S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" & + "-og@"; + -- /GLOBAL_OUTPUT=filename + + S_Metric_Line : aliased constant S := "/LINE_METRICS=" & + "ALL " & + "!-la,!-lcode,!-lcomm," & + "!-leol,!-lb " & + "LINES_ALL " & + "-la " & + "CODE_LINES " & + "-lcode " & + "COMENT_LINES " & + "-lcomm " & + "MIXED_CODE_COMMENTS " & + "-leol " & + "BLANK_LINES " & + "-lb "; + -- /LINE_METRICS=(option, option ...) + + S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Metric_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- binder. + + S_Metric_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /QUIET + + S_Metric_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory[,...]) + + S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' & + "-o" & '"'; + -- /SUFFIX_DETAILS=suffix + + S_Metric_Suppress : aliased constant S := "/SUPPRESS=" & + "NOTHING " & + "!-nocc,!-noec,!-nonl," & + "!-ne,!-nolocal " & + "CYCLOMATIC_COMPLEXITY " & + "-nocc " & + "ESSENTIAL_COMPLEXITY " & + "-noec " & + "MAXIMAL_LOOP_NESTING " & + "-nonl " & + "EXITS_AS_GOTOS " & + "-ne " & + "LOCAL_DETAILS " & + "-nolocal "; + -- /SUPPRESS=(option, option ...) + + S_Metric_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /VERBOSE + + S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" & + "-ox@"; + -- /XML_OUTPUT=filename + + Metric_Switches : aliased constant Switches := + (S_Metric_Config 'Access, + S_Metric_Current 'Access, + S_Metric_Debug 'Access, + S_Metric_Element 'Access, + S_Metric_Ext 'Access, + S_Metric_Format 'Access, + S_Metric_Globout 'Access, + S_Metric_Line 'Access, + S_Metric_Mess 'Access, + S_Metric_Project 'Access, + S_Metric_Quiet 'Access, + S_Metric_Search 'Access, + S_Metric_Suffix 'Access, + S_Metric_Suppress 'Access, + S_Metric_Verbose 'Access, + S_Metric_XMLout 'Access); + ---------------------------- -- Switches for GNAT NAME -- ---------------------------- |