diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-08-04 13:51:43 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-08-04 13:51:43 +0000 |
| commit | 0c888ad177ad08a2bac14e762ddced0beed5647c (patch) | |
| tree | 828bbf6fbd489f2ef494e6151a1c4d1d49ecf151 /gcc/ada | |
| parent | 8b407655ed1a6e1300b60482f455c32e8b662a8b (diff) | |
| download | gcc-0c888ad177ad08a2bac14e762ddced0beed5647c.tar.gz | |
2008-08-04 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk r138620
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@138622 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
94 files changed, 4914 insertions, 2249 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fdb714c1cb7..e49c0cd7510 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,582 @@ +2008-08-04 Pascal Obry <obry@adacore.com> + + * adaint.h: Add missing prototype. + + * adaint.c: Refine support for Windows file attributes. + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * sem_res.adb: + (Valid_Conversion): Catch case of designated types having different + sizes, even though they statically match. + +2008-08-04 Javier Miranda <miranda@adacore.com> + + * sem_eval.adb (Subtypes_Statically_Match): Remove superfluous patch + added in previous patch to handle access to subprograms. + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * freeze.adb: + (Freeze_Entity): Only check No_Default_Initialization restriction for + constructs that come from source + +2008-08-04 Thomas Quinot <quinot@adacore.com> + + * exp_ch6.adb: Minor comment fix. + + * sem_ch4.adb: Minor reformatting. + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * sem_res.adb: (Large_Storage_Type): Improve previous change. + +2008-08-04 Pascal Obry <obry@adacore.com> + + * adaint.c, s-os_lib.adb, s-os_lib.ads: Use Windows ACL to deal with + file attributes. + +2008-08-04 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Access_Subprogram_Declaration): Adding missing support + for N_Formal_Object_Declaration nodes. Adding kludge required by + First_Formal to provide its functionality with access to functions. + (Replace_Anonymous_Access_To_Protected_Subprogram): Add missing support + for anonymous access types returned by functions. + + * sem_ch5.adb (Analyze_Assignment): Code cleanup to avoid duplicate + conversion of null-excluding access types (required only once to force + the generation of the required runtime check). + + * sem_type.adb (Covers): minor reformating + + * checks.adb (Null_Exclusion_Static_Checks): Avoid reporting errors + with internally generated nodes. Avoid generating the error inside init + procs. + + * sem_res.adb (Resolve_Membership_Test): Minor reformating. + (Resolve_Null): Generate the null-excluding check in case of assignment + to a null-excluding object. + (Valid_Conversion): Add missing support for anonymous access to + subprograms. + + * sem_ch6.adb (Check_Return_Subtype_Indication): Add missing support for + anonymous access types whose designated type is an itype. This case + occurs with anonymous access to protected subprograms types. + (Analyze_Return_Type): Add missing support for anonymous access to + protected subprogram. + + * sem_eval.adb (Subtypes_Statically_Match): In case of access to + subprograms addition of missing check on matching convention. Required + to properly handle access to protected subprogram types. + + * exp_ch3 (Build_Assignment): Code cleanup removing duplicated check on + null excluding access types. + +2008-08-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb: Add comments + + * sem_ch4.adb (Analyze_Allocator): If the designated type is a non-null + access type and the allocator is not initialized, warn rather than + reporting an error. + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb: Minor reformatting + + * exp_dist.adb: Minor reformatting + + * g-comlin.adb: Minor reformatting + +2008-08-04 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): Perform a conversion of the + target to the type of the aggregate in the case where the target object + is class-wide. + + * exp_ch5.adb (Expand_Simple_Function_Return): When the function's + result type is class-wide and inherently limited, and the expression + has a specific type, create a return object of the specific type, for + more efficient handling of returns of build-in-place aggregates (avoids + conversions of the class-wide return object to the specific type on + component assignments). + + * sem_ch6.adb (Check_Return_Subtype_Indication): Suppress the error + about a type mismatch for a class-wide function with a return object + having a specific type when the object declaration doesn't come from + source. Such an object can result from the expansion of a simple return. + +2008-08-04 Vasiliy Fofanov <fofanov@adacore.com> + + * g-soccon-mingw-64.ads, system-mingw-x86_64.ads: New files. + + * gcc-interface/Makefile.in: Use 64bit-specific system files when + compiling for 64bit windows. + +2008-08-04 Jerome Lambourg <lambourg@adacore.com> + + * g-comlin.adb (Group_Switches): Preserve the switch order when + grouping and allow switch grouping of switches with more than one + character extension (e.g. gnatw.x). + (Args_From_Expanded): Remove this now obsolete method. + +2008-08-04 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Get_Allocator_Final_List): Freeze anonymous type for + chain at once, to ensure that type is properly decorated for back-end, + when allocator appears within a loop. + +2008-08-04 Kevin Pouget <pouget@adacore.com> + + * snames.h, snames.adb, snames.ads: + Add Attr_To_Any, Attr_From_Any and Attr_TypeCode defines. + + * exp_dist.ads, exp_dist.adb: Add Build_From_Any_Call, + Build_To_Any_Call and Build_TypeCode_Call procedures. + + * exp_attr.adb, sem_attr.adb: Add corresponding cases. + + * rtsfind.ads: Add corresponding names. + + * tbuild.adb: Update prefix restrictions to allow '_' character. + +2008-08-04 Doug Rupp <rupp@adacore.com> + + * gigi.h (fill_vms_descriptor): Add third parameter gnat_actual + * trans.c (call_to_gnu): Call fill_vms_descriptor with new parameter. + * utils2.c (fill_vms_descriptor): Add third parameter for error sloc and + use it. Calculate pointer range overflow using 64bit types. + +2008-08-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Access_Definition): A formal object declaration is a + legal context for an anonymous access to subprogram. + + * sem_ch4.adb (Analyze_One_Call): If the call can be interpreted as an + indirect call, report success to the caller to include possible + interpretation. + + * sem_ch6.adb (Check_Return_Type_Indication): Apply proper conformance + check when the type + of the extended return is an anonymous access_to_subprogram type. + + * sem_res.adb: + (Resolve_Call): Insert a dereference if the type of the subprogram is an + access_to_subprogram and the context requires its return type, and a + dereference has not been introduced previously. + +2008-08-04 Arnaud Charlet <charlet@adacore.com> + + * usage.adb (Usage): Minor rewording of -gnatwz switch, to improve + gnatcheck support in GPS. + +2008-08-04 Vincent Celier <celier@adacore.com> + + * mlib.adb (Create_Sym_Links): Create relative symbolic links when + requested + +2008-08-04 Vincent Celier <celier@adacore.com> + + * gprep.adb (Process_One_File): Call Prep.Preprocess with a Boolean + variable, but don't check the resulting value as it has no impact on + the processing. + + * opt.ads: + (Generate_Processed_File): New Boolean flag, set to True in the compiler + when switch -gnateG is used. + + * prep.adb: + (Preprocess): new Boolean out parameter Source_Modified. Set it to True + when the source is modified by the preprocessor and there is no + preprocessing errors. + + * prep.ads (Preprocess): new Boolean out parameter Source_Modified + + * sinput-l.adb: + (Load_File): Output the result of preprocessing if the source text was + modified. + + * switch-c.adb (Scan_Front_End_Switches): Recognize switch -gnateG + + * switch-m.adb (Normalize_Compiler_Switches): Normalize switch -gnateG + + * ug_words: Add VMS equivalent for -gnateG + + * vms_data.ads: + Add VMS option /GENERATE_PROCESSED_SOURCE, equivalent to switch -gnateG + +2008-08-04 Doug Rupp <rupp@adacore.com> + + * gcc-interface/utils2.c: + (fill_vms_descriptor): Raise CE if attempt made to pass 64bit pointer + in 32bit descriptor. + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * par-ch10.adb: Minor reformatting + + * i-cobol.adb: Minor reformatting. + +2008-08-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Access_Definition): Create an itype reference for an + anonymous access return type of a regular function that is not a + compilation unit. + +2008-08-04 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: New Builder attribute Global_Compilation_Switches + + * snames.adb: New standard name Global_Compilation_Switches + + * snames.ads: New standard name Global_Compilation_Switches + + * make.adb: Correct spelling error in comment + +2008-08-04 Arnaud Charlet <charlet@adacore.com> + + * sem_prag.adb (Check_Form_Of_Interface_Name): Fix handling for CLI + target. + +2008-08-04 Thomas Quinot <quinot@adacore.com> + + * sem_ch10.adb: Minor comment fix. + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * restrict.adb: Improved messages for restriction warnings + + * restrict.ads: Improved messages for restriction messages + + * s-rident.ads (Profile_Name): Add No_Profile + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * system-darwin-x86.ads: Correct bad definition of Max_Nonbinary_Modulus + +2008-08-04 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Entity): Check for size clause for boolean warning + +2008-08-04 Vincent Celier <celier@adacore.com> + + * prj-proc.adb: + (Copy_Package_Declarations): When inheriting package Naming from a + project being extended, do not inherit source exception names. + +2008-08-04 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Check_Precondition_Postcondition): When scanning the + list of declaration to find previous subprogram, do not go to the + original node of a generic unit. + +2008-08-02 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.c (build_binary_op) <PLUS_EXPR, MINUS_EXPR>: + New case. Convert BOOLEAN_TYPE operation to the default integer type. + +2008-08-01 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (DECL_PARM_ALT): Now DECL_PARM_ALT_TYPE. + * gcc-interface/decl.c (gnat_to_gnu_param): Fix formatting, simplify + and adjust for above renaming. + * gcc-interface/utils.c (convert_vms_descriptor): Likewise. Add new + gnu_expr_alt_type parameter. Convert the expression to it instead + of changing its type in place. + (build_function_stub): Adjust call to above function. + +2008-08-01 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Remove dead + code. Do not get full definition of deferred constants with address + clause for a use. Do not ignore deferred constant definitions with + address clause. Ignore constant definitions already marked with the + error node. + <object>: Remove obsolete comment. For a deferred constant with + address clause, get the initializer from the full view. + * gcc-interface/trans.c (gnat_to_gnu) <N_Attribute_Definition_Clause>: + Rework and remove obsolete comment. + <N_Object_Declaration>: For a deferred constant with address clause, + mark the full view with the error node. + * gcc-interface/utils.c (convert_to_fat_pointer): Rework and fix + formatting nits. + +2008-08-01 Hristian Kirtchev <kirtchev@adacore.com> + + * rtsfind.ads: Add block IO versions of stream routines for Strings. + + * bindgen.adb, gnat_rm.texi, gnat_ugn.texi, opt.ads, + sem_prag.adb, snames.adb, snames.ads, snames.h, + par-prag.adb: Undo previous stream related changes. + + * s-rident.ads: Add new restriction No_Stream_Optimizations. + + * s-ststop.ads, s-ststop.adb: Comment reformatting. + Define enumeration type to designate different IO mechanisms. + Enchance generic package Stream_Ops_Internal to include an + implementation of Input and Output. + + * exp_attr.adb (Find_Stream_Subprogram): If restriction + No_Stream_Optimization is active, choose the default byte IO + implementations of stream attributes for Strings. + Otherwise use the corresponding block IO version. + +2008-08-01 Olivier Hainque <hainque@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <case E_Function>: Do not + turn Ada Pure into GCC const, now implicitely implying nothrow as well. + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * par-ch3.adb (P_Defining_Identifier): Avoid repeated attempt to + convert plain identifier into defining identifier. + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Check_Form_Of_Interface_Name): Refine and improve + warnings + + * lib-xref.adb: Add error defense. + +2008-08-01 Bob Duff <duff@adacore.com> + + * ioexcept.ads, sequenio.ads, directio.ads: Correct comment. + +2008-08-01 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Expand_Call): Adjustment to previous fix for passing + correct accessibility levels. In the "when others" case, retrieve the + access level of the Etype of Prev rather than Prev_Orig, because the + original exression has not always been analyzed. + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * prj-nmsc.adb: Minor reformatting + + * sem_ch4.adb: Minor reformatting + Minor code reorganization + + * prj.ads: Minor reformatting + + * s-os_lib.adb: Minor reformatting + + * par-prag.adb (Prag, case Wide_Character_Encoding): Deal with upper + half encodings + + * scans.ads: Minor reformatting. + + * sem_prag.adb (Analyze_Pragma): Put entries in alpha order + (Analyze_Pragma): Make sure all GNAT pragmas call GNAT_Pragma + + * sem_res.adb: + (Resolve_Call): Check violation of No_Specific_Termination_Handlers + + * sem_ch12.adb: Minor comment reformatting + + * par-ch3.adb (P_Type_Declaration): Properly handle missing type + keyword + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb (Process_PPCs): Don't copy spec PPC to body if not + generating code + +2008-08-01 Ed Schonberg <schonberg@adacore.com> + + * checks.adb (Apply_Float_Conversion_Check): If the expression to be + converted is a real literal and the target type has static bounds, + perform the conversion exactly to prevent floating-point anomalies on + some targets. + +2008-08-01 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: New attribute Compiler'Name_Syntax (<lang>) + + * prj-nmsc.adb (Process_Compiler): Recognize attribute Name_Syntax + + * prj.adb (Object_Exist_For): Use Object_Generated, not + Objects_Generated that is removed and was never modified anyway. + + * prj.ads: + (Path_Syntax_Kind): New enumeration type + (Language_Config): New component Path_Syntax, defaulted to Host. + Components PIC_Option and Objects_Generated removed, as they are not + used. + + * snames.adb: New standard name Path_Syntax + + * snames.ads: New standard name Path_Syntax + +2008-08-01 Vincent Celier <celier@adacore.com> + + * mlib-utl.adb: + (Adalib_Path): New variable to store the path of the adalib directory + when procedure Specify_Adalib_Dir is called. + (Lib_Directory): If Adalib_Path is not null, return its value + (Specify_Adalib_Dir): New procedure + + * mlib-utl.ads (Specify_Adalib_Dir): New procedure + +2008-08-01 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: + (Check_Precondition_Postcondition): If not generating code, analyze the + expression in a postcondition that appears in a subprogram body, so that + it is properly decorated for ASIS use. + +2008-08-01 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Expand_Call): Remove ugly special-case code that resets + Orig_Prev to Prev in the case where the actual is N_Function_Call or + N_Identifier. This was interfering with other cases that are rewritten + as N_Identifier, such as allocators, resulting in passing of the wrong + accessibility level, and based on testing this code is apparently no + longer needed at all. + +2008-08-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_One_Call): Handle complex overloading of a + procedure call whose prefix + is a parameterless function call that returns an access_to_procedure. + +2008-08-01 Jose Ruiz <ruiz@adacore.com> + + * adaint.c (__gnat_tmp_name): Refine the generation of temporary names + for RTX. Adding a suffix that is incremented at each iteration. + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body): Remove special casing of + Raise_Exception + +2008-08-01 Jerome Lambourg <lambourg@adacore.com> + + * s-os_lib.adb (Normalize_Pathname): Take care of double-quotes in + paths, which are authorized by Windows but can lead to errors when used + elsewhere. + +2008-08-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.ads (Need_Subprogram_Instance_Body): new function, to create + a pending instantiation for the body of a subprogram that is to be + inlined. + + * sem_ch12.adb: + (Analyze_Subprogram_Instantiation): use Need_Subprogram_Instance_Body. + + * sem_prag.adb (Make_Inline): If the pragma applies to an instance, + create a pending instance for its body, so that calls to the subprogram + can be inlined by the back-end. + +2008-08-01 Jose Ruiz <ruiz@adacore.com> + + * gnat_ugn.texi: Document the RTX run times (rts-rtx-rtss and + rts-rtx-w32). + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * scng.adb (Error_Illegal_Wide_Character): Bump scan pointer + +2008-08-01 Doug Rupp <rupp@adacore.com> + + * gnat_rm.texi: Document new mechanism Short_Descriptor. + + * types.ads (Mechanism_Type): Modify range for new Short_Descriptor + mechanism values. + + * sem_prag.adb (Set_Mechanism_Value): Enhance for Short_Descriptor + mechanism and Short_Descriptor mechanism values. + + * snames.adb (preset_names): Add short_descriptor entry. + + * snames.ads: Add Name_Short_Descriptor. + + * types.h: Add new By_Short_Descriptor mechanism values. + + * sem_mech.adb (Set_Mechanism_Value): Enhance for Short_Descriptor + mechanism and Short_Descriptor mechanism values. + + * sem_mech.ads (Mechanism_Type): Add new By_Short_Descriptor mechanism + values. + (Descriptor_Codes): Modify range for new mechanism values. + + * treepr.adb (Print_Entity_Enfo): Handle new By_Short_Descriptor + mechanism values. + + * gcc-interface/decl.c (gnat_to_gnu_entity): Handle By_Short_Descriptor. + (gnat_to_gnu_param): Handle By_Short_Descriptor. + + * gcc-interface/gigi.h (build_vms_descriptor64): Remove prototype. + (build_vms_descriptor32): New prototype. + (fill_vms_descriptor): Remove unneeded gnat_actual parameter. + + * gcc-interface/trans.c (call_to_gnu): Removed unneeded gnat_actual + argument in call fill_vms_descriptor. + + * gcc-interface/utils.c (build_vms_descriptor32): Renamed from + build_vms_descriptor and enhanced to hande Short_Descriptor mechanism. + (build_vms_descriptor): Renamed from build_vms_descriptor64. + (convert_vms_descriptor32): New function. + (convert_vms_descriptor64): New function. + (convert_vms_descriptor): Rewrite to handle both 32bit and 64bit + descriptors. + + * gcc-interface/utils2.c (fill_vms_descriptor): Revert previous changes, + no longer needed. + +2008-08-01 Jose Ruiz <ruiz@adacore.com> + + * adaint.c (__gnat_tmp_name): RTSS applications do not support tempnam + nor tmpnam, so we always use c:\WINDOWS\Temp\gnat-XXXXXX as temporary + name. + +2008-08-01 Jose Ruiz <ruiz@adacore.com> + + * cstreams.c (__gnat_full_name): RTSS applications cannot ask for the + current directory so only fully qualified names are allowed. + +2008-08-01 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: + Minor editing, remove uncomfortable use of semicolon + + * s-ststop.adb: Add some ??? comments + + * sem_ch10.adb: Minor reformatting + + * snames.ads: + Minor comment fixes, some pragmas were not properly + categorized in the comments, documentation change only + + * xref_lib.adb: Minor reformatting + + * sinput.adb: Minor reformatting + + * gnatchop.adb: Minor reformatting + + * sem_util.ads: Minor reformatting. + + * opt.ads: Minor documentation fix + + * scng.adb: Minor reformatting + + * prj-part.adb: Update comments + +2008-08-01 Ed Schonberg <schonberg@adacore.com> + + * exp_disp.adb (Expand_Interface_Conversion): If the target type is a + tagged synchronized type, use corresponding record type. + +2008-08-01 Doug Rupp <rupp@adacore.com> + + * mlib-tgt-specific-vms-alpha.adb (Build_Dynamic_Library): Output a + dummy transfer address for debugging. + + * mlib-tgt-specific-vms-ia64.adb (Build_Dynamic_Library): Likewise. + + * vms_data.ads: vms_data.ads: New qualfier /MACHINE_CODE_LISTING + 2008-07-31 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_entity): Fix formatting. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 29f649aa096..20f8d22ea21 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -187,6 +187,8 @@ struct vstring #if defined (_WIN32) #include <dir.h> #include <windows.h> +#include <accctrl.h> +#include <aclapi.h> #undef DIR_SEPARATOR #define DIR_SEPARATOR '\\' #endif @@ -982,7 +984,15 @@ __gnat_named_file_length (char *name) void __gnat_tmp_name (char *tmp_filename) { -#ifdef __MINGW32__ +#ifdef RTX + /* Variable used to create a series of unique names */ + static int counter = 0; + + /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */ + strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-"); + sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++); + +#elif defined (__MINGW32__) { char *pname; @@ -1504,10 +1514,6 @@ __gnat_set_file_time_name (char *name, time_t time_stamp) #endif } -#ifdef _WIN32 -#include <windows.h> -#endif - /* Get the list of installed standard libraries from the HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries key. */ @@ -1677,9 +1683,147 @@ __gnat_is_directory (char *name) return (!ret && S_ISDIR (statbuf.st_mode)); } +#if defined (_WIN32) && !defined (RTX) +/* This MingW section contains code to work with ACL. */ +static int +__gnat_check_OWNER_ACL +(TCHAR *wname, + DWORD CheckAccessDesired, + GENERIC_MAPPING CheckGenericMapping) +{ + DWORD dwAccessDesired, dwAccessAllowed; + PRIVILEGE_SET PrivilegeSet; + DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET); + BOOL fAccessGranted = FALSE; + HANDLE hToken; + DWORD nLength; + SECURITY_DESCRIPTOR* pSD = NULL; + + GetFileSecurity + (wname, OWNER_SECURITY_INFORMATION | + GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, + NULL, 0, &nLength); + + if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc + (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL) + return 0; + + /* Obtain the security descriptor. */ + + if (!GetFileSecurity + (wname, OWNER_SECURITY_INFORMATION | + GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, + pSD, nLength, &nLength)) + return 0; + + if (!ImpersonateSelf (SecurityImpersonation)) + return 0; + + if (!OpenThreadToken + (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) + return 0; + + /* Undoes the effect of ImpersonateSelf. */ + + RevertToSelf (); + + /* We want to test for write permissions. */ + + dwAccessDesired = CheckAccessDesired; + + MapGenericMask (&dwAccessDesired, &CheckGenericMapping); + + if (!AccessCheck + (pSD , /* security descriptor to check */ + hToken, /* impersonation token */ + dwAccessDesired, /* requested access rights */ + &CheckGenericMapping, /* pointer to GENERIC_MAPPING */ + &PrivilegeSet, /* receives privileges used in check */ + &dwPrivSetSize, /* size of PrivilegeSet buffer */ + &dwAccessAllowed, /* receives mask of allowed access rights */ + &fAccessGranted)) + return 0; + + return fAccessGranted; +} + +static void +__gnat_set_OWNER_ACL +(TCHAR *wname, + DWORD AccessMode, + DWORD AccessPermissions) +{ + ACL* pOldDACL = NULL; + ACL* pNewDACL = NULL; + SECURITY_DESCRIPTOR* pSD = NULL; + EXPLICIT_ACCESS ea; + TCHAR username [100]; + DWORD unsize = 100; + + HANDLE file = CreateFile + (wname, READ_CONTROL | WRITE_DAC, 0, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + + if (file == INVALID_HANDLE_VALUE) + return; + + /* Get current user, he will act as the owner */ + + if (!GetUserName (username, &unsize)) + return; + + if (GetSecurityInfo + (file, + SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION, + NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS) + return; + + ZeroMemory (&ea, sizeof (EXPLICIT_ACCESS)); + + ea.grfAccessMode = AccessMode; + ea.grfAccessPermissions = AccessPermissions; + ea.grfInheritance = CONTAINER_INHERIT_ACE | OBJECT_INHERIT_ACE; + ea.Trustee.TrusteeForm = TRUSTEE_IS_NAME; + ea.Trustee.TrusteeType = TRUSTEE_IS_USER; + ea.Trustee.ptstrName = username; + + if (AccessMode == SET_ACCESS) + { + /* SET_ACCESS, we want to set an explicte set of permissions, do not + merge with current DACL. */ + if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS) + return; + } + else + if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS) + return; + + if (SetSecurityInfo + (file, SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS) + return; + + LocalFree (pSD); + LocalFree (pNewDACL); + CloseHandle (file); +} +#endif /* defined (_WIN32) && !defined (RTX) */ + int __gnat_is_readable_file (char *name) { +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericRead = GENERIC_READ; + + return __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); +#else int ret; int mode; struct stat statbuf; @@ -1687,11 +1831,25 @@ __gnat_is_readable_file (char *name) ret = __gnat_stat (name, &statbuf); mode = statbuf.st_mode & S_IRUSR; return (!ret && mode); +#endif } int __gnat_is_writable_file (char *name) { +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericWrite = GENERIC_WRITE; + + return __gnat_check_OWNER_ACL + (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping) + && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); +#else int ret; int mode; struct stat statbuf; @@ -1699,12 +1857,45 @@ __gnat_is_writable_file (char *name) ret = __gnat_stat (name, &statbuf); mode = statbuf.st_mode & S_IWUSR; return (!ret && mode); +#endif +} + +int +__gnat_is_executable_file (char *name) +{ +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericExecute = GENERIC_EXECUTE; + + return __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); +#else + int ret; + int mode; + struct stat statbuf; + + ret = __gnat_stat (name, &statbuf); + mode = statbuf.st_mode & S_IXUSR; + return (!ret && mode); +#endif } void __gnat_set_writable (char *name) { -#if ! defined (__vxworks) && ! defined(__nucleus__) +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, GENERIC_WRITE); + SetFileAttributes + (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY); +#elif ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) @@ -1718,7 +1909,13 @@ __gnat_set_writable (char *name) void __gnat_set_executable (char *name) { -#if ! defined (__vxworks) && ! defined(__nucleus__) +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, GENERIC_EXECUTE); +#elif ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) @@ -1732,7 +1929,15 @@ __gnat_set_executable (char *name) void __gnat_set_readonly (char *name) { -#if ! defined (__vxworks) && ! defined(__nucleus__) +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2); + + __gnat_set_OWNER_ACL (wname, SET_ACCESS, GENERIC_READ); + SetFileAttributes + (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY); +#elif ! defined (__vxworks) && ! defined(__nucleus__) struct stat statbuf; if (stat (name, &statbuf) == 0) diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 7b1e86df960..a447c0fa58a 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -101,6 +101,7 @@ extern int __gnat_is_absolute_path (char *,int); extern int __gnat_is_directory (char *); extern int __gnat_is_writable_file (char *); extern int __gnat_is_readable_file (char *name); +extern int __gnat_is_executable_file (char *name); extern void __gnat_set_readonly (char *name); extern void __gnat_set_writable (char *name); extern void __gnat_set_executable (char *name); diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 204496a9f11..070651cbd6a 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -126,7 +126,6 @@ package body Bindgen is -- Detect_Blocking : Integer; -- Default_Stack_Size : Integer; -- Leap_Seconds_Support : Integer; - -- Canonical_Streams : Integer; -- Main_Priority is the priority value set by pragma Priority in the main -- program. If no such pragma is present, the value is -1. @@ -212,10 +211,6 @@ package body Bindgen is -- disabled. A value of zero indicates that leap seconds are turned "off", -- while a value of one signifies "on" status. - -- Canonical_Streams indicates whether stream-related optimizations are - -- active. A value of zero indicates that all optimizations are active, - -- while a value of one signifies that they have been disabled. - ----------------------- -- Local Subprograms -- ----------------------- @@ -596,9 +591,6 @@ package body Bindgen is WBI (" Leap_Seconds_Support : Integer;"); WBI (" pragma Import (C, Leap_Seconds_Support, " & """__gl_leap_seconds_support"");"); - WBI (" Canonical_Streams : Integer;"); - WBI (" pragma Import (C, Canonical_Streams, " & - """__gl_canonical_streams"");"); -- Import entry point for elaboration time signal handler -- installation, and indication of if it's been called previously. @@ -767,17 +759,6 @@ package body Bindgen is Set_String (";"); Write_Statement_Buffer; - Set_String (" Canonical_Streams := "); - - if Canonical_Streams then - Set_Int (1); - else - Set_Int (0); - end if; - - Set_String (";"); - Write_Statement_Buffer; - -- Generate call to Install_Handler WBI (""); @@ -1059,18 +1040,6 @@ package body Bindgen is Set_String (";"); Write_Statement_Buffer; - WBI (" extern int __gl_canonical_streams;"); - Set_String (" __gl_canonical_streams = "); - - if Canonical_Streams then - Set_Int (1); - else - Set_Int (0); - end if; - - Set_String (";"); - Write_Statement_Buffer; - WBI (""); -- Install elaboration time signal handler diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6eb7ebbbbc3..38b1a07e409 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1633,11 +1633,36 @@ package body Checks is end; end if; - -- Get the bounds of the target type + -- Get the (static) bounds of the target type Ifirst := Expr_Value (LB); Ilast := Expr_Value (HB); + -- A simple optimization: if the expression is a universal literal, + -- we can do the comparison with the bounds and the conversion to + -- an integer type statically. The range checks are unchanged. + + if Nkind (Ck_Node) = N_Real_Literal + and then Etype (Ck_Node) = Universal_Real + and then Is_Integer_Type (Target_Typ) + and then Nkind (Parent (Ck_Node)) = N_Type_Conversion + then + declare + Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node)); + + begin + if Int_Val <= Ilast and then Int_Val >= Ifirst then + + -- Conversion is safe. + + Rewrite (Parent (Ck_Node), + Make_Integer_Literal (Loc, UI_To_Int (Int_Val))); + Analyze_And_Resolve (Parent (Ck_Node), Target_Typ); + return; + end if; + end; + end if; + -- Check against lower bound if Truncate and then Ifirst > 0 then @@ -2846,11 +2871,7 @@ package body Checks is -- be applied to a [sub]type that does not exclude null already. elsif Can_Never_Be_Null (Typ) - - -- No need to check itypes that have a null exclusion because - -- they are already examined at their point of creation. - - and then not Is_Itype (Typ) + and then Comes_From_Source (Typ) then Error_Msg_NE ("`NOT NULL` not allowed (& already excludes null)", @@ -5281,10 +5302,20 @@ package body Checks is -- If known to be null, here is where we generate a compile time check if Known_Null (N) then - Apply_Compile_Time_Constraint_Error - (N, - "null value not allowed here?", - CE_Access_Check_Failed); + + -- Avoid generating warning message inside init procs + + if not Inside_Init_Proc then + Apply_Compile_Time_Constraint_Error + (N, + "null value not allowed here?", + CE_Access_Check_Failed); + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + Mark_Non_Null; return; end if; diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index fe81bcbe97e..79dde9331c0 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -6,7 +6,7 @@ * * * Auxiliary C functions for Interfaces.C.Streams * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -156,7 +156,18 @@ __gnat_constant_stdout (void) char * __gnat_full_name (char *nam, char *buffer) { -#if defined(__EMX__) || defined (__MINGW32__) +#ifdef RTSS + /* RTSS applications have no current-directory notion, so RTSS file I/O + requests must use fully qualified path names, such as: + c:\temp\MyFile.txt (for a file system object) + \\.\MyDevice0 (for a device object) + */ + if (nam[1] == ':' || nam[0] == '\\') + strcpy (buffer, nam); + else + buffer[0] = '\0'; + +#elif defined(__EMX__) || defined (__MINGW32__) /* If this is a device file return it as is; under Windows NT and OS/2 a device file end with ":". */ if (nam[strlen (nam) - 1] == ':') diff --git a/gcc/ada/directio.ads b/gcc/ada/directio.ads index b69ca4467e1..c09f77270b9 100644 --- a/gcc/ada/directio.ads +++ b/gcc/ada/directio.ads @@ -15,9 +15,9 @@ pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and Text_IO is not considered to --- be an internal unit that is automatically compiled in Ada 2005 mode (since --- a user is allowed to redeclare Direct_IO). +-- child unit (not possible in Ada 83 mode), and Direct_IO is not considered +-- to be an internal unit that is automatically compiled in Ada 2005 mode +-- (since a user is allowed to redeclare Direct_IO). with Ada.Direct_IO; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index eaff8e89a9e..bc3b954fb6c 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2436,8 +2436,12 @@ package body Exp_Aggr is -- to the actual type of the aggregate, so that the proper components -- are visible. We know already that the types are compatible. + -- There should also be a comment here explaining why the conversion + -- is needed in the case of interfaces.??? + if Present (Etype (Lhs)) - and then Is_Interface (Etype (Lhs)) + and then (Is_Interface (Etype (Lhs)) + or else Is_Class_Wide_Type (Etype (Lhs))) then Target := Unchecked_Convert_To (Typ, Lhs); else diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 84bc808b86f..890f09b1d82 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -33,6 +33,7 @@ with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; +with Exp_Dist; use Exp_Dist; with Exp_Imgv; use Exp_Imgv; with Exp_Pakd; use Exp_Pakd; with Exp_Strm; use Exp_Strm; @@ -2075,6 +2076,22 @@ package body Exp_Attr is Expand_Fpt_Attribute_R (N); -------------- + -- From_Any -- + -------------- + + when Attribute_From_Any => From_Any : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, + Build_From_Any_Call (P_Type, + Relocate_Node (First (Exprs)), + Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, P_Type); + end From_Any; + + -------------- -- Identity -- -------------- @@ -4396,6 +4413,22 @@ package body Exp_Attr is Relocate_Node (First (Exprs)))); Analyze_And_Resolve (N, RTE (RE_Address)); + ------------ + -- To_Any -- + ------------ + + when Attribute_To_Any => To_Any : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, + Build_To_Any_Call + (Convert_To (P_Type, + Relocate_Node (First (Exprs))), Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, RTE (RE_Any)); + end To_Any; + ---------------- -- Truncation -- ---------------- @@ -4409,6 +4442,19 @@ package body Exp_Attr is Expand_Fpt_Attribute_R (N); end if; + -------------- + -- TypeCode -- + -------------- + + when Attribute_TypeCode => TypeCode : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, RTE (RE_TypeCode)); + end TypeCode; + ----------------------- -- Unbiased_Rounding -- ----------------------- @@ -5365,53 +5411,100 @@ package body Exp_Attr is and then not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then - -- String as defined in package Ada if Base_Typ = Standard_String then - if Nam = TSS_Stream_Input then - return RTE (RE_String_Input); + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output); - elsif Nam = TSS_Stream_Output then - return RTE (RE_String_Output); + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read); - elsif Nam = TSS_Stream_Read then - return RTE (RE_String_Read); + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read_Blk_IO); - else pragma Assert (Nam = TSS_Stream_Write); - return RTE (RE_String_Write); + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write_Blk_IO); + end if; end if; -- Wide_String as defined in package Ada elsif Base_Typ = Standard_Wide_String then - if Nam = TSS_Stream_Input then - return RTE (RE_Wide_String_Input); + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write); + end if; - elsif Nam = TSS_Stream_Output then - return RTE (RE_Wide_String_Output); + else + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output_Blk_IO); - elsif Nam = TSS_Stream_Read then - return RTE (RE_Wide_String_Read); + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read_Blk_IO); - else pragma Assert (Nam = TSS_Stream_Write); - return RTE (RE_Wide_String_Write); + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write_Blk_IO); + end if; end if; -- Wide_Wide_String as defined in package Ada elsif Base_Typ = Standard_Wide_Wide_String then - if Nam = TSS_Stream_Input then - return RTE (RE_Wide_Wide_String_Input); + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read); - elsif Nam = TSS_Stream_Output then - return RTE (RE_Wide_Wide_String_Output); + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input_Blk_IO); - elsif Nam = TSS_Stream_Read then - return RTE (RE_Wide_Wide_String_Read); + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output_Blk_IO); - else pragma Assert (Nam = TSS_Stream_Write); - return RTE (RE_Wide_Wide_String_Write); + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write_Blk_IO); + end if; end if; end if; end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b110121bc5e..92a5f8c3b60 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1826,23 +1826,6 @@ package body Exp_Ch3 is Attribute_Name => Name_Unrestricted_Access); end if; - -- Ada 2005 (AI-231): Add the run-time check if required - - if Ada_Version >= Ada_05 - and then Can_Never_Be_Null (Etype (Id)) -- Lhs - then - if Known_Null (Exp) then - return New_List ( - Make_Raise_Constraint_Error (Sloc (Exp), - Reason => CE_Null_Not_Allowed)); - - elsif Present (Etype (Exp)) - and then not Can_Never_Be_Null (Etype (Exp)) - then - Install_Null_Excluding_Check (Exp); - end if; - end if; - -- Take a copy of Exp to ensure that later copies of this component -- declaration in derived types see the original tree, not a node -- rewritten during expansion of the init_proc. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ba09aa69807..b1243d7a280 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -977,8 +977,7 @@ package body Exp_Ch4 is -- not allow sliding, but this check does (a relaxation from Ada 83). if Is_Constrained (DesigT) - and then not Subtypes_Statically_Match - (T, DesigT) + and then not Subtypes_Statically_Match (T, DesigT) then Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); @@ -8354,7 +8353,9 @@ package body Exp_Ch4 is -- chain. The Final_Chain that is thus created is shared by the -- access parameter. The access type is tested against the result -- type of the function to exclude allocators whose type is an - -- anonymous access result type. + -- anonymous access result type. We freeze the type at once to + -- ensure that it is properly decorated for the back-end, even + -- if the context and current scope is a loop. if Nkind (Associated_Node_For_Itype (PtrT)) in N_Subprogram_Specification @@ -8371,6 +8372,7 @@ package body Exp_Ch4 is Subtype_Indication => New_Occurrence_Of (T, Loc)))); + Freeze_Before (N, Owner); Build_Final_List (N, Owner); Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 18ea8fe44db..729c126f4d6 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3695,22 +3695,39 @@ package body Exp_Ch5 is Return_Object_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Subtype_Ind : Node_Id; - Subtype_Ind : constant Node_Id := New_Occurrence_Of (R_Type, Loc); + begin + -- If the result type of the function is class-wide and the + -- expression has a specific type, then we use the expression's + -- type as the type of the return object. In cases where the + -- expression is an aggregate that is built in place, this avoids + -- the need for an expensive conversion of the return object to + -- the specific type on assignments to the individual components. + + if Is_Class_Wide_Type (R_Type) + and then not Is_Class_Wide_Type (Etype (Exp)) + then + Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); + else + Subtype_Ind := New_Occurrence_Of (R_Type, Loc); + end if; - Obj_Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Object_Entity, - Object_Definition => Subtype_Ind, - Expression => Exp); + declare + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Object_Entity, + Object_Definition => Subtype_Ind, + Expression => Exp); - Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Obj_Decl)); + Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl)); - begin - Rewrite (N, Ext); - Analyze (N); - return; + begin + Rewrite (N, Ext); + Analyze (N); + return; + end; end; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d1d43cf3974..4c3f3da63f9 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2034,15 +2034,6 @@ package body Exp_Ch6 is Prev := Actual; Prev_Orig := Original_Node (Prev); - -- The original actual may have been a call written in prefix - -- form, and rewritten before analysis. - - if not Analyzed (Prev_Orig) - and then Nkind_In (Actual, N_Function_Call, N_Identifier) - then - Prev_Orig := Prev; - end if; - -- Ada 2005 (AI-251): Check if any formal is a class-wide interface -- to expand it in a further round. @@ -2293,13 +2284,15 @@ package body Exp_Ch6 is Intval => Scope_Depth (Current_Scope) + 1), Extra_Accessibility (Formal)); - -- For other cases we simply pass the level of the - -- actual's access type. + -- For other cases we simply pass the level of the actual's + -- access type. The type is retrieved from Prev rather than + -- Prev_Orig, because in some cases Prev_Orig denotes an + -- original expression that has not been analyzed. when others => Add_Extra_Actual (Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Etype (Prev_Orig))), + Intval => Type_Access_Level (Etype (Prev))), Extra_Accessibility (Formal)); end case; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index ac25171abf7..461edc75a3d 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -766,6 +766,13 @@ package body Exp_Disp is Iface_Typ := Root_Type (Iface_Typ); end if; + -- If the target type is a tagged synchronized type, the dispatch table + -- info is in the correspondoing record type. + + if Is_Concurrent_Type (Iface_Typ) then + Iface_Typ := Corresponding_Record_Type (Iface_Typ); + end if; + pragma Assert (not Is_Static or else (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ))); diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index c22239277bf..38693f13b6a 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -858,6 +858,25 @@ package body Exp_Dist is end PolyORB_Support; + -- The following PolyORB-specific subprograms are made visible to Exp_Attr: + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_From_Any_Call; + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_To_Any_Call; + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_TypeCode_Call; + ------------------------------------ -- Local variables and structures -- ------------------------------------ @@ -8218,12 +8237,11 @@ package body Exp_Dist is -- point type from Standard, or the smallest unsigned (modular) type -- from System.Unsigned_Types, whose range encompasses that of Typ. - function Make_Stream_Procedure_Function_Name + function Make_Helper_Function_Name (Loc : Source_Ptr; Typ : Entity_Id; Nam : Name_Id) return Entity_Id; - -- Return the name to be assigned for stream subprogram Nam of Typ. - -- (copied from exp_strm.adb, should be shared???) + -- Return the name to be assigned for helper subprogram Nam of Typ ------------------------------------------------------------ -- Common subprograms for building various tree fragments -- @@ -8432,6 +8450,11 @@ package body Exp_Dist is elsif U_Type = Standard_String then Lib_RE := RE_FA_String; + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then + Lib_RE := RE_FA_A; + -- Other (non-primitive) types else @@ -8493,8 +8516,7 @@ package body Exp_Dist is return; end if; - Fnam := - Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uFrom_Any); + Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); Spec := Make_Function_Specification (Loc, @@ -9293,7 +9315,13 @@ package body Exp_Dist is elsif U_Type = Standard_String then Lib_RE := RE_TA_String; + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then + Lib_RE := RE_TA_A; + elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then + -- No corresponding FA_TC ??? Lib_RE := RE_TA_TC; -- Other (non-primitive) types @@ -9358,8 +9386,7 @@ package body Exp_Dist is return; end if; - Fnam := - Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uTo_Any); + Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); Spec := Make_Function_Specification (Loc, @@ -9976,7 +10003,7 @@ package body Exp_Dist is -- not been set yet, so can't call Find_Inherited_TSS. if Typ = RTE (RE_Any) then - Fnam := RTE (RE_TC_Any); + Fnam := RTE (RE_TC_A); else -- First simple case where the TypeCode is present @@ -10057,6 +10084,11 @@ package body Exp_Dist is elsif U_Type = Standard_String then Lib_RE := RE_TC_String; + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then + Lib_RE := RE_TC_A; + -- Other (non-primitive) types else @@ -10100,8 +10132,7 @@ package body Exp_Dist is Stms : constant List_Id := New_List; TCNam : constant Entity_Id := - Make_Stream_Procedure_Function_Name (Loc, - Typ, Name_uTypeCode); + Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); Parameters : List_Id; @@ -10964,30 +10995,40 @@ package body Exp_Dist is end; end Append_Array_Traversal; - ----------------------------------------- - -- Make_Stream_Procedure_Function_Name -- - ----------------------------------------- + ------------------------------- + -- Make_Helper_Function_Name -- + ------------------------------- - function Make_Stream_Procedure_Function_Name + function Make_Helper_Function_Name (Loc : Source_Ptr; Typ : Entity_Id; Nam : Name_Id) return Entity_Id is begin - -- For tagged types, we use a canonical name so that it matches - -- the primitive spec. For all other cases, we use a serialized - -- name so that multiple generations of the same procedure do not - -- clash. + declare + Serial : Nat := 0; + -- For tagged types, we use a canonical name so that it matches + -- the primitive spec. For all other cases, we use a serialized + -- name so that multiple generations of the same procedure do + -- not clash. + + begin + if not Is_Tagged_Type (Typ) then + Serial := Increment_Serial_Number; + end if; + + -- Use prefixed underscore to avoid potential clash with used + -- identifier (we use attribute names for Nam). - if Is_Tagged_Type (Typ) then - return Make_Defining_Identifier (Loc, Nam); - else return Make_Defining_Identifier (Loc, Chars => - New_External_Name (Nam, ' ', Increment_Serial_Number)); - end if; - end Make_Stream_Procedure_Function_Name; + New_External_Name + (Related_Id => Nam, + Suffix => ' ', Suffix_Index => Serial, + Prefix => '_')); + end; + end Make_Helper_Function_Name; end Helpers; ----------------------------------- diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index a1418d3f6bb..26995a8b9f9 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -129,4 +129,37 @@ package Exp_Dist is -- a remote call) satisfies the requirements for being transportable -- across partitions, raising Program_Error if it does not. + ---------------------------------------------------------------- + -- Functions for expansion of PolyORB/DSA specific attributes -- + ---------------------------------------------------------------- + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to From_Any attribute function of type Typ with expression + -- N as actual parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if the + -- From_Any attribute for Typ needs to be generated at this point, its + -- declaration is appended to Decls. + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to To_Any attribute function with expression as actual + -- parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if + -- the To_Any attribute for Typ needs to be generated at this point, + -- its declaration is appended to Decls. + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id; + -- Build call to TypeCode attribute function for Typ. Decls is the + -- declarations list for an appropriate enclosing scope of the point + -- where the call will be inserted; if the To_Any attribute for Typ + -- needs to be generated at this point, its declaration is appended + -- to Decls. + end Exp_Dist; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 31f93985c44..dffcbaf3b40 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2398,6 +2398,8 @@ package body Freeze is elsif Root_Type (F_Type) = Standard_Boolean and then Convention (F_Type) = Convention_Ada + and then not Has_Warnings_Off (F_Type) + and then not Has_Size_Clause (F_Type) then Error_Msg_N ("?& is an 8-bit Ada Boolean, " @@ -2543,6 +2545,7 @@ package body Freeze is and then Convention (R_Type) = Convention_Ada and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (R_Type) + and then not Has_Size_Clause (R_Type) then Error_Msg_N ("?return type of & is an 8-bit " @@ -2662,7 +2665,8 @@ package body Freeze is -- ever default initialized, and is why the check is deferred -- until freezing, at which point we know if Import applies. - if not Is_Imported (E) + if Comes_From_Source (E) + and then not Is_Imported (E) and then not Has_Init_Expression (Declaration_Node (E)) and then ((Has_Non_Null_Base_Init_Proc (Etype (E)) diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index c9cb4dbad25..32460c0599b 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -32,7 +32,9 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; -with GNAT.OS_Lib; use GNAT.OS_Lib; +with Ada.Strings.Unbounded; + +with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Command_Line is @@ -101,8 +103,6 @@ package body GNAT.Command_Line is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Command_Line_Configuration_Record, Command_Line_Configuration); - type Boolean_Chars is array (Character) of Boolean; - procedure Remove (Line : in out Argument_List_Access; Index : Integer); -- Remove a specific element from Line @@ -111,9 +111,6 @@ package body GNAT.Command_Line is Str : String_Access); -- Append a new element to Line - function Args_From_Expanded (Args : Boolean_Chars) return String; - -- Return the string made of all characters with True in Args - generic with procedure Callback (Simple_Switch : String); procedure For_Each_Simple_Switch @@ -1050,25 +1047,6 @@ package body GNAT.Command_Line is end if; end Free; - ------------------------ - -- Args_From_Expanded -- - ------------------------ - - function Args_From_Expanded (Args : Boolean_Chars) return String is - Result : String (1 .. Args'Length); - Index : Natural := Result'First; - - begin - for A in Args'Range loop - if Args (A) then - Result (Index) := A; - Index := Index + 1; - end if; - end loop; - - return Result (1 .. Index - 1); - end Args_From_Expanded; - ------------------ -- Define_Alias -- ------------------ @@ -1470,12 +1448,9 @@ package body GNAT.Command_Line is Result : Argument_List_Access; Params : Argument_List_Access) is - type Boolean_Array is array (Result'Range) of Boolean; - - Matched : Boolean_Array; - Count : Natural; + Group : Ada.Strings.Unbounded.Unbounded_String; First : Natural; - From_Args : Boolean_Chars; + use type Ada.Strings.Unbounded.Unbounded_String; begin if Cmd.Config = null @@ -1485,8 +1460,8 @@ package body GNAT.Command_Line is end if; for P in Cmd.Config.Prefixes'Range loop - Matched := (others => False); - Count := 0; + Group := Ada.Strings.Unbounded.Null_Unbounded_String; + First := 0; for C in Result'Range loop if Result (C) /= null @@ -1494,32 +1469,25 @@ package body GNAT.Command_Line is and then Looking_At (Result (C).all, Result (C)'First, Cmd.Config.Prefixes (P).all) then - Matched (C) := True; - Count := Count + 1; + Group := + Group & + Result (C) + (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. + Result (C)'Last); + + if First = 0 then + First := C; + end if; + + Free (Result (C)); end if; end loop; - if Count > 1 then - From_Args := (others => False); - First := 0; - - for M in Matched'Range loop - if Matched (M) then - if First = 0 then - First := M; - end if; - - for A in Result (M)'First + Cmd.Config.Prefixes (P)'Length - .. Result (M)'Last - loop - From_Args (Result (M)(A)) := True; - end loop; - Free (Result (M)); - end if; - end loop; - - Result (First) := new String' - (Cmd.Config.Prefixes (P).all & Args_From_Expanded (From_Args)); + if First > 0 then + Result (First) := + new String' + (Cmd.Config.Prefixes (P).all & + Ada.Strings.Unbounded.To_String (Group)); end if; end loop; end Group_Switches; diff --git a/gcc/ada/g-soccon-mingw-64.ads b/gcc/ada/g-soccon-mingw-64.ads new file mode 100644 index 00000000000..cc84740b15f --- /dev/null +++ b/gcc/ada/g-soccon-mingw-64.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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 provides target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for x86_64-mingw32msv +-- This file is generated automatically, do not modify it by hand! Instead, +-- make changes to gen-soccon.c and re-run it on each target. + +with Interfaces.C; +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 23; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 10013; -- Permission denied + EADDRINUSE : constant := 10048; -- Address already in use + EADDRNOTAVAIL : constant := 10049; -- Cannot assign address + EAFNOSUPPORT : constant := 10047; -- Addr family not supported + EALREADY : constant := 10037; -- Operation in progress + EBADF : constant := 10009; -- Bad file descriptor + ECONNABORTED : constant := 10053; -- Connection aborted + ECONNREFUSED : constant := 10061; -- Connection refused + ECONNRESET : constant := 10054; -- Connection reset by peer + EDESTADDRREQ : constant := 10039; -- Destination addr required + EFAULT : constant := 10014; -- Bad address + EHOSTDOWN : constant := 10064; -- Host is down + EHOSTUNREACH : constant := 10065; -- No route to host + EINPROGRESS : constant := 10036; -- Operation now in progress + EINTR : constant := 10004; -- Interrupted system call + EINVAL : constant := 10022; -- Invalid argument + EIO : constant := 10101; -- Input output error + EISCONN : constant := 10056; -- Socket already connected + ELOOP : constant := 10062; -- Too many symbolic links + EMFILE : constant := 10024; -- Too many open files + EMSGSIZE : constant := 10040; -- Message too long + ENAMETOOLONG : constant := 10063; -- Name too long + ENETDOWN : constant := 10050; -- Network is down + ENETRESET : constant := 10052; -- Disconn. on network reset + ENETUNREACH : constant := 10051; -- Network is unreachable + ENOBUFS : constant := 10055; -- No buffer space available + ENOPROTOOPT : constant := 10042; -- Protocol not available + ENOTCONN : constant := 10057; -- Socket not connected + ENOTSOCK : constant := 10038; -- Operation on non socket + EOPNOTSUPP : constant := 10045; -- Operation not supported + EPFNOSUPPORT : constant := 10046; -- Unknown protocol family + EPROTONOSUPPORT : constant := 10043; -- Unknown protocol + EPROTOTYPE : constant := 10041; -- Unknown protocol type + ESHUTDOWN : constant := 10058; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported + ETIMEDOUT : constant := 10060; -- Connection timed out + ETOOMANYREFS : constant := 10059; -- Too many references + EWOULDBLOCK : constant := 10035; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 11001; -- Unknown host + TRY_AGAIN : constant := 11002; -- Host name lookup failure + NO_DATA : constant := 11004; -- No data record for name + NO_RECOVERY : constant := 11003; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := -1; -- Send end of record + MSG_WAITALL : constant := 8; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; + -- Flags set on all send(2) calls + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := 19; -- Get datagram info + + ------------------- + -- System limits -- + ------------------- + + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + + ---------------------- + -- Type definitions -- + ---------------------- + + -- Sizes (in bytes) of the components of struct timeval + + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 8200; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.short; + subtype H_Length_T is Interfaces.C.short; + + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + + ------------------------------ + -- MinGW-specific constants -- + ------------------------------ + + -- These constants may be used only within the MinGW version of + -- GNAT.Sockets.Thin. + + WSASYSNOTREADY : constant := 10091; -- System not ready + WSAVERNOTSUPPORTED : constant := 10092; -- Version not supported + WSANOTINITIALISED : constant := 10093; -- Winsock not initialized + WSAEDISCON : constant := 10101; -- Disconnected + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index acc523d8abb..ff8ebbe52b1 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1318,11 +1318,11 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) g-socthi.ads<g-socthi-mingw.ads \ g-socthi.adb<g-socthi-mingw.adb \ g-stsifd.adb<g-stsifd-sockets.adb \ - g-soccon.ads<g-soccon-mingw.ads \ g-soliop.ads<g-soliop-mingw.ads ifeq ($(strip $(filter-out rtx_w32 rtx_rtss,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ + g-soccon.ads<g-soccon-mingw.ads \ s-intman.adb<s-intman-dummy.adb \ s-osinte.ads<s-osinte-rtx.ads \ s-osprim.adb<s-osprim-rtx.adb \ @@ -1352,10 +1352,19 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) s-intman.adb<s-intman-mingw.adb \ s-osinte.ads<s-osinte-mingw.ads \ s-osprim.adb<s-osprim-mingw.adb \ - s-taprop.adb<s-taprop-mingw.adb \ - system.ads<system-mingw.ads + s-taprop.adb<s-taprop-mingw.adb - EXTRA_GNATRTL_NONTASKING_OBJS = s-win32.o s-winext.o g-regist.o + ifeq ($(strip $(filter-out x86_64%,$(arch))),) + LIBGNAT_TARGET_PAIRS += \ + g-soccon.ads<g-soccon-mingw-64.ads \ + system.ads<system-mingw-x86_64.ads + else + LIBGNAT_TARGET_PAIRS += \ + g-soccon.ads<g-soccon-mingw.ads \ + system.ads<system-mingw.ads + endif + + EXTRA_GNATRTL_NONTASKING_OBJS = s-win32.o s-win32.o g-regist.o EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o MISCLIB = -lwsock32 diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 9472995effc..1db5ce28ecf 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -294,10 +294,10 @@ struct lang_type GTY(()) {tree t; }; #define SET_DECL_FUNCTION_STUB(NODE, X) \ SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X) -/* In a PARM_DECL, points to the alternate TREE_TYPE */ -#define DECL_PARM_ALT(NODE) \ +/* In a PARM_DECL, points to the alternate TREE_TYPE. */ +#define DECL_PARM_ALT_TYPE(NODE) \ GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE)) -#define SET_DECL_PARM_ALT(NODE, X) \ +#define SET_DECL_PARM_ALT_TYPE(NODE, X) \ SET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE), X) /* In a FIELD_DECL corresponding to a discriminant, contains the diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index f8ebf5a58be..c9e90457803 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -367,12 +367,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) switch (kind) { case E_Constant: - /* If this is a use of a deferred constant, get its full - declaration. */ - if (!definition && Present (Full_View (gnat_entity))) + /* If this is a use of a deferred constant without address clause, + get its full definition. */ + if (!definition + && No (Address_Clause (gnat_entity)) + && Present (Full_View (gnat_entity))) { - gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), - gnu_expr, 0); + gnu_decl + = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0); saved = true; break; } @@ -391,12 +393,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) != N_Allocator)) gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); - /* Ignore deferred constant definitions; they are processed fully in the - front-end. For deferred constant references get the full definition. - On the other hand, constants that are renamings are handled like - variable renamings. If No_Initialization is set, this is not a - deferred constant but a constant whose value is built manually. */ - if (definition && !gnu_expr + /* Ignore deferred constant definitions without address clause since + they are processed fully in the front-end. If No_Initialization + is set, this is not a deferred constant but a constant whose value + is built manually. And constants that are renamings are handled + like variables. */ + if (definition + && !gnu_expr + && No (Address_Clause (gnat_entity)) && !No_Initialization (Declaration_Node (gnat_entity)) && No (Renamed_Object (gnat_entity))) { @@ -404,12 +408,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) saved = true; break; } - else if (!definition && IN (kind, Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity))) + + /* Ignore constant definitions already marked with the error node. See + the N_Object_Declaration case of gnat_to_gnu for the rationale. */ + if (definition + && gnu_expr + && present_gnu_tree (gnat_entity) + && get_gnu_tree (gnat_entity) == error_mark_node) { - gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), - NULL_TREE, 0); - saved = true; + maybe_present = true; break; } @@ -1037,17 +1044,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && !Is_Imported (gnat_entity) && !gnu_expr) gnu_expr = integer_zero_node; - /* If we are defining the object and it has an Address clause we must - get the address expression from the saved GCC tree for the - object if the object has a Freeze_Node. Otherwise, we elaborate - the address expression here since the front-end has guaranteed - in that case that the elaboration has no effects. Note that - only the latter mechanism is currently in use. */ + /* If we are defining the object and it has an Address clause, we must + either get the address expression from the saved GCC tree for the + object if it has a Freeze node, or elaborate the address expression + here since the front-end has guaranteed that the elaboration has no + effects in this case. */ if (definition && Present (Address_Clause (gnat_entity))) { tree gnu_address - = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) - : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); + = present_gnu_tree (gnat_entity) + ? get_gnu_tree (gnat_entity) + : gnat_to_gnu (Expression (Address_Clause (gnat_entity))); save_gnu_tree (gnat_entity, NULL_TREE, false); @@ -1064,6 +1071,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || compile_time_known_address_p (Expression (Address_Clause (gnat_entity))); + /* If this is a deferred constant, the initializer is attached to + the full view. */ + if (kind == E_Constant && Present (Full_View (gnat_entity))) + gnu_expr + = gnat_to_gnu + (Expression (Declaration_Node (Full_View (gnat_entity)))); + /* If we don't have an initializing expression for the underlying variable, the initializing expression for the pointer is the specified address. Otherwise, we have to make a COMPOUND_EXPR @@ -3872,6 +3886,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ; else if (By_Descriptor_Last <= mech && mech <= By_Descriptor) mech = By_Descriptor; + + else if (By_Short_Descriptor_Last <= mech && + mech <= By_Short_Descriptor) + mech = By_Short_Descriptor; + else if (mech > 0) { if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE @@ -3913,7 +3932,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = chainon (gnu_param, gnu_stub_param_list); /* Change By_Descriptor parameter to By_Reference for the internal version of an exported subprogram. */ - if (mech == By_Descriptor) + if (mech == By_Descriptor || mech == By_Short_Descriptor) { gnu_param = gnat_to_gnu_param (gnat_param, By_Reference, @@ -4020,19 +4039,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (TREE_CODE (gnu_return_type) == VOID_TYPE) pure_flag = false; - /* The semantics of "pure" in Ada essentially matches that of "const" - in the back-end. In particular, both properties are orthogonal to - the "nothrow" property. But this is true only if the EH circuitry - is explicit in the internal representation of the back-end. If we - are to completely hide the EH circuitry from it, we need to declare - that calls to pure Ada subprograms that can throw have side effects - since they can trigger an "abnormal" transfer of control flow; thus - they can be neither "const" nor "pure" in the back-end sense. */ + /* The semantics of "pure" in Ada used to essentially match that of + "const" in the middle-end. In particular, both properties were + orthogonal to the "nothrow" property. This is not true in the + middle-end any more and we have no choice but to ignore the hint + at this stage. */ + gnu_type = build_qualified_type (gnu_type, TYPE_QUALS (gnu_type) - | (Exception_Mechanism == Back_End_Exceptions - ? TYPE_QUAL_CONST * pure_flag : 0) | (TYPE_QUAL_VOLATILE * volatile_flag)); Sloc_to_locus (Sloc (gnat_entity), &input_location); @@ -4826,13 +4841,13 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, gnu_param_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type)))); - /* VMS descriptors are themselves passed by reference. - Build both a 32bit and 64bit descriptor, one of which will be chosen - in fill_vms_descriptor based on the allocator size */ + /* VMS descriptors are themselves passed by reference. */ if (mech == By_Descriptor) { + /* Build both a 32-bit and 64-bit descriptor, one of which will be + chosen in fill_vms_descriptor. */ gnu_param_type_alt - = build_pointer_type (build_vms_descriptor64 (gnu_param_type, + = build_pointer_type (build_vms_descriptor32 (gnu_param_type, Mechanism (gnat_param), gnat_subprog)); gnu_param_type @@ -4840,6 +4855,11 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, Mechanism (gnat_param), gnat_subprog)); } + else if (mech == By_Short_Descriptor) + gnu_param_type + = build_pointer_type (build_vms_descriptor32 (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); /* Arrays are passed as pointers to element type for foreign conventions. */ else if (foreign @@ -4920,6 +4940,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, && !by_ref && (by_return || (mech != By_Descriptor + && mech != By_Short_Descriptor && !POINTER_TYPE_P (gnu_param_type) && !AGGREGATE_TYPE_P (gnu_param_type))) && !(Is_Array_Type (Etype (gnat_param)) @@ -4931,12 +4952,14 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, ro_param || by_ref || by_component_ptr); DECL_BY_REF_P (gnu_param) = by_ref; DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; - DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor); + DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor || + mech == By_Short_Descriptor); DECL_POINTS_TO_READONLY_P (gnu_param) = (ro_param && (by_ref || by_component_ptr)); - /* Save the 64bit descriptor for later. */ - SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt); + /* Save the alternate descriptor type, if any. */ + if (gnu_param_type_alt) + SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt); /* If no Mechanism was specified, indicate what we're using, then back-annotate it. */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index f44fec89abd..1b3fa24137c 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -683,7 +683,7 @@ extern void end_subprog_body (tree body, bool elab_p); Return a constructor for the template. */ extern tree build_template (tree template_type, tree array_type, tree expr); -/* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify +/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify a descriptor type, and the GCC type of an object. Each FIELD_DECL in the type contains in its DECL_INITIAL the expression to use when a constructor is made for the type. GNAT_ENTITY is a gnat node used @@ -692,8 +692,8 @@ extern tree build_template (tree template_type, tree array_type, tree expr); extern tree build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity); -/* Build a 64bit VMS descriptor from a Mechanism_Type. See above. */ -extern tree build_vms_descriptor64 (tree type, Mechanism_Type mech, +/* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */ +extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity); /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG @@ -853,9 +853,10 @@ extern tree build_allocator (tree type, tree init, tree result_type, Node_Id gnat_node, bool); /* Fill in a VMS descriptor for EXPR and return a constructor for it. - GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how we - find the size of the allocator. */ -extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual); + GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how + we derive the source location on a C_E */ +extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, + Node_Id gnat_actual); /* Indicate that we need to make the address of EXPR_NODE and it therefore should not be allocated in a register. Return true if successful. */ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index f8e1d49eaa2..97ff3bd2269 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -3398,6 +3398,15 @@ gnat_to_gnu (Node_Id gnat_node) if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK) gnu_expr = NULL_TREE; + /* If this is a deferred constant with an address clause, we ignore the + full view since the clause is on the partial view and we cannot have + 2 different GCC trees for the object. The only bits of the full view + we will use is the initializer, but it will be directly fetched. */ + if (Ekind(gnat_temp) == E_Constant + && Present (Address_Clause (gnat_temp)) + && Present (Full_View (gnat_temp))) + save_gnu_tree (Full_View (gnat_temp), error_mark_node, true); + if (No (Freeze_Node (gnat_temp))) gnat_to_gnu_entity (gnat_temp, gnu_expr, 1); break; @@ -4542,21 +4551,22 @@ gnat_to_gnu (Node_Id gnat_node) /***************************************************/ case N_Attribute_Definition_Clause: - gnu_result = alloc_stmt_list (); - /* The only one we need deal with is for 'Address. For the others, SEM - puts the information elsewhere. We need only deal with 'Address - if the object has a Freeze_Node (which it never will currently). */ - if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address - || No (Freeze_Node (Entity (Name (gnat_node))))) + /* The only one we need to deal with is 'Address since, for the others, + the front-end puts the information elsewhere. */ + if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address) + break; + + /* And we only deal with 'Address if the object has a Freeze node. */ + gnat_temp = Entity (Name (gnat_node)); + if (No (Freeze_Node (gnat_temp))) break; - /* Get the value to use as the address and save it as the - equivalent for GNAT_TEMP. When the object is frozen, - gnat_to_gnu_entity will do the right thing. */ - save_gnu_tree (Entity (Name (gnat_node)), - gnat_to_gnu (Expression (gnat_node)), true); + /* Get the value to use as the address and save it as the equivalent + for the object. When it is frozen, gnat_to_gnu_entity will do the + right thing. */ + save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true); break; case N_Enumeration_Representation_Clause: @@ -5910,7 +5920,7 @@ build_unary_op_trapv (enum tree_code code, { gcc_assert ((code == NEGATE_EXPR) || (code == ABS_EXPR)); - operand = save_expr (operand); + operand = protect_multiple_eval (operand); return emit_check (build_binary_op (EQ_EXPR, integer_type_node, operand, TYPE_MIN_VALUE (gnu_type)), @@ -5929,8 +5939,8 @@ build_binary_op_trapv (enum tree_code code, tree left, tree right) { - tree lhs = save_expr (left); - tree rhs = save_expr (right); + tree lhs = protect_multiple_eval (left); + tree rhs = protect_multiple_eval (right); tree type_max = TYPE_MAX_VALUE (gnu_type); tree type_min = TYPE_MIN_VALUE (gnu_type); tree gnu_expr; diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 2105abdcb29..dcf0558ec9d 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -2659,7 +2659,7 @@ build_template (tree template_type, tree array_type, tree expr) an object of that type and also for the name. */ tree -build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) +build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity) { tree record_type = make_node (RECORD_TYPE); tree pointer32_type; @@ -2689,7 +2689,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) idx_arr = (tree *) alloca (ndim * sizeof (tree)); - if (mech != By_Descriptor_NCA + if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) for (i = ndim - 1, inner_type = type; i >= 0; @@ -2775,16 +2775,21 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) switch (mech) { case By_Descriptor_A: + case By_Short_Descriptor_A: class = 4; break; case By_Descriptor_NCA: + case By_Short_Descriptor_NCA: class = 10; break; case By_Descriptor_SB: + case By_Short_Descriptor_SB: class = 15; break; case By_Descriptor: + case By_Short_Descriptor: case By_Descriptor_S: + case By_Short_Descriptor_S: default: class = 1; break; @@ -2797,7 +2802,9 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) = chainon (field_list, make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1), record_type, - size_in_bytes (mech == By_Descriptor_A ? inner_type : type))); + size_in_bytes ((mech == By_Descriptor_A || + mech == By_Short_Descriptor_A) + ? inner_type : type))); field_list = chainon (field_list, make_descriptor_field ("DTYPE", @@ -2823,10 +2830,13 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) switch (mech) { case By_Descriptor: + case By_Short_Descriptor: case By_Descriptor_S: + case By_Short_Descriptor_S: break; case By_Descriptor_SB: + case By_Short_Descriptor_SB: field_list = chainon (field_list, make_descriptor_field @@ -2842,7 +2852,9 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) break; case By_Descriptor_A: + case By_Short_Descriptor_A: case By_Descriptor_NCA: + case By_Short_Descriptor_NCA: field_list = chainon (field_list, make_descriptor_field ("SCALE", gnat_type_for_size (8, 1), @@ -2859,7 +2871,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) = chainon (field_list, make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1), record_type, - size_int (mech == By_Descriptor_NCA + size_int ((mech == By_Descriptor_NCA || + mech == By_Short_Descriptor_NCA) ? 0 /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */ : (TREE_CODE (type) == ARRAY_TYPE @@ -2910,7 +2923,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) TYPE_MIN_VALUE (idx_arr[i])), size_int (1))); - fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M'); + fname[0] = ((mech == By_Descriptor_NCA || + mech == By_Short_Descriptor_NCA) ? 'S' : 'M'); fname[1] = '0' + i, fname[2] = 0; field_list = chainon (field_list, @@ -2918,7 +2932,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) gnat_type_for_size (32, 1), record_type, idx_length)); - if (mech == By_Descriptor_NCA) + if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA) tem = idx_length; } @@ -2962,7 +2976,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) an object of that type and also for the name. */ tree -build_vms_descriptor64 (tree type, Mechanism_Type mech, Entity_Id gnat_entity) +build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) { tree record64_type = make_node (RECORD_TYPE); tree pointer64_type; @@ -3283,12 +3297,160 @@ make_descriptor_field (const char *name, tree type, return field; } -/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular - pointer or fat pointer type. GNAT_SUBPROG is the subprogram to which - the VMS descriptor is passed. */ +/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a + regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to + which the VMS descriptor is passed. */ + +static tree +convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) +{ + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + /* The CLASS field is the 3rd field in the descriptor. */ + tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type))); + /* The POINTER field is the 6th field in the descriptor. */ + tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (class))); + + /* Retrieve the value of the POINTER field. */ + tree gnu_expr64 + = build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE); + + if (POINTER_TYPE_P (gnu_type)) + return convert (gnu_type, gnu_expr64); + + else if (TYPE_FAT_POINTER_P (gnu_type)) + { + tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + tree template_type = TREE_TYPE (p_bounds_type); + tree min_field = TYPE_FIELDS (template_type); + tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type)); + tree template, template_addr, aflags, dimct, t, u; + /* See the head comment of build_vms_descriptor. */ + int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class)); + tree lfield, ufield; + + /* Convert POINTER to the type of the P_ARRAY field. */ + gnu_expr64 = convert (p_array_type, gnu_expr64); + + switch (iclass) + { + case 1: /* Class S */ + case 15: /* Class SB */ + /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */ + t = TREE_CHAIN (TREE_CHAIN (class)); + t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + t = tree_cons (min_field, + convert (TREE_TYPE (min_field), integer_one_node), + tree_cons (max_field, + convert (TREE_TYPE (max_field), t), + NULL_TREE)); + template = gnat_build_constructor (template_type, t); + template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template); + + /* For class S, we are done. */ + if (iclass == 1) + break; + + /* Test that we really have a SB descriptor, like DEC Ada. */ + t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL); + u = convert (TREE_TYPE (class), DECL_INITIAL (class)); + u = build_binary_op (EQ_EXPR, integer_type_node, t, u); + /* If so, there is already a template in the descriptor and + it is located right after the POINTER field. The fields are + 64bits so they must be repacked. */ + t = TREE_CHAIN (pointer64); + lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); + + t = TREE_CHAIN (t); + ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + ufield = convert + (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); + + /* Build the template in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (template_type), lfield, + tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield, NULL_TREE)); + template = gnat_build_constructor (template_type, t); + + /* Otherwise use the {1, LENGTH} template we build above. */ + template_addr = build3 (COND_EXPR, p_bounds_type, u, + build_unary_op (ADDR_EXPR, p_bounds_type, + template), + template_addr); + break; + + case 4: /* Class A */ + /* The AFLAGS field is the 3rd field after the pointer in the + descriptor. */ + t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer64))); + aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* The DIMCT field is the next field in the descriptor after + aflags. */ + t = TREE_CHAIN (t); + dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Raise CONSTRAINT_ERROR if either more than 1 dimension + or FL_COEFF or FL_BOUNDS not set. */ + u = build_int_cst (TREE_TYPE (aflags), 192); + u = build_binary_op (TRUTH_OR_EXPR, integer_type_node, + build_binary_op (NE_EXPR, integer_type_node, + dimct, + convert (TREE_TYPE (dimct), + size_one_node)), + build_binary_op (NE_EXPR, integer_type_node, + build2 (BIT_AND_EXPR, + TREE_TYPE (aflags), + aflags, u), + u)); + /* There is already a template in the descriptor and it is located + in block 3. The fields are 64bits so they must be repacked. */ + t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN + (t))))); + lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); + + t = TREE_CHAIN (t); + ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + ufield = convert + (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); + + /* Build the template in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (template_type), lfield, + tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield, NULL_TREE)); + template = gnat_build_constructor (template_type, t); + template = build3 (COND_EXPR, p_bounds_type, u, + build_call_raise (CE_Length_Check_Failed, Empty, + N_Raise_Constraint_Error), + template); + template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template); + break; + + case 10: /* Class NCA */ + default: + post_error ("unsupported descriptor type for &", gnat_subprog); + template_addr = integer_zero_node; + break; + } + + /* Build the fat pointer in the form of a constructor. */ + t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr64, + tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr, NULL_TREE)); + return gnat_build_constructor (gnu_type, t); + } + + else + gcc_unreachable (); +} + +/* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a + regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to + which the VMS descriptor is passed. */ static tree -convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) +convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) { tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); @@ -3298,11 +3460,11 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) tree pointer = TREE_CHAIN (class); /* Retrieve the value of the POINTER field. */ - gnu_expr + tree gnu_expr32 = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); if (POINTER_TYPE_P (gnu_type)) - return convert (gnu_type, gnu_expr); + return convert (gnu_type, gnu_expr32); else if (TYPE_FAT_POINTER_P (gnu_type)) { @@ -3316,7 +3478,7 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class)); /* Convert POINTER to the type of the P_ARRAY field. */ - gnu_expr = convert (p_array_type, gnu_expr); + gnu_expr32 = convert (p_array_type, gnu_expr32); switch (iclass) { @@ -3372,14 +3534,14 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) TREE_TYPE (aflags), aflags, u), u)); - add_stmt (build3 (COND_EXPR, void_type_node, u, - build_call_raise (CE_Length_Check_Failed, Empty, - N_Raise_Constraint_Error), - NULL_TREE)); /* There is already a template in the descriptor and it is located at the start of block 3 (12th field). */ t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t)))); template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + template = build3 (COND_EXPR, p_bounds_type, u, + build_call_raise (CE_Length_Check_Failed, Empty, + N_Raise_Constraint_Error), + template); template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template); break; @@ -3391,9 +3553,10 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) } /* Build the fat pointer in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr, + t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr32, tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), template_addr, NULL_TREE)); + return gnat_build_constructor (gnu_type, t); } @@ -3401,6 +3564,47 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) gcc_unreachable (); } +/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular + pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) + pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the + VMS descriptor is passed. */ + +static tree +convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type, + Entity_Id gnat_subprog) +{ + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + tree mbo = TYPE_FIELDS (desc_type); + const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo)); + tree mbmo = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (mbo))); + tree is64bit, gnu_expr32, gnu_expr64; + + /* If the field name is not MBO, it must be 32-bit and no alternate. + Otherwise primary must be 64-bit and alternate 32-bit. */ + if (strcmp (mbostr, "MBO") != 0) + return convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); + + /* Build the test for 64-bit descriptor. */ + mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE); + mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE); + is64bit + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (EQ_EXPR, integer_type_node, + convert (integer_type_node, mbo), + integer_one_node), + build_binary_op (EQ_EXPR, integer_type_node, + convert (integer_type_node, mbmo), + integer_minus_one_node)); + + /* Build the 2 possible end results. */ + gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr, gnat_subprog); + gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr); + gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); + + return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32); +} + /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG and the GNAT node GNAT_SUBPROG. */ @@ -3429,8 +3633,11 @@ build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) gnu_arg_types = TREE_CHAIN (gnu_arg_types)) { if (DECL_BY_DESCRIPTOR_P (gnu_stub_param)) - gnu_param = convert_vms_descriptor (TREE_VALUE (gnu_arg_types), - gnu_stub_param, gnat_subprog); + gnu_param + = convert_vms_descriptor (TREE_VALUE (gnu_arg_types), + gnu_stub_param, + DECL_PARM_ALT_TYPE (gnu_stub_param), + gnat_subprog); else gnu_param = gnu_stub_param; @@ -3662,31 +3869,31 @@ update_pointer_to (tree old_type, tree new_type) } } -/* Convert a pointer to a constrained array into a pointer to a fat - pointer. This involves making or finding a template. */ +/* Convert EXPR, a pointer to a constrained array, into a pointer to an + unconstrained one. This involves making or finding a template. */ static tree convert_to_fat_pointer (tree type, tree expr) { tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)))); - tree template, template_addr; + tree p_array_type = TREE_TYPE (TYPE_FIELDS (type)); tree etype = TREE_TYPE (expr); + tree template; - /* If EXPR is a constant of zero, we make a fat pointer that has a null - pointer to the template and array. */ + /* If EXPR is null, make a fat pointer that contains null pointers to the + template and array. */ if (integer_zerop (expr)) return gnat_build_constructor (type, tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), + convert (p_array_type, expr), tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), convert (build_pointer_type (template_type), expr), NULL_TREE))); - /* If EXPR is a thin pointer, make the template and data from the record. */ - + /* If EXPR is a thin pointer, make template and data from the record.. */ else if (TYPE_THIN_POINTER_P (etype)) { tree fields = TYPE_FIELDS (TREE_TYPE (etype)); @@ -3702,30 +3909,31 @@ convert_to_fat_pointer (tree type, tree expr) build_component_ref (expr, NULL_TREE, TREE_CHAIN (fields), false)); } + + /* Otherwise, build the constructor for the template. */ else - /* Otherwise, build the constructor for the template. */ template = build_template (template_type, TREE_TYPE (etype), expr); - template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template); - - /* The result is a CONSTRUCTOR for the fat pointer. + /* The final result is a constructor for the fat pointer. - If expr is an argument of a foreign convention subprogram, the type it - points to is directly the component type. In this case, the expression + If EXPR is an argument of a foreign convention subprogram, the type it + points to is directly the component type. In this case, the expression type may not match the corresponding FIELD_DECL type at this point, so we - call "convert" here to fix that up if necessary. This type consistency is + call "convert" here to fix that up if necessary. This type consistency is required, for instance because it ensures that possible later folding of - component_refs against this constructor always yields something of the + COMPONENT_REFs against this constructor always yields something of the same type as the initial reference. - Note that the call to "build_template" above is still fine, because it - will only refer to the provided template_type in this case. */ - return - gnat_build_constructor - (type, tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - template_addr, NULL_TREE))); + Note that the call to "build_template" above is still fine because it + will only refer to the provided TEMPLATE_TYPE in this case. */ + return + gnat_build_constructor + (type, + tree_cons (TYPE_FIELDS (type), + convert (p_array_type, expr), + tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), + build_unary_op (ADDR_EXPR, NULL_TREE, template), + NULL_TREE))); } /* Convert to a thin pointer type, TYPE. The only thing we know how to convert diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 1ed1b9f9cdb..89fb5f0f419 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -986,7 +986,6 @@ build_binary_op (enum tree_code op_code, tree result_type, outputs. */ if (modulus && integer_pow2p (modulus)) modulus = NULL_TREE; - goto common; case COMPLEX_EXPR: @@ -1011,6 +1010,15 @@ build_binary_op (enum tree_code op_code, tree result_type, right_operand = convert (sizetype, right_operand); break; + case PLUS_EXPR: + case MINUS_EXPR: + /* Avoid doing arithmetics in BOOLEAN_TYPE like the other compilers. + Contrary to C, Ada doesn't allow arithmetics in Standard.Boolean + but we can generate addition or subtraction for 'Succ and 'Pred. */ + if (operation_type && TREE_CODE (operation_type) == BOOLEAN_TYPE) + operation_type = left_base_type = right_base_type = integer_type_node; + goto common; + default: common: /* The result type should be the same as the base types of the @@ -2152,8 +2160,8 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, /* Fill in a VMS descriptor for EXPR and return a constructor for it. GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is - how we find the allocator size which determines whether to use the - alternate 64bit descriptor. */ + how we derive the source location to raise C_E on an out of range + pointer. */ tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) @@ -2161,43 +2169,42 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) tree field; tree parm_decl = get_gnu_tree (gnat_formal); tree const_list = NULL_TREE; - int size; - tree record_type; - - /* A string literal will always be in 32bit space on VMS. Where - will it be on other 64bit systems??? - An identifier's allocation may be unknown at compile time. - An explicit dereference could be either in 32bit or 64bit space. - Don't know about other possibilities, so assume unknown which - will result in fetching the 64bit descriptor. ??? */ - if (Nkind (gnat_actual) == N_String_Literal) - size = 32; - else if (Nkind (gnat_actual) == N_Identifier) - size = UI_To_Int (Esize (Etype (gnat_actual))); - else if (Nkind (gnat_actual) == N_Explicit_Dereference) - size = UI_To_Int (Esize (Etype (Prefix (gnat_actual)))); - else - size = 0; - - /* If size is unknown, make it POINTER_SIZE */ - if (size == 0) - size = POINTER_SIZE; - - /* If size is 64bits grab the alternate 64bit descriptor. */ - if (size == 64) - TREE_TYPE (parm_decl) = DECL_PARM_ALT (parm_decl); + tree record_type = TREE_TYPE (TREE_TYPE (parm_decl)); + int do_range_check = + strcmp ("MBO", + IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type)))); - record_type = TREE_TYPE (TREE_TYPE (parm_decl)); expr = maybe_unconstrained_array (expr); gnat_mark_addressable (expr); for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) - const_list - = tree_cons (field, - convert (TREE_TYPE (field), - SUBSTITUTE_PLACEHOLDER_IN_EXPR - (DECL_INITIAL (field), expr)), - const_list); + { + tree conexpr = convert (TREE_TYPE (field), + SUBSTITUTE_PLACEHOLDER_IN_EXPR + (DECL_INITIAL (field), expr)); + + /* Check to ensure that only 32bit pointers are passed in + 32bit descriptors */ + if (do_range_check && + strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0) + { + tree pointer64type = + build_pointer_type_for_mode (void_type_node, DImode, false); + tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr); + tree malloc64low = + build_int_cstu (long_integer_type_node, 0x80000000); + + add_stmt (build3 (COND_EXPR, void_type_node, + build_binary_op (GE_EXPR, long_integer_type_node, + convert (long_integer_type_node, + addr64expr), + malloc64low), + build_call_raise (CE_Range_Check_Failed, gnat_actual, + N_Raise_Constraint_Error), + NULL_TREE)); + } + const_list = tree_cons (field, conexpr, const_list); + } return gnat_build_constructor (record_type, nreverse (const_list)); } diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 8c1759471ef..29c1aec6dae 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -104,7 +104,6 @@ Implementation Defined Pragmas * Pragma Assert:: * Pragma Ast_Entry:: * Pragma C_Pass_By_Copy:: -* Pragma Canonical_Streams:: * Pragma Check:: * Pragma Check_Name:: * Pragma Check_Policy:: @@ -706,7 +705,6 @@ consideration, the use of these pragmas should be minimized. * Pragma Assert:: * Pragma Ast_Entry:: * Pragma C_Pass_By_Copy:: -* Pragma Canonical_Streams:: * Pragma Check:: * Pragma Check_Name:: * Pragma Check_Policy:: @@ -1059,27 +1057,6 @@ You can also pass records by copy by specifying the convention @code{Import} and @code{Export} pragmas, which allow specification of passing mechanisms on a parameter by parameter basis. -@node Pragma Canonical_Streams -@unnumberedsec Canonical Streams -@cindex Canonical streams -@findex Canonical_Streams -@noindent -Syntax: -@smallexample @c ada -pragma Canonical_Streams; -@end smallexample - -@noindent -This configuration pragma affects the behavior of stream attributes of any -@code{String}, @code{Wide_String} or @code{Wide_Wide_String} based type. When -this pragma is present, @code{'Input}, @code{'Output}, @code{'Read} and -@code{'Write} exibit Ada 95 canonical behavior, in other words, streaming of -values is done character by character. - -@noindent -The use of this pragma is intended to bypass any implementation-related -optimizations allowed by Ada 2005 RM 13.13.2 (56/2) Implementation Permission. - @node Pragma Check @unnumberedsec Pragma Check @cindex Assertions @@ -1852,6 +1829,7 @@ MECHANISM_NAME ::= Value | Reference | Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a @end smallexample @@ -1884,6 +1862,9 @@ anonymous access parameter. @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Export_Function is to accept either 64bit or +32bit descriptors unless short_descriptor is specified, then only 32bit +descriptors are accepted. @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null @@ -1953,6 +1934,7 @@ MECHANISM_NAME ::= Value | Reference | Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a @end smallexample @@ -1970,6 +1952,9 @@ pragma that specifies the desired foreign convention. @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Export_Procedure is to accept either 64bit or +32bit descriptors unless short_descriptor is specified, then only 32bit +descriptors are accepted. @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null @@ -2035,6 +2020,7 @@ MECHANISM_NAME ::= Value | Reference | Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a @end smallexample @@ -2057,6 +2043,9 @@ pragma that specifies the desired foreign convention. @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Export_Valued_Procedure is to accept either 64bit or +32bit descriptors unless short_descriptor is specified, then only 32bit +descriptors are accepted. @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null @@ -2483,6 +2472,7 @@ MECHANISM_NAME ::= Value | Reference | Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample @@ -2516,6 +2506,8 @@ is used. @cindex OpenVMS @cindex Passing by descriptor Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Import_Function is to pass a 64bit descriptor +unless short_descriptor is specified, then a 32bit descriptor is passed. @code{First_Optional_Parameter} applies only to OpenVMS ports of GNAT@. It specifies that the designated parameter and all following parameters @@ -2589,6 +2581,7 @@ MECHANISM_NAME ::= Value | Reference | Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample @@ -2635,6 +2628,7 @@ MECHANISM_NAME ::= Value | Reference | Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index e64cebfb32e..99df83f9918 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -4034,11 +4034,11 @@ details. @item -gnatq @cindex @option{-gnatq} (@command{gcc}) -Don't quit; try semantics, even if parse errors. +Don't quit. Try semantics, even if parse errors. @item -gnatQ @cindex @option{-gnatQ} (@command{gcc}) -Don't quit; generate @file{ALI} and tree files even if illegalities. +Don't quit. Generate @file{ALI} and tree files even if illegalities. @item -gnatr @cindex @option{-gnatr} (@command{gcc}) @@ -10925,7 +10925,6 @@ recognized by GNAT: Ada_2005 Assertion_Policy C_Pass_By_Copy - Canonical_Streams Check_Name Check_Policy Compile_Time_Error @@ -25509,6 +25508,7 @@ information about several specific platforms. * Linux-Specific Considerations:: * AIX-Specific Considerations:: * Irix-Specific Considerations:: +* RTX-Specific Considerations:: @end menu @node Summary of Run-Time Configurations @@ -25619,6 +25619,15 @@ information about several specific platforms. @item @code{@ @ @ @ }Tasking @tab native Win32 threads @item @code{@ @ @ @ }Exceptions @tab SJLJ @* +@item @b{x86-windows-rtx} +@item @code{@ @ }@i{rts-rtx-rtss (default)} +@item @code{@ @ @ @ }Tasking @tab RTX real-time subsystem RTSS threads (kernel mode) +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @code{@ @ }@i{rts-rtx-w32} +@item @code{@ @ @ @ }Tasking @tab RTX Win32 threads (user mode) +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* @item @b{x86_64-linux} @item @code{@ @ }@i{rts-native (default)} @item @code{@ @ @ @ }Tasking @tab pthread library @@ -25843,6 +25852,26 @@ $ LD_LIBRARY_PATH=$LD_LIBRARY_PATH:`dirname \`gcc --print-file-name=libgcc_s.so @end group @end smallexample +@node RTX-Specific Considerations +@section RTX-Specific Considerations +@cindex RTX libraries + +@noindent +The Real-time Extension (RTX) to Windows is based on the Windows Win32 +API. Applications can be built to work in two different modes: + +@itemize @bullet +@item +Windows executables that run in Ring 3 to utilize memory protection +(@emph{rts-rtx-w32}). + +@item +Real-time subsystem (RTSS) executables that run in Ring 0, where +performance can be optimized with RTSS applications taking precedent +over all Windows applications (@emph{rts-rtx-rtss}). + +@end itemize + @c ******************************* @node Example of Binder Output File @appendix Example of Binder Output File diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb index 766a474afbf..7c17beb5802 100644 --- a/gcc/ada/gnatchop.adb +++ b/gcc/ada/gnatchop.adb @@ -63,9 +63,9 @@ procedure Gnatchop is -- Arguments used in Gnat_Cmd call EOF : constant Character := Character'Val (26); - -- Special character to signal end of file. Not required in input - -- files, but properly treated if present. Not generated in output - -- files except as a result of copying input file. + -- Special character to signal end of file. Not required in input files, + -- but properly treated if present. Not generated in output files except + -- as a result of copying input file. -------------------- -- File arguments -- @@ -152,8 +152,8 @@ procedure Gnatchop is -- Index of unit in sorted unit list Bufferg : String_Access; - -- Pointer to buffer containing configuration pragmas to be - -- prepended. Null if no pragmas to be prepended. + -- Pointer to buffer containing configuration pragmas to be prepended. + -- Null if no pragmas to be prepended. end record; -- The following table stores the unit offset information @@ -1018,9 +1018,9 @@ procedure Gnatchop is Contents := new String (1 .. Read_Ptr); Contents.all := Buffer (1 .. Read_Ptr); - -- Things aren't simple on VMS due to the plethora of file types - -- and organizations. It seems clear that there shouldn't be more - -- bytes read than are contained in the file though. + -- Things aren't simple on VMS due to the plethora of file types and + -- organizations. It seems clear that there shouldn't be more bytes + -- read than are contained in the file though. if Hostparm.OpenVMS then Success := Read_Ptr <= Length + 1; @@ -1249,7 +1249,6 @@ procedure Gnatchop is F : constant String := File.Table (File_Num).Name.all; begin - if Is_Directory (F) then Error_Msg (F & " is a directory, cannot be chopped"); return False; @@ -1277,7 +1276,6 @@ procedure Gnatchop is end if; return False; - end Scan_Arguments; ---------------- @@ -1636,11 +1634,11 @@ procedure Gnatchop is -- Returns in OS_Name the proper name for the OS when used with the -- returned Encoding value. For example on Windows this will return the -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8 - -- (form parameter Stream_IO). + -- (the form parameter for Stream_IO). + -- -- Name is the filename and W_Name the same filename in Unicode 16 bits - -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length and - -- E_Length are the length returned in OS_Name and Encoding - -- respectively. + -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length + -- are the length returned in OS_Name/Encoding respectively. Info : Unit_Info renames Unit.Table (Num); Name : aliased constant String := Info.File_Name.all & ASCII.NUL; @@ -1676,6 +1674,7 @@ procedure Gnatchop is C_Name : aliased constant String := E_Name & ASCII.NUL; OS_Encoding : constant String := Encoding (1 .. E_Length); File : Stream_IO.File_Type; + begin begin if not Overwrite_Files and then Exists (E_Name) then @@ -1685,6 +1684,7 @@ procedure Gnatchop is (File, Stream_IO.Out_File, E_Name, OS_Encoding); Success := True; end if; + exception when Stream_IO.Name_Error | Stream_IO.Use_Error => Error_Msg ("cannot create " & Info.File_Name.all); @@ -1705,7 +1705,6 @@ procedure Gnatchop is if Success and then Info.Bufferg /= null then Write_Source_Reference_Pragma (Info, 1, File, EOL, Success); - String'Write (Stream_IO.Stream (File), Info.Bufferg.all); end if; @@ -1742,10 +1741,9 @@ procedure Gnatchop is -- Start of processing for gnatchop begin - -- Add the directory where gnatchop is invoked in front of the - -- path, if gnatchop is invoked with directory information. - -- Only do this if the platform is not VMS, where the notion of path - -- does not really exist. + -- Add the directory where gnatchop is invoked in front of the path, if + -- gnatchop is invoked with directory information. Only do this if the + -- platform is not VMS, where the notion of path does not really exist. if not Hostparm.OpenVMS then declare @@ -1758,12 +1756,10 @@ begin Absolute_Dir : constant String := Normalize_Pathname (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; - + Absolute_Dir + & Path_Separator + & Getenv ("PATH").all; begin Setenv ("PATH", PATH); end; @@ -1813,26 +1809,24 @@ begin Sort_Units; - -- Check if any duplicate files would be created. If so, emit - -- a warning if Overwrite_Files is true, otherwise generate an error. + -- Check if any duplicate files would be created. If so, emit a warning if + -- Overwrite_Files is true, otherwise generate an error. if Report_Duplicate_Units and then not Overwrite_Files then goto No_Files_Written; end if; - -- Check if any files exist, if so do not write anything - -- Because all files have been parsed and checked already, - -- there won't be any duplicates + -- Check if any files exist, if so do not write anything Because all files + -- have been parsed and checked already, there won't be any duplicates if not Overwrite_Files and then Files_Exist then goto No_Files_Written; end if; - -- After this point, all source files are read in succession - -- and chopped into their destination files. + -- After this point, all source files are read in succession and chopped + -- into their destination files. - -- As the Source_File_Name pragmas are handled as logical file 0, - -- write it first. + -- Source_File_Name pragmas are handled as logical file 0 so write it first for F in 1 .. File.Last loop if not Write_Chopped_Files (F) then diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index 040a726f572..44633b9c902 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -475,6 +475,9 @@ package body GPrep is procedure Process_One_File is Infile : Source_File_Index; + Modified : Boolean; + pragma Warnings (Off, Modified); + begin -- Create the output file (fails if this does not work) @@ -515,7 +518,7 @@ package body GPrep is -- Preprocess the input file - Prep.Preprocess; + Prep.Preprocess (Modified); -- In verbose mode, if there is no error, report it diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb index f9f696b9eee..3b46385ada2 100644 --- a/gcc/ada/i-cobol.adb +++ b/gcc/ada/i-cobol.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -337,7 +337,7 @@ package body Interfaces.COBOL is -- Here a swap is needed declare - Len : constant Natural := B'Length; + Len : constant Natural := B'Length; begin for J in 1 .. Len / 2 loop @@ -452,10 +452,15 @@ package body Interfaces.COBOL is -- Used for the nonseparate formats to embed the appropriate sign -- at the specified location (i.e. at Result (Loc)) + ------------- + -- Convert -- + ------------- + procedure Convert (First, Last : Natural) is - J : Natural := Last; + J : Natural; begin + J := Last; while J >= First loop Result (J) := COBOL_Character'Val @@ -478,6 +483,10 @@ package body Interfaces.COBOL is raise Conversion_Error; end Convert; + ---------------- + -- Embed_Sign -- + ---------------- + procedure Embed_Sign (Loc : Natural) is Digit : Natural range 0 .. 9; @@ -559,6 +568,10 @@ package body Interfaces.COBOL is -- storing the result in Result (First .. Last). Raise Conversion_Error -- if the value is too large to fit. + ------------- + -- Convert -- + ------------- + procedure Convert (First, Last : Natural) is J : Natural := Last; diff --git a/gcc/ada/ioexcept.ads b/gcc/ada/ioexcept.ads index 0473ff32bdf..efdadc713c9 100644 --- a/gcc/ada/ioexcept.ads +++ b/gcc/ada/ioexcept.ads @@ -15,9 +15,9 @@ pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and Text_IO is not considered to --- be an internal unit that is automatically compiled in Ada 2005 mode (since --- a user is allowed to redeclare IO_Exceptions). +-- child unit (not possible in Ada 83 mode), and IO_Exceptions is not +-- considered to be an internal unit that is automatically compiled in Ada +-- 2005 mode (since a user is allowed to redeclare IO_Exceptions). with Ada.IO_Exceptions; diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index c6dec0aa379..d4dcd3cb201 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -83,16 +83,16 @@ package body Layout is Left_Opnd : Node_Id; Right_Opnd : Node_Id) return Node_Id; -- This is like Make_Op_Multiply except that it optimizes some cases - -- knowing that associative rearrangement is allowed for constant - -- folding if one of the operands is a compile time known value + -- knowing that associative rearrangement is allowed for constant folding + -- if one of the operands is a compile time known value function Assoc_Subtract (Loc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id) return Node_Id; -- This is like Make_Op_Subtract except that it optimizes some cases - -- knowing that associative rearrangement is allowed for constant - -- folding if one of the operands is a compile time known value + -- knowing that associative rearrangement is allowed for constant folding + -- if one of the operands is a compile time known value function Bits_To_SU (N : Node_Id) return Node_Id; -- This is used when we cross the boundary from static sizes in bits to @@ -159,21 +159,20 @@ package body Layout is -- Front-end layout of record type procedure Rewrite_Integer (N : Node_Id; V : Uint); - -- Rewrite node N with an integer literal whose value is V. The Sloc - -- for the new node is taken from N, and the type of the literal is - -- set to a copy of the type of N on entry. + -- Rewrite node N with an integer literal whose value is V. The Sloc for + -- the new node is taken from N, and the type of the literal is set to a + -- copy of the type of N on entry. procedure Set_And_Check_Static_Size (E : Entity_Id; Esiz : SO_Ref; RM_Siz : SO_Ref); - -- This procedure is called to check explicit given sizes (possibly - -- stored in the Esize and RM_Size fields of E) against computed - -- Object_Size (Esiz) and Value_Size (RM_Siz) values. Appropriate - -- errors and warnings are posted if specified sizes are inconsistent - -- with specified sizes. On return, the Esize and RM_Size fields of - -- E are set (either from previously given values, or from the newly - -- computed values, as appropriate). + -- This procedure is called to check explicit given sizes (possibly stored + -- in the Esize and RM_Size fields of E) against computed Object_Size + -- (Esiz) and Value_Size (RM_Siz) values. Appropriate errors and warnings + -- are posted if specified sizes are inconsistent with specified sizes. On + -- return, Esize and RM_Size fields of E are set (either from previously + -- given values, or from the newly computed values, as appropriate). procedure Set_Composite_Alignment (E : Entity_Id); -- This procedure is called for record types and subtypes, and also for @@ -200,8 +199,8 @@ package body Layout is -- which must be obeyed. If so, we cannot increase the size in this -- routine. - -- For a type, the issue is whether an object size clause has been - -- set. A normal size clause constrains only the value size (RM_Size) + -- For a type, the issue is whether an object size clause has been set. + -- A normal size clause constrains only the value size (RM_Size) if Is_Type (E) then Esize_Set := Has_Object_Size_Clause (E); @@ -247,14 +246,14 @@ package body Layout is return; end if; - -- Here we have a situation where the Esize is not a multiple of - -- the alignment. We must either increase Esize or reduce the - -- alignment to correct this situation. + -- Here we have a situation where the Esize is not a multiple of the + -- alignment. We must either increase Esize or reduce the alignment to + -- correct this situation. -- The case in which we can decrease the alignment is where the -- alignment was not set by an alignment clause, and the type in - -- question is a discrete type, where it is definitely safe to - -- reduce the alignment. For example: + -- question is a discrete type, where it is definitely safe to reduce + -- the alignment. For example: -- t : integer range 1 .. 2; -- for t'size use 8; @@ -275,8 +274,8 @@ package body Layout is return; end if; - -- Now the only possible approach left is to increase the Esize - -- but we can't do that if the size was set by a specific clause. + -- Now the only possible approach left is to increase the Esize but we + -- can't do that if the size was set by a specific clause. if Esize_Set then Error_Msg_NE @@ -606,9 +605,10 @@ package body Layout is Ent := Get_Dynamic_SO_Entity (D); if Is_Discrim_SO_Function (Ent) then - -- If a component is passed in whose type matches the type - -- of the function formal, then select that component from - -- the "V" parameter rather than passing "V" directly. + + -- If a component is passed in whose type matches the type of + -- the function formal, then select that component from the "V" + -- parameter rather than passing "V" directly. if Present (Comp) and then Base_Type (Etype (Comp)) @@ -661,18 +661,18 @@ package body Layout is when Dynamic => Nod : Node_Id; end case; end record; - -- Shows the status of the value so far. Const means that the value - -- is constant, and Val is the current constant value. Dynamic means - -- that the value is dynamic, and in this case Nod is the Node_Id of - -- the expression to compute the value. + -- Shows the status of the value so far. Const means that the value is + -- constant, and Val is the current constant value. Dynamic means that + -- the value is dynamic, and in this case Nod is the Node_Id of the + -- expression to compute the value. Size : Val_Type; -- Calculated value so far if Size.Status = Const, -- or expression value so far if Size.Status = Dynamic. SU_Convert_Required : Boolean := False; - -- This is set to True if the final result must be converted from - -- bits to storage units (rounding up to a storage unit boundary). + -- This is set to True if the final result must be converted from bits + -- to storage units (rounding up to a storage unit boundary). ----------------------- -- Local Subprograms -- @@ -799,9 +799,9 @@ package body Layout is (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); SU_Convert_Required := False; - -- Otherwise, we go ahead and convert the value in bits, - -- and set SU_Convert_Required to True to ensure that the - -- final value is indeed properly converted. + -- Otherwise, we go ahead and convert the value in bits, and + -- set SU_Convert_Required to True to ensure that the final + -- value is indeed properly converted. else Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); @@ -827,8 +827,8 @@ package body Layout is Len := Convert_To (Standard_Unsigned, Len); - -- If we cannot verify that range cannot be super-flat, - -- we need a max with zero, since length must be non-neg. + -- If we cannot verify that range cannot be super-flat, we need + -- a max with zero, since length must be non-negative. if not OK or else LLo < 0 then Len := @@ -846,8 +846,8 @@ package body Layout is Next_Index (Indx); end loop; - -- Here after processing all bounds to set sizes. If the value is - -- a constant, then it is bits, so we convert to storage units. + -- Here after processing all bounds to set sizes. If the value is a + -- constant, then it is bits, so we convert to storage units. if Size.Status = Const then return Bits_To_SU (Make_Integer_Literal (Loc, Size.Val)); @@ -900,10 +900,10 @@ package body Layout is -- How An Array Type is Laid Out -- ------------------------------------ - -- Here is what goes on. We need to multiply the component size of - -- the array (which has already been set) by the length of each of - -- the indexes. If all these values are known at compile time, then - -- the resulting size of the array is the appropriate constant value. + -- Here is what goes on. We need to multiply the component size of the + -- array (which has already been set) by the length of each of the + -- indexes. If all these values are known at compile time, then the + -- resulting size of the array is the appropriate constant value. -- If the component size or at least one bound is dynamic (but no -- discriminants are present), then the size will be computed as an @@ -941,8 +941,8 @@ package body Layout is -- Value of size computed so far. See comments above Vtyp : Entity_Id := Empty; - -- Variant record type for the formal parameter of the - -- discriminant function V if Status = Discrim. + -- Variant record type for the formal parameter of the discriminant + -- function V if Status = Discrim. SU_Convert_Required : Boolean := False; -- This is set to True if the final result must be converted from @@ -1064,7 +1064,7 @@ package body Layout is while Present (Indx) loop Ityp := Etype (Indx); - -- If an index of the array is a generic formal type then there's + -- If an index of the array is a generic formal type then there is -- no point in determining a size for the array type. if Is_Generic_Type (Ityp) then @@ -1139,18 +1139,18 @@ package body Layout is (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); SU_Convert_Required := False; - -- If the current value is a factor of the storage unit, - -- then we can use a value of one for the size and reduce - -- the strength of the later division. + -- If the current value is a factor of the storage unit, then + -- we can use a value of one for the size and reduce the + -- strength of the later division. elsif SSU mod Size.Val = 0 then Storage_Divisor := SSU / Size.Val; Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1)); SU_Convert_Required := True; - -- Otherwise, we go ahead and convert the value in bits, - -- and set SU_Convert_Required to True to ensure that the - -- final value is indeed properly converted. + -- Otherwise, we go ahead and convert the value in bits, and + -- set SU_Convert_Required to True to ensure that the final + -- value is indeed properly converted. else Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); @@ -1165,8 +1165,8 @@ package body Layout is Len := Compute_Length (Lo, Hi); - -- If Len isn't a Length attribute, then its range needs to - -- be checked a possible Max with zero needs to be computed. + -- If Len isn't a Length attribute, then its range needs to be + -- checked a possible Max with zero needs to be computed. if Nkind (Len) /= N_Attribute_Reference or else Attribute_Name (Len) /= Name_Length @@ -1193,9 +1193,8 @@ package body Layout is return; end if; - -- If we cannot verify that range cannot be super-flat, - -- we need a maximum with zero, since length cannot be - -- negative. + -- If we cannot verify that range cannot be super-flat, we + -- need a max with zero, since length cannot be negative. if not OK or else LLo < 0 then Len := @@ -1221,9 +1220,9 @@ package body Layout is Next_Index (Indx); end loop; - -- Here after processing all bounds to set sizes. If the value is - -- a constant, then it is bits, and the only thing we need to do - -- is to check against explicit given size and do alignment adjust. + -- Here after processing all bounds to set sizes. If the value is a + -- constant, then it is bits, and the only thing we need to do is to + -- check against explicit given size and do alignment adjust. if Size.Status = Const then Set_And_Check_Static_Size (E, Size.Val, Size.Val); @@ -1303,8 +1302,8 @@ package body Layout is return; end if; - -- Set size if not set for object and known for type. Use the - -- RM_Size if that is known for the type and Esize is not. + -- Set size if not set for object and known for type. Use the RM_Size if + -- that is known for the type and Esize is not. if Unknown_Esize (E) then if Known_Esize (T) then @@ -1325,9 +1324,9 @@ package body Layout is Adjust_Esize_Alignment (E); - -- Final adjustment, if we don't know the alignment, and the Esize - -- was not set by an explicit Object_Size attribute clause, then - -- we reset the Esize to unknown, since we really don't know it. + -- Final adjustment, if we don't know the alignment, and the Esize was + -- not set by an explicit Object_Size attribute clause, then we reset + -- the Esize to unknown, since we really don't know it. if Unknown_Alignment (E) and then not Has_Size_Clause (E) @@ -1505,8 +1504,8 @@ package body Layout is New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU; end if; - -- If old normalized position is static, we can go ahead - -- and compute the new normalized position directly. + -- If old normalized position is static, we can go ahead and + -- compute the new normalized position directly. if Known_Static_Normalized_Position (Prev_Comp) then New_Npos := Old_Npos; @@ -1619,11 +1618,11 @@ package body Layout is return; end if; - -- Check case of type of component has a scope of the record we - -- are laying out. When this happens, the type in question is an - -- Itype that has not yet been laid out (that's because such - -- types do not get frozen in the normal manner, because there - -- is no place for the freeze nodes). + -- Check case of type of component has a scope of the record we are + -- laying out. When this happens, the type in question is an Itype + -- that has not yet been laid out (that's because such types do not + -- get frozen in the normal manner, because there is no place for + -- the freeze nodes). if Scope (Ctyp) = E then Layout_Type (Ctyp); @@ -1636,9 +1635,8 @@ package body Layout is end if; -- Set size of component from type. We use the Esize except in a - -- packed record, where we use the RM_Size (since that is exactly - -- what the RM_Size value, as distinct from the Object_Size is - -- useful for!) + -- packed record, where we use the RM_Size (since that is what the + -- RM_Size value, as distinct from the Object_Size is useful for!) if Is_Packed (E) then Set_Esize (Comp, RM_Size (Ctyp)); @@ -1915,10 +1913,10 @@ package body Layout is RM_Siz_Expr : Node_Id := Empty; -- Expression for the evolving RM_Siz value. This is typically a - -- conditional expression which involves tests of discriminant - -- values that are formed as references to the entity V. At - -- the end of scanning all the components, a suitable function - -- is constructed in which V is the parameter. + -- conditional expression which involves tests of discriminant values + -- that are formed as references to the entity V. At the end of + -- scanning all the components, a suitable function is constructed + -- in which V is the parameter. ----------------------- -- Local Subprograms -- @@ -1928,14 +1926,14 @@ package body Layout is (Clist : Node_Id; Esiz : out SO_Ref; RM_Siz_Expr : out Node_Id); - -- Recursive procedure, called to lay out one component list - -- Esiz and RM_Siz_Expr are set to the Object_Size and Value_Size - -- values respectively representing the record size up to and - -- including the last component in the component list (including - -- any variants in this component list). RM_Siz_Expr is returned - -- as an expression which may in the general case involve some - -- references to the discriminants of the current record value, - -- referenced by selecting from the entity V. + -- Recursive procedure, called to lay out one component list Esiz + -- and RM_Siz_Expr are set to the Object_Size and Value_Size values + -- respectively representing the record size up to and including the + -- last component in the component list (including any variants in + -- this component list). RM_Siz_Expr is returned as an expression + -- which may in the general case involve some references to the + -- discriminants of the current record value, referenced by selecting + -- from the entity V. --------------------------- -- Layout_Component_List -- @@ -1982,9 +1980,9 @@ package body Layout is else RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz); - -- If the size is represented by a function, then we - -- create an appropriate function call using V as - -- the parameter to the call. + -- If the size is represented by a function, then we create + -- an appropriate function call using V as the parameter to + -- the call. if Is_Discrim_SO_Function (RMS_Ent) then RM_Siz_Expr := @@ -2080,9 +2078,9 @@ package body Layout is -- individual variants, and xxDx are the discriminant -- checking functions generated for the variant type. - -- If this is the first variant, we simply set the - -- result as the expression. Note that this takes - -- care of the others case. + -- If this is the first variant, we simply set the result + -- as the expression. Note that this takes care of the + -- others case. if No (RM_Siz_Expr) then RM_Siz_Expr := Bits_To_SU (RM_SizV); @@ -2236,17 +2234,17 @@ package body Layout is -- All other cases else - -- Initialize alignment conservatively to 1. This value will - -- be increased as necessary during processing of the record. + -- Initialize alignment conservatively to 1. This value will be + -- increased as necessary during processing of the record. if Unknown_Alignment (E) then Set_Alignment (E, Uint_1); end if; - -- Initialize previous component. This is Empty unless there - -- are components which have already been laid out by component - -- clauses. If there are such components, we start our lay out of - -- the remaining components following the last such component. + -- Initialize previous component. This is Empty unless there are + -- components which have already been laid out by component clauses. + -- If there are such components, we start our lay out of the + -- remaining components following the last such component. Prev_Comp := Empty; @@ -2303,8 +2301,8 @@ package body Layout is Desig_Type : Entity_Id; begin - -- For string literal types, for now, kill the size always, this - -- is because gigi does not like or need the size to be set ??? + -- For string literal types, for now, kill the size always, this is + -- because gigi does not like or need the size to be set ??? if Ekind (E) = E_String_Literal_Subtype then Set_Esize (E, Uint_0); @@ -2312,14 +2310,14 @@ package body Layout is return; end if; - -- For access types, set size/alignment. This is system address - -- size, except for fat pointers (unconstrained array access types), - -- where the size is two times the address size, to accommodate the - -- two pointers that are required for a fat pointer (data and - -- template). Note that E_Access_Protected_Subprogram_Type is not - -- an access type for this purpose since it is not a pointer but is - -- equivalent to a record. For access subtypes, copy the size from - -- the base type since Gigi represents them the same way. + -- For access types, set size/alignment. This is system address size, + -- except for fat pointers (unconstrained array access types), where the + -- size is two times the address size, to accommodate the two pointers + -- that are required for a fat pointer (data and template). Note that + -- E_Access_Protected_Subprogram_Type is not an access type for this + -- purpose since it is not a pointer but is equivalent to a record. For + -- access subtypes, copy the size from the base type since Gigi + -- represents them the same way. if Is_Access_Type (E) then @@ -2335,15 +2333,15 @@ package body Layout is Desig_Type := Non_Limited_View (Designated_Type (E)); end if; - -- If Esize already set (e.g. by a size clause), then nothing - -- further to be done here. + -- If Esize already set (e.g. by a size clause), then nothing further + -- to be done here. if Known_Esize (E) then null; - -- Access to subprogram is a strange beast, and we let the - -- backend figure out what is needed (it may be some kind - -- of fat pointer, including the static link for example. + -- Access to subprogram is a strange beast, and we let the backend + -- figure out what is needed (it may be some kind of fat pointer, + -- including the static link for example. elsif Is_Access_Protected_Subprogram_Type (E) then null; @@ -2354,9 +2352,9 @@ package body Layout is Set_Size_Info (E, Base_Type (E)); Set_RM_Size (E, RM_Size (Base_Type (E))); - -- For other access types, we use either address size, or, if - -- a fat pointer is used (pointer-to-unconstrained array case), - -- twice the address size to accommodate a fat pointer. + -- For other access types, we use either address size, or, if a fat + -- pointer is used (pointer-to-unconstrained array case), twice the + -- address size to accommodate a fat pointer. elsif Present (Desig_Type) and then Is_Array_Type (Desig_Type) @@ -2378,9 +2376,9 @@ package body Layout is ("?this access type does not correspond to C pointer", E); end if; - -- If the designated type is a limited view it is unanalyzed. We - -- can examine the declaration itself to determine whether it will - -- need a fat pointer. + -- If the designated type is a limited view it is unanalyzed. We can + -- examine the declaration itself to determine whether it will need a + -- fat pointer. elsif Present (Desig_Type) and then Present (Parent (Desig_Type)) @@ -2392,9 +2390,9 @@ package body Layout is Init_Size (E, 2 * System_Address_Size); -- When the target is AAMP, access-to-subprogram types are fat - -- pointers consisting of the subprogram address and a static - -- link (with the exception of library-level access types, - -- where a simple subprogram address is used). + -- pointers consisting of the subprogram address and a static link + -- (with the exception of library-level access types, where a simple + -- subprogram address is used). elsif AAMP_On_Target and then @@ -2411,15 +2409,14 @@ package body Layout is -- On VMS, reset size to 32 for convention C access type if no -- explicit size clause is given and the default size is 64. Really -- we do not know the size, since depending on options for the VMS - -- compiler, the size of a pointer type can be 32 or 64, but - -- choosing 32 as the default improves compatibility with legacy - -- VMS code. + -- compiler, the size of a pointer type can be 32 or 64, but choosing + -- 32 as the default improves compatibility with legacy VMS code. -- Note: we do not use Has_Size_Clause in the test below, because we - -- want to catch the case of a derived type inheriting a size - -- clause. We want to consider this to be an explicit size clause - -- for this purpose, since it would be weird not to inherit the size - -- in this case. + -- want to catch the case of a derived type inheriting a size clause. + -- We want to consider this to be an explicit size clause for this + -- purpose, since it would be weird not to inherit the size in this + -- case. -- We do NOT do this if we are in -gnatdm mode on a non-VMS target -- since in that case we want the normal pointer representation. @@ -2440,12 +2437,11 @@ package body Layout is elsif Is_Scalar_Type (E) then - -- For discrete types, the RM_Size and Esize must be set - -- already, since this is part of the earlier processing - -- and the front end is always required to lay out the - -- sizes of such types (since they are available as static - -- attributes). All we do is to check that this rule is - -- indeed obeyed! + -- For discrete types, the RM_Size and Esize must be set already, + -- since this is part of the earlier processing and the front end is + -- always required to lay out the sizes of such types (since they are + -- available as static attributes). All we do is to check that this + -- rule is indeed obeyed! if Is_Discrete_Type (E) then @@ -2472,10 +2468,10 @@ package body Layout is Init_Esize (E, S); exit; - -- If the RM_Size is greater than 64 (happens only - -- when strange values are specified by the user, - -- then Esize is simply a copy of RM_Size, it will - -- be further refined later on) + -- If the RM_Size is greater than 64 (happens only when + -- strange values are specified by the user, then Esize + -- is simply a copy of RM_Size, it will be further + -- refined later on) elsif S = 64 then Set_Esize (E, RM_Size (E)); @@ -2490,8 +2486,8 @@ package body Layout is end; end if; - -- For non-discrete scalar types, if the RM_Size is not set, - -- then set it now to a copy of the Esize if the Esize is set. + -- For non-discrete scalar types, if the RM_Size is not set, then set + -- it now to a copy of the Esize if the Esize is set. else if Known_Esize (E) and then Unknown_RM_Size (E) then @@ -2508,8 +2504,8 @@ package body Layout is if Known_RM_Size (E) and then Unknown_Esize (E) then - -- If the alignment is known, we bump the Esize up to the - -- next alignment boundary if it is not already on one. + -- If the alignment is known, we bump the Esize up to the next + -- alignment boundary if it is not already on one. if Known_Alignment (E) then declare @@ -2520,18 +2516,17 @@ package body Layout is end; end if; - -- If Esize is set, and RM_Size is not, RM_Size is copied from - -- Esize at least for now this seems reasonable, and is in any - -- case needed for compatibility with old versions of gigi. - -- look to be unknown. + -- If Esize is set, and RM_Size is not, RM_Size is copied from Esize. + -- At least for now this seems reasonable, and is in any case needed + -- for compatibility with old versions of gigi. elsif Known_Esize (E) and then Unknown_RM_Size (E) then Set_RM_Size (E, Esize (E)); end if; - -- For array base types, set component size if object size of - -- the component type is known and is a small power of 2 (8, - -- 16, 32, 64), since this is what will always be used. + -- For array base types, set component size if object size of the + -- component type is known and is a small power of 2 (8, 16, 32, 64), + -- since this is what will always be used. if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) @@ -2540,8 +2535,8 @@ package body Layout is CT : constant Entity_Id := Component_Type (E); begin - -- For some reasons, access types can cause trouble, - -- So let's just do this for discrete types ??? + -- For some reasons, access types can cause trouble, So let's + -- just do this for discrete types ??? if Present (CT) and then Is_Discrete_Type (CT) @@ -2646,9 +2641,9 @@ package body Layout is begin Set_Esize (E, RM_Size (E)); - -- For scalar types, increase Object_Size to power of 2, - -- but not less than a storage unit in any case (i.e., - -- normally this means it will be storage-unit addressable). + -- For scalar types, increase Object_Size to power of 2, but + -- not less than a storage unit in any case (i.e., normally + -- this means it will be storage-unit addressable). if Is_Scalar_Type (E) then if Size <= System_Storage_Unit then @@ -2700,16 +2695,15 @@ package body Layout is SC : Node_Id; procedure Check_Size_Too_Small (Spec : Uint; Min : Uint); - -- Spec is the number of bit specified in the size clause, and - -- Min is the minimum computed size. An error is given that the - -- specified size is too small if Spec < Min, and in this case - -- both Esize and RM_Size are set to unknown in E. The error - -- message is posted on node SC. + -- Spec is the number of bit specified in the size clause, and Min is + -- the minimum computed size. An error is given that the specified size + -- is too small if Spec < Min, and in this case both Esize and RM_Size + -- are set to unknown in E. The error message is posted on node SC. procedure Check_Unused_Bits (Spec : Uint; Max : Uint); - -- Spec is the number of bits specified in the size clause, and - -- Max is the maximum computed size. A warning is given about - -- unused bits if Spec > Max. This warning is posted on node SC. + -- Spec is the number of bits specified in the size clause, and Max is + -- the maximum computed size. A warning is given about unused bits if + -- Spec > Max. This warning is posted on node SC. -------------------------- -- Check_Size_Too_Small -- @@ -2758,10 +2752,10 @@ package body Layout is end if; end if; - -- Case where Value_Size (RM_Size) is set by specific Value_Size - -- clause (we do not need to worry about Value_Size being set by - -- a Size clause, since that will have set Esize as well, and we - -- already took care of that case). + -- Case where Value_Size (RM_Size) is set by specific Value_Size clause + -- (we do not need to worry about Value_Size being set by a Size clause, + -- since that will have set Esize as well, and we already took care of + -- that case). if Known_Static_RM_Size (E) then SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size); @@ -2949,8 +2943,8 @@ package body Layout is end if; end if; - -- Set chosen alignment, and increase Esize if necessary to match - -- the chosen alignment. + -- Set chosen alignment, and increase Esize if necessary to match the + -- chosen alignment. Set_Alignment (E, UI_From_Int (Align)); @@ -2969,21 +2963,21 @@ package body Layout is FST : constant Entity_Id := First_Subtype (Def_Id); begin - -- All discrete types except for the base types in standard - -- are constrained, so indicate this by setting Is_Constrained. + -- All discrete types except for the base types in standard are + -- constrained, so indicate this by setting Is_Constrained. Set_Is_Constrained (Def_Id); - -- We set generic types to have an unknown size, since the - -- representation of a generic type is irrelevant, in view - -- of the fact that they have nothing to do with code. + -- Set generic types to have an unknown size, since the representation + -- of a generic type is irrelevant, in view of the fact that they have + -- nothing to do with code. if Is_Generic_Type (Root_Type (FST)) then Set_RM_Size (Def_Id, Uint_0); - -- If the subtype statically matches the first subtype, then - -- it is required to have exactly the same layout. This is - -- required by aliasing considerations. + -- If the subtype statically matches the first subtype, then it is + -- required to have exactly the same layout. This is required by + -- aliasing considerations. elsif Def_Id /= FST and then Subtypes_Statically_Match (Def_Id, FST) @@ -2991,9 +2985,9 @@ package body Layout is Set_RM_Size (Def_Id, RM_Size (FST)); Set_Size_Info (Def_Id, FST); - -- In all other cases the RM_Size is set to the minimum size. - -- Note that this routine is never called for subtypes for which - -- the RM_Size is set explicitly by an attribute clause. + -- In all other cases the RM_Size is set to the minimum size. Note that + -- this routine is never called for subtypes for which the RM_Size is + -- set explicitly by an attribute clause. else Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id))); @@ -3033,9 +3027,9 @@ package body Layout is return; end if; - -- Here we calculate the alignment as the largest power of two - -- multiple of System.Storage_Unit that does not exceed either - -- the actual size of the type, or the maximum allowed alignment. + -- Here we calculate the alignment as the largest power of two multiple + -- of System.Storage_Unit that does not exceed either the actual size of + -- the type, or the maximum allowed alignment. declare S : constant Int := @@ -3050,18 +3044,18 @@ package body Layout is A := 2 * A; end loop; - -- Now we think we should set the alignment to A, but we - -- skip this if an alignment is already set to a value - -- greater than A (happens for derived types). + -- Now we think we should set the alignment to A, but we skip this if + -- an alignment is already set to a value greater than A (happens for + -- derived types). - -- However, if the alignment is known and too small it - -- must be increased, this happens in a case like: + -- However, if the alignment is known and too small it must be + -- increased, this happens in a case like: -- type R is new Character; -- for R'Size use 16; - -- Here the alignment inherited from Character is 1, but - -- it must be increased to 2 to reflect the increased size. + -- Here the alignment inherited from Character is 1, but it must be + -- increased to 2 to reflect the increased size. if Unknown_Alignment (E) or else Alignment (E) < A then Init_Alignment (E, A); @@ -3170,8 +3164,8 @@ package body Layout is Make_Simple_Return_Statement (Loc, Expression => Expr)))); - -- The caller requests that the expression be encapsulated in - -- a parameterless function. + -- The caller requests that the expression be encapsulated in a + -- parameterless function. elsif Make_Func then Decl := diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 8af553fef59..2ab83c53aa8 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1834,7 +1834,11 @@ package body Lib.Xref is Par : Node_Id; begin - if Ekind (Scope (E)) /= E_Generic_Package then + -- The Present check here is an error defense + + if Present (Scope (E)) + and then Ekind (Scope (E)) /= E_Generic_Package + then return False; end if; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 7d055096832..13156357dc0 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1865,7 +1865,7 @@ package body Make is ALI := No_ALI_Id; Verbose_Msg - (Unit_Name, " sources does not include ", + (Unit_Name, " sources do not include ", Name_Id (WR.Sfile)); return; diff --git a/gcc/ada/mlib-tgt-specific-vms-alpha.adb b/gcc/ada/mlib-tgt-specific-vms-alpha.adb index 291293607f9..f272307b935 100644 --- a/gcc/ada/mlib-tgt-specific-vms-alpha.adb +++ b/gcc/ada/mlib-tgt-specific-vms-alpha.adb @@ -276,12 +276,26 @@ package body MLib.Tgt.Specific is -- Create and write the auto-init assembly file declare - First_Line : constant String := - ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" & - ASCII.LF; - Second_Line : constant String := - ASCII.HT & ".long " & Init_Proc & ASCII.LF; - -- First and second lines of the auto-init assembly file + use ASCII; + + -- Output a dummy transfer address for debugging + -- followed by the LIB$INITIALIZE section. + + Lines : constant String := + HT & ".text" & LF & + HT & ".align 4" & LF & + HT & ".globl __main" & LF & + HT & ".ent __main" & LF & + "__main..en:" & LF & + HT & ".base $27" & LF & + HT & ".frame $29,0,$26,8" & LF & + HT & "ret $31,($26),1" & LF & + HT & ".link" & LF & + "__main:" & LF & + HT & ".pdesc __main..en,null" & LF & + HT & ".end __main" & LF & LF & + HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF & + HT & ".long " & Init_Proc & LF; begin Macro_File := Create_File (Macro_File_Name, Text); @@ -289,16 +303,9 @@ package body MLib.Tgt.Specific is 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; + (Macro_File, Lines (Lines'First)'Address, + Lines'Length); + OK := Len = Lines'Length; end if; if OK then diff --git a/gcc/ada/mlib-tgt-specific-vms-ia64.adb b/gcc/ada/mlib-tgt-specific-vms-ia64.adb index baa8ce213f1..ed483876be4 100644 --- a/gcc/ada/mlib-tgt-specific-vms-ia64.adb +++ b/gcc/ada/mlib-tgt-specific-vms-ia64.adb @@ -275,26 +275,30 @@ package body MLib.Tgt.Specific is -- 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; + use ASCII; + + -- Output a dummy transfer address for debugging + -- followed by the LIB$INITIALIZE section. + + Lines : constant String := + HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF & + HT & ".text" & LF & + HT & ".align 16" & LF & + HT & ".global __main#" & LF & + HT & ".proc __main#" & LF & + "__main:" & LF & + HT & ".prologue" & LF & + HT & ".body" & LF & + HT & ".mib" & LF & + HT & "nop 0" & LF & + HT & "nop 0" & LF & + HT & "br.ret.sptk.many b0" & LF & + HT & ".endp __main#" & LF & LF & + HT & ".type " & Init_Proc & "#, @function" & LF & + HT & ".global " & Init_Proc & "#" & LF & + HT & ".global LIB$INITIALIZE#" & LF & + HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF & + HT & "data4 @fptr(" & Init_Proc & "#)" & LF; begin Macro_File := Create_File (Macro_File_Name, Text); @@ -302,37 +306,9 @@ package body MLib.Tgt.Specific is 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; + (Macro_File, Lines (Lines'First)'Address, + Lines'Length); + OK := Len = Lines'Length; end if; if OK then diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb index 4d15ad85cf3..76e7db5332b 100644 --- a/gcc/ada/mlib-utl.adb +++ b/gcc/ada/mlib-utl.adb @@ -35,6 +35,10 @@ with System; package body MLib.Utl is + Adalib_Path : String_Access := null; + -- Path of the GNAT adalib directory, specified in procedure + -- Specify_Adalib_Dir. Used in function Lib_Directory. + Gcc_Name : String_Access; -- Default value of the "gcc" executable used in procedure Gcc @@ -597,6 +601,13 @@ package body MLib.Utl is Libgnat : constant String := Tgt.Libgnat; begin + -- If procedure Specify_Adalib_Dir has been called, used the specified + -- value. + + if Adalib_Path /= null then + return Adalib_Path.all; + end if; + Name_Len := Libgnat'Length; Name_Buffer (1 .. Name_Len) := Libgnat; Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library)); @@ -606,4 +617,17 @@ package body MLib.Utl is return Name_Buffer (1 .. Name_Len - Libgnat'Length); end Lib_Directory; + ------------------------ + -- Specify_Adalib_Dir -- + ------------------------ + + procedure Specify_Adalib_Dir (Path : String) is + begin + if Path'Length = 0 then + Adalib_Path := null; + else + Adalib_Path := new String'(Path); + end if; + end Specify_Adalib_Dir; + end MLib.Utl; diff --git a/gcc/ada/mlib-utl.ads b/gcc/ada/mlib-utl.ads index 237c678d1a7..f91eebf7f51 100644 --- a/gcc/ada/mlib-utl.ads +++ b/gcc/ada/mlib-utl.ads @@ -58,4 +58,10 @@ package MLib.Utl is function Lib_Directory return String; -- Return the directory containing libgnat + procedure Specify_Adalib_Dir (Path : String); + -- Specify the path of the GNAT adalib directory, to be returned by + -- function Lib_Directory without looking for it. This is used only in + -- gprlib, because we cannot rely on the search in Lib_Directory, as the + -- GNAT version may be different for gprbuild/gprlib and the compiler. + end MLib.Utl; diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb index b0301d2817c..0bb3a99fbfb 100644 --- a/gcc/ada/mlib.adb +++ b/gcc/ada/mlib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -310,18 +310,9 @@ package body MLib is pragma Unreferenced (Success, Result); begin - if Is_Absolute_Path (Lib_Version) then - Version_Path := new String (1 .. Lib_Version'Length + 1); - Version_Path (1 .. Lib_Version'Length) := Lib_Version; - - else - Version_Path := - new String (1 .. Lib_Dir'Length + 1 + Lib_Version'Length + 1); - Version_Path (1 .. Version_Path'Last - 1) := - Lib_Dir & Directory_Separator & Lib_Version; - end if; - - Version_Path (Version_Path'Last) := ASCII.NUL; + Version_Path := new String (1 .. Lib_Version'Length + 1); + Version_Path (1 .. Lib_Version'Length) := Lib_Version; + Version_Path (Version_Path'Last) := ASCII.NUL; if Maj_Version'Length = 0 then declare @@ -339,6 +330,7 @@ package body MLib is Maj_Path : constant String := Lib_Dir & Directory_Separator & Maj_Version; Newpath2 : String (1 .. Maj_Path'Length + 1); + Maj_Ver : String (1 .. Maj_Version'Length + 1); begin Newpath1 (1 .. Lib_Path'Length) := Lib_Path; @@ -347,13 +339,16 @@ package body MLib is Newpath2 (1 .. Maj_Path'Length) := Maj_Path; Newpath2 (Newpath2'Last) := ASCII.NUL; + Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; + Maj_Ver (Maj_Ver'Last) := ASCII.NUL; + Delete_File (Maj_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath2'Address); Delete_File (Lib_Path, Success); - Result := Symlink (Newpath2'Address, Newpath1'Address); + Result := Symlink (Maj_Ver'Address, Newpath1'Address); end; end if; end Create_Sym_Links; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 7ffa2d5d855..68bf246919a 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -283,11 +283,6 @@ package Opt is -- is set True, or if pragma No_Run_Time is used. See the spec of Rtsfind -- for details on the handling of the latter pragma. - Canonical_Streams : Boolean := False; - -- GNATBIND - -- Set to True if configuration pragma Canonical_Streams is present. It - -- controls the canonical behaviour of stream operations for String types. - Constant_Condition_Warnings : Boolean := False; -- GNAT -- Set to True to activate warnings on constant conditions @@ -533,6 +528,11 @@ package Opt is -- the name is of the form .xxx, then to name.xxx where name is the source -- file name with extension stripped. + Generate_Processed_File : Boolean := False; + -- GNAT + -- True when switch -gnateG is used. When True, create in a file + -- <source>.prep, if the source is preprocessed. + Generating_Code : Boolean := False; -- GNAT -- True if the frontend finished its work and has called the backend to diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index eb16fb1737b..f433352b06d 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -115,7 +115,7 @@ package body Ch10 is P : Node_Id; SR_Present : Boolean; - Cunit_Error_Flag : Boolean := False; + Cunit_Error_Flag : Boolean := False; -- This flag is set True if we have to scan for a compilation unit -- token. It is used to ensure clean termination in such cases by -- not insisting on being at the end of file, and, in the syntax only @@ -140,8 +140,8 @@ package body Ch10 is Config_Pragmas := No_List; - -- If we have an initial Source_Reference pragma, then remember - -- the fact to generate an NR parameter in the output line. + -- If we have an initial Source_Reference pragma, then remember the fact + -- to generate an NR parameter in the output line. SR_Present := False; @@ -180,8 +180,7 @@ package body Ch10 is Item := P_Pragma; if Item = Error - or else not - Is_Configuration_Pragma_Name (Pragma_Name (Item)) + or else not Is_Configuration_Pragma_Name (Pragma_Name (Item)) then Restore_Scan_State (Scan_State); exit; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index c2ec59be9dc..9a5a8d39345 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -206,6 +206,18 @@ package body Ch3 is Ident_Node := Token_Node; Scan; -- past the reserved identifier + -- If we already have a defining identifier, clean it out and make + -- a new clean identifier. This situation arises in some error cases + -- and we need to fix it. + + if Nkind (Ident_Node) = N_Defining_Identifier then + Ident_Node := + Make_Identifier (Sloc (Ident_Node), + Chars => Chars (Ident_Node)); + end if; + + -- Change identifier to defining identifier if not in error + if Ident_Node /= Error then Change_Identifier_To_Defining_Identifier (Ident_Node); end if; @@ -290,20 +302,12 @@ package body Ch3 is Scan; -- past TYPE Ident_Node := P_Defining_Identifier (C_Is); - -- Otherwise this is an error case, and we may already have converted - -- the current token to a defining identifier, so don't do it again! + -- Otherwise this is an error case else T_Type; - - if Token = Tok_Identifier - and then Nkind (Token_Node) = N_Defining_Identifier - then - Ident_Node := Token_Node; - Scan; -- past defining identifier - else - Ident_Node := P_Defining_Identifier (C_Is); - end if; + Type_Token_Location := Type_Loc; + Ident_Node := P_Defining_Identifier (C_Is); end if; Discr_Sloc := Token_Ptr; @@ -1356,7 +1360,6 @@ package body Ch3 is -- If we have a comma, then scan out the list of identifiers elsif Token = Tok_Comma then - while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 7e68cbea1cb..ba32f387b6a 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1032,6 +1032,10 @@ begin raise Constraint_Error; end if; + Upper_Half_Encoding := + Wide_Character_Encoding_Method in + WC_Upper_Half_Encoding_Method; + exception when Constraint_Error => Error_Msg_N ("invalid argument for pragma%", Arg1); @@ -1054,7 +1058,6 @@ begin Pragma_Atomic | Pragma_Atomic_Components | Pragma_Attach_Handler | - Pragma_Canonical_Streams | Pragma_Check | Pragma_Check_Name | Pragma_Check_Policy | diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index eb739a75274..c1f4a5e780b 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1043,10 +1043,12 @@ package body Prep is -- Preprocess -- ---------------- - procedure Preprocess is + procedure Preprocess (Source_Modified : out Boolean) is Start_Of_Processing : Source_Ptr; Cond : Boolean; Preprocessor_Line : Boolean := False; + No_Error_Found : Boolean := True; + Modified : Boolean := False; procedure Output (From, To : Source_Ptr); -- Output the characters with indices From .. To in the buffer @@ -1118,75 +1120,21 @@ package body Prep is -- Preprocessor line if Token = Tok_Special and then Special_Character = '#' then - Preprocessor_Line := True; - Scan.all; - - case Token is - - -- #if - - when Tok_If => - declare - If_Ptr : constant Source_Ptr := Token_Ptr; - - begin - Scan.all; - Cond := Expression (not Deleting); - - -- Check for an eventual "then" - - if Token = Tok_Then then - Scan.all; - end if; - - -- It is an error to have trailing characters after - -- the condition or "then". - - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then - Error_Msg - ("extraneous text on preprocessor line", - Token_Ptr); - Go_To_End_Of_Line; - end if; - - declare - -- Set the initial state of this new "#if". - -- This must be done before incrementing the - -- Last of the table, otherwise function - -- Deleting does not report the correct value. - - New_State : constant Pp_State := - (If_Ptr => If_Ptr, - Else_Ptr => 0, - Deleting => Deleting or (not Cond), - Match_Seen => Deleting or Cond); - - begin - Pp_States.Increment_Last; - Pp_States.Table (Pp_States.Last) := New_State; - end; - end; - - -- #elsif + Modified := True; + Preprocessor_Line := True; + Scan.all; - when Tok_Elsif => - Cond := False; + case Token is - if Pp_States.Last = 0 - or else Pp_States.Table (Pp_States.Last).Else_Ptr - /= 0 - then - Error_Msg ("no IF for this ELSIF", Token_Ptr); + -- #if - else - Cond := - not Pp_States.Table (Pp_States.Last).Match_Seen; - end if; + when Tok_If => + declare + If_Ptr : constant Source_Ptr := Token_Ptr; + begin Scan.all; - Cond := Expression (Cond); + Cond := Expression (not Deleting); -- Check for an eventual "then" @@ -1203,136 +1151,201 @@ package body Prep is Error_Msg ("extraneous text on preprocessor line", Token_Ptr); - + No_Error_Found := False; Go_To_End_Of_Line; end if; - -- Depending on the value of the condition, set the - -- new values of Deleting and Match_Seen. - if Pp_States.Last > 0 then - if Pp_States.Table (Pp_States.Last).Match_Seen then - Pp_States.Table (Pp_States.Last).Deleting := - True; - else - if Cond then - Pp_States.Table (Pp_States.Last).Match_Seen := - True; - Pp_States.Table (Pp_States.Last).Deleting := - False; - end if; - end if; - end if; + declare + -- Set the initial state of this new "#if". This + -- must be done before incrementing the Last of + -- the table, otherwise function Deleting does + -- not report the correct value. - -- #else + New_State : constant Pp_State := + (If_Ptr => If_Ptr, + Else_Ptr => 0, + Deleting => Deleting or (not Cond), + Match_Seen => Deleting or Cond); - when Tok_Else => - if Pp_States.Last = 0 then - Error_Msg ("no IF for this ELSE", Token_Ptr); + begin + Pp_States.Increment_Last; + Pp_States.Table (Pp_States.Last) := New_State; + end; + end; - elsif - Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 - then - Error_Msg ("duplicate ELSE line", Token_Ptr); - end if; + -- #elsif - -- Set the possibly new values of Deleting and - -- Match_Seen. + when Tok_Elsif => + Cond := False; - if Pp_States.Last > 0 then - if Pp_States.Table (Pp_States.Last).Match_Seen then - Pp_States.Table (Pp_States.Last).Deleting := - True; + if Pp_States.Last = 0 + or else Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 + then + Error_Msg ("no IF for this ELSIF", Token_Ptr); + No_Error_Found := False; - else + else + Cond := + not Pp_States.Table (Pp_States.Last).Match_Seen; + end if; + + Scan.all; + Cond := Expression (Cond); + + -- Check for an eventual "then" + + if Token = Tok_Then then + Scan.all; + end if; + + -- It is an error to have trailing characters after + -- the condition or "then". + + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + + Go_To_End_Of_Line; + end if; + + -- Depending on the value of the condition, set the + -- new values of Deleting and Match_Seen. + if Pp_States.Last > 0 then + if Pp_States.Table (Pp_States.Last).Match_Seen then + Pp_States.Table (Pp_States.Last).Deleting := True; + else + if Cond then Pp_States.Table (Pp_States.Last).Match_Seen := True; Pp_States.Table (Pp_States.Last).Deleting := False; end if; + end if; + end if; - -- Set the Else_Ptr to check for illegal #elsif - -- later. + -- #else - Pp_States.Table (Pp_States.Last).Else_Ptr := - Token_Ptr; - end if; + when Tok_Else => + if Pp_States.Last = 0 then + Error_Msg ("no IF for this ELSE", Token_Ptr); + No_Error_Found := False; - Scan.all; + elsif + Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 + then + Error_Msg ("duplicate ELSE line", Token_Ptr); + No_Error_Found := False; + end if; - -- It is an error to have characters after "#else" - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then - Error_Msg - ("extraneous text on preprocessor line", - Token_Ptr); - Go_To_End_Of_Line; - end if; + -- Set the possibly new values of Deleting and + -- Match_Seen. - -- #end if; + if Pp_States.Last > 0 then + if Pp_States.Table (Pp_States.Last).Match_Seen then + Pp_States.Table (Pp_States.Last).Deleting := + True; - when Tok_End => - if Pp_States.Last = 0 then - Error_Msg ("no IF for this END", Token_Ptr); + else + Pp_States.Table (Pp_States.Last).Match_Seen := + True; + Pp_States.Table (Pp_States.Last).Deleting := + False; end if; + -- Set the Else_Ptr to check for illegal #elsif + -- later. + + Pp_States.Table (Pp_States.Last).Else_Ptr := + Token_Ptr; + end if; + + Scan.all; + + -- It is an error to have characters after "#else" + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + Go_To_End_Of_Line; + end if; + + -- #end if; + + when Tok_End => + if Pp_States.Last = 0 then + Error_Msg ("no IF for this END", Token_Ptr); + No_Error_Found := False; + end if; + + Scan.all; + + if Token /= Tok_If then + Error_Msg ("IF expected", Token_Ptr); + No_Error_Found := False; + + else Scan.all; - if Token /= Tok_If then - Error_Msg ("IF expected", Token_Ptr); + if Token /= Tok_Semicolon then + Error_Msg ("`;` Expected", Token_Ptr); + No_Error_Found := False; else Scan.all; - if Token /= Tok_Semicolon then - Error_Msg ("`;` Expected", Token_Ptr); - - else - Scan.all; - - -- It is an error to have character after - -- "#end if;". - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then - Error_Msg - ("extraneous text on preprocessor line", - Token_Ptr); - end if; + -- It is an error to have character after + -- "#end if;". + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; end if; end if; + end if; - -- In case of one of the errors above, skip the tokens - -- until the end of line is reached. + -- In case of one of the errors above, skip the tokens + -- until the end of line is reached. - Go_To_End_Of_Line; + Go_To_End_Of_Line; - -- Decrement the depth of the #if stack + -- Decrement the depth of the #if stack - if Pp_States.Last > 0 then - Pp_States.Decrement_Last; - end if; + if Pp_States.Last > 0 then + Pp_States.Decrement_Last; + end if; - -- Illegal preprocessor line + -- Illegal preprocessor line - when others => - if Pp_States.Last = 0 then - Error_Msg ("IF expected", Token_Ptr); + when others => + No_Error_Found := False; - elsif - Pp_States.Table (Pp_States.Last).Else_Ptr = 0 - then - Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", - Token_Ptr); + if Pp_States.Last = 0 then + Error_Msg ("IF expected", Token_Ptr); - else - Error_Msg ("IF or `END IF` expected", Token_Ptr); - end if; + elsif + Pp_States.Table (Pp_States.Last).Else_Ptr = 0 + then + Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", + Token_Ptr); + + else + Error_Msg ("IF or `END IF` expected", Token_Ptr); + end if; - -- Skip to the end of this illegal line + -- Skip to the end of this illegal line - Go_To_End_Of_Line; - end case; + Go_To_End_Of_Line; + end case; -- Not a preprocessor line @@ -1352,6 +1365,8 @@ package body Prep is if Token = Tok_Special and then Special_Character = '$' then + Modified := True; + declare Dollar_Ptr : constant Source_Ptr := Token_Ptr; Symbol : Symbol_Id; @@ -1449,7 +1464,10 @@ package body Prep is for Level in reverse 1 .. Pp_States.Last loop Error_Msg ("no `END IF` for this IF", Pp_States.Table (Level).If_Ptr); + No_Error_Found := False; end loop; + + Source_Modified := No_Error_Found and Modified; end Preprocess; end Prep; diff --git a/gcc/ada/prep.ads b/gcc/ada/prep.ads index 198ddb4159f..0f595e64dfb 100644 --- a/gcc/ada/prep.ads +++ b/gcc/ada/prep.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -106,9 +106,10 @@ package Prep is -- Parse the definition file. The definition file must have already been -- loaded and the scanner initialized. - procedure Preprocess; + procedure Preprocess (Source_Modified : out Boolean); -- Preprocess the input file. The input file must have already been loaded - -- and the scanner initialized. + -- and the scanner initialized. Source_Modified is set to True iff the + -- preprocessor modified the source text. procedure Check_Command_Line_Symbol_Definition (Definition : String; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 6f6c888b4e6..9e8c92dbc44 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -168,6 +168,7 @@ package body Prj.Attr is "Sadriver#" & "Larequired_switches#" & "Lapic_option#" & + "Sapath_syntax#" & -- Configuration - Mapping files @@ -200,6 +201,7 @@ package body Prj.Attr is "Pbuilder#" & "Ladefault_switches#" & "Lcswitches#" & + "Lcglobal_compilation_switches#" & "Scexecutable#" & "SVexecutable_suffix#" & "SVglobal_configuration_pragmas#" & diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 3aa90ddfbd1..b3dc949347c 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1442,7 +1442,7 @@ package body Prj.Nmsc is then In_Tree.Languages_Data.Table (Lang_Index).Config.Dependency_Kind := - Makefile; + Makefile; end if; List := Element.Value.Values; @@ -1481,7 +1481,7 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Include_Path := - Element.Value.Value; + Element.Value.Value; when Name_Include_Path_File => @@ -1489,7 +1489,7 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Include_Path_File := - Element.Value.Value; + Element.Value.Value; when Name_Driver => @@ -1499,16 +1499,32 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Compiler_Driver := - File_Name_Type (Element.Value.Value); + File_Name_Type (Element.Value.Value); when Name_Required_Switches => Put (Into_List => - In_Tree.Languages_Data.Table - (Lang_Index).Config. - Compiler_Required_Switches, + In_Tree.Languages_Data.Table + (Lang_Index).Config. + Compiler_Required_Switches, From_List => Element.Value.Values, In_Tree => In_Tree); + when Name_Path_Syntax => + begin + In_Tree.Languages_Data.Table + (Lang_Index).Config.Path_Syntax := + Path_Syntax_Kind'Value + (Get_Name_String (Element.Value.Value)); + + exception + when Constraint_Error => + Error_Msg + (Project, + In_Tree, + "invalid value for Path_Syntax", + Element.Value.Location); + end; + when Name_Pic_Option => -- Attribute Compiler_Pic_Option (<language>) @@ -1580,8 +1596,8 @@ package body Prj.Nmsc is end if; Put (Into_List => - In_Tree.Languages_Data.Table - (Lang_Index).Config.Config_File_Switches, + In_Tree.Languages_Data.Table + (Lang_Index).Config.Config_File_Switches, From_List => List, In_Tree => In_Tree); @@ -1591,7 +1607,7 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Objects_Path := - Element.Value.Value; + Element.Value.Value; when Name_Objects_Path_File => @@ -1599,7 +1615,7 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Objects_Path_File := - Element.Value.Value; + Element.Value.Value; when Name_Config_Body_File_Name => @@ -1607,7 +1623,7 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Body := - Element.Value.Value; + Element.Value.Value; when Name_Config_Body_File_Name_Pattern => @@ -1624,7 +1640,7 @@ package body Prj.Nmsc is In_Tree.Languages_Data.Table (Lang_Index).Config.Config_Spec := - Element.Value.Value; + Element.Value.Value; when Name_Config_Spec_File_Name_Pattern => @@ -1678,8 +1694,7 @@ package body Prj.Nmsc is Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop - Attribute := - In_Tree.Variable_Elements.Table (Attribute_Id); + Attribute := In_Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Separate_Suffix then diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 901875ad204..5e0b14f0151 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -165,13 +165,12 @@ package body Prj.Part is Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String); - -- Parse a project file. - -- Recursive procedure: it calls itself for imported and extended - -- projects. When From_Extended is not None, if the project has already - -- been parsed and is an extended project A, return the ultimate - -- (not extended) project that extends A. When In_Limited is True, - -- the importing path includes at least one "limited with". - -- When parsing configuration projects, do not allow a depth > 1. + -- Parse a project file. This is a recursive procedure: it calls itself for + -- imported and extended projects. When From_Extended is not None, if the + -- project has already been parsed and is an extended project A, return the + -- ultimate (not extended) project that extends A. When In_Limited is True, + -- the importing path includes at least one "limited with". When parsing + -- configuration projects, do not allow a depth > 1. procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 67ae8ba85f0..134f85b8b1c 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -83,12 +83,15 @@ package body Prj.Proc is -- Current_Dir is for optimization purposes, avoiding extra system calls. procedure Copy_Package_Declarations - (From : Declarations; - To : in out Declarations; - New_Loc : Source_Ptr; - In_Tree : Project_Tree_Ref); + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Naming_Restricted : Boolean; + In_Tree : Project_Tree_Ref); -- Copy a package declaration From to To for a renamed package. Change the - -- locations of all the attributes to New_Loc. + -- locations of all the attributes to New_Loc. When Naming_Restricted is + -- True, do not copy attributes Body, Spec, Implementation and + -- Specification. function Expression (Project : Project_Id; @@ -310,10 +313,11 @@ package body Prj.Proc is ------------------------------- procedure Copy_Package_Declarations - (From : Declarations; - To : in out Declarations; - New_Loc : Source_Ptr; - In_Tree : Project_Tree_Ref) + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Naming_Restricted : Boolean; + In_Tree : Project_Tree_Ref) is V1 : Variable_Id := From.Attributes; V2 : Variable_Id := No_Variable; @@ -368,67 +372,73 @@ package body Prj.Proc is while A1 /= No_Array loop - -- Copy the array - Arr := In_Tree.Arrays.Table (A1); A1 := Arr.Next; - -- Remove the Next component + if not Naming_Restricted or else + (Arr.Name /= Snames.Name_Body + and then Arr.Name /= Snames.Name_Spec + and then Arr.Name /= Snames.Name_Implementation + and then Arr.Name /= Snames.Name_Specification) + then + -- Remove the Next component - Arr.Next := No_Array; + Arr.Next := No_Array; - Array_Table.Increment_Last (In_Tree.Arrays); + Array_Table.Increment_Last (In_Tree.Arrays); - -- Create new Array declaration - if To.Arrays = No_Array then - To.Arrays := Array_Table.Last (In_Tree.Arrays); + -- Create new Array declaration - else - In_Tree.Arrays.Table (A2).Next := - Array_Table.Last (In_Tree.Arrays); - end if; + if To.Arrays = No_Array then + To.Arrays := Array_Table.Last (In_Tree.Arrays); - A2 := Array_Table.Last (In_Tree.Arrays); + else + In_Tree.Arrays.Table (A2).Next := + Array_Table.Last (In_Tree.Arrays); + end if; - -- Don't store the array, as its first element has not been set yet + A2 := Array_Table.Last (In_Tree.Arrays); - -- Copy the array elements of the array + -- Don't store the array as its first element has not been set yet - E1 := Arr.Value; - Arr.Value := No_Array_Element; + -- Copy the array elements of the array - while E1 /= No_Array_Element loop + E1 := Arr.Value; + Arr.Value := No_Array_Element; + while E1 /= No_Array_Element loop - -- Copy the array element + -- Copy the array element - Elm := In_Tree.Array_Elements.Table (E1); - E1 := Elm.Next; + Elm := In_Tree.Array_Elements.Table (E1); + E1 := Elm.Next; - -- Remove the Next component + -- Remove the Next component - Elm.Next := No_Array_Element; + Elm.Next := No_Array_Element; - -- Change the location + -- Change the location - Elm.Value.Location := New_Loc; - Array_Element_Table.Increment_Last (In_Tree.Array_Elements); + Elm.Value.Location := New_Loc; + Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - -- Create new array element + -- Create new array element - if Arr.Value = No_Array_Element then - Arr.Value := Array_Element_Table.Last (In_Tree.Array_Elements); - else - In_Tree.Array_Elements.Table (E2).Next := - Array_Element_Table.Last (In_Tree.Array_Elements); - end if; + if Arr.Value = No_Array_Element then + Arr.Value := + Array_Element_Table.Last (In_Tree.Array_Elements); + else + In_Tree.Array_Elements.Table (E2).Next := + Array_Element_Table.Last (In_Tree.Array_Elements); + end if; - E2 := Array_Element_Table.Last (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table (E2) := Elm; - end loop; + E2 := Array_Element_Table.Last (In_Tree.Array_Elements); + In_Tree.Array_Elements.Table (E2) := Elm; + end loop; - -- Finally, store the new array + -- Finally, store the new array - In_Tree.Arrays.Table (A2) := Arr; + In_Tree.Arrays.Table (A2) := Arr; + end if; end loop; end Copy_Package_Declarations; @@ -1343,14 +1353,15 @@ package body Prj.Proc is -- renaming declaration. Copy_Package_Declarations - (From => + (From => In_Tree.Packages.Table (Renamed_Package).Decl, - To => + To => In_Tree.Packages.Table (New_Pkg).Decl, - New_Loc => + New_Loc => Location_Of (Current_Item, From_Project_Node_Tree), - In_Tree => In_Tree); + Naming_Restricted => False, + In_Tree => In_Tree); end; -- Standard package declaration, not renaming @@ -2730,10 +2741,13 @@ package body Prj.Proc is Next => Processed_Data.Decl.Packages); Processed_Data.Decl.Packages := Current_Pkg; Copy_Package_Declarations - (From => Element.Decl, - To => In_Tree.Packages.Table (Current_Pkg).Decl, - New_Loc => No_Location, - In_Tree => In_Tree); + (From => Element.Decl, + To => + In_Tree.Packages.Table (Current_Pkg).Decl, + New_Loc => No_Location, + Naming_Restricted => + Element.Name = Snames.Name_Naming, + In_Tree => In_Tree); end if; Extended_Pkg := Element.Next; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 23623f5feda..505e2dad3d1 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -690,7 +690,7 @@ package body Prj is if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then return In_Tree.Languages_Data.Table - (Lang).Config.Objects_Generated; + (Lang).Config.Object_Generated; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 9af43b388ce..12b86b73079 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -399,6 +399,13 @@ package Prj is No_Source : constant Source_Id := 0; + type Path_Syntax_Kind is + (Canonical, + -- Unix style + + Host); + -- Host specific syntax, for example on VMS (the default) + type Language_Config is record Kind : Language_Kind := File_Based; -- Kind of language. All languages are file based, except Ada which is @@ -423,6 +430,10 @@ package Prj is -- The list of switches that are required as a minimum to invoke the -- compiler driver. + Path_Syntax : Path_Syntax_Kind := Host; + -- Value may be Canonical (Unix style) or Host (host syntax, for example + -- on VMS for DEC C). + Compilation_PIC_Option : Name_List_Index := No_Name_List; -- The option(s) to compile a source in Position Independent Code for -- shared libraries. Specified in the configuration. When not specified, @@ -525,12 +536,6 @@ package Prj is Toolchain_Description : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Description for the language - PIC_Option : Name_Id := No_Name; - -- Hold the value of attribute Compiler'PIC_Option for the language - - Objects_Generated : Boolean := True; - -- Indicates if objects are generated for the language - end record; -- Record describing the configuration of a language @@ -541,6 +546,7 @@ package Prj is Compiler_Driver => No_File, Compiler_Driver_Path => null, Compiler_Required_Switches => No_Name_List, + Path_Syntax => Canonical, Compilation_PIC_Option => No_Name_List, Object_Generated => True, Objects_Linked => True, @@ -567,9 +573,7 @@ package Prj is Binder_Required_Switches => No_Name_List, Binder_Prefix => No_Name, Toolchain_Version => No_Name, - Toolchain_Description => No_Name, - PIC_Option => No_Name, - Objects_Generated => True); + Toolchain_Description => No_Name); type Language_Data is record Name : Name_Id := No_Name; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 2f1bd5dec3d..99a20afcad9 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -52,22 +52,20 @@ package body Restrict is -- Local Subprograms -- ----------------------- - procedure Restriction_Msg (Msg : String; R : String; N : Node_Id); - -- Output error message at node N with given text, replacing the - -- '%' in the message with the name of the restriction given as R, - -- cased according to the current identifier casing. We do not use - -- the normal insertion mechanism, since this requires an entry - -- in the Names table, and this table will be locked if we are - -- generating a message from gigi. + procedure Restriction_Msg (R : Restriction_Id; N : Node_Id); + -- Called if a violation of restriction R at node N is found. This routine + -- outputs the appropriate message or messages taking care of warning vs + -- real violation, serious vs non-serious, implicit vs explicit, the second + -- message giving the profile name if needed, and the location information. function Same_Unit (U1, U2 : Node_Id) return Boolean; -- Returns True iff U1 and U2 represent the same library unit. Used for -- handling of No_Dependence => Unit restriction case. function Suppress_Restriction_Message (N : Node_Id) return Boolean; - -- N is the node for a possible restriction violation message, but - -- the message is to be suppressed if this is an internal file and - -- this file is not the main unit. + -- N is the node for a possible restriction violation message, but the + -- message is to be suppressed if this is an internal file and this file is + -- not the main unit. Returns True if message is to be suppressed. ------------------- -- Abort_Allowed -- @@ -148,7 +146,7 @@ package body Restrict is if Name_Len < 5 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" and then - Name_Buffer (Name_Len - 4 .. Name_Len) /= ".adb") + Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb") then return; end if; @@ -194,8 +192,6 @@ package body Restrict is N : Node_Id; V : Uint := Uint_Minus_1) is - Rimage : constant String := Restriction_Id'Image (R); - VV : Integer; -- V converted to integer form. If V is greater than Integer'Last, -- it is reset to minus 1 (unknown value). @@ -311,35 +307,7 @@ package body Restrict is and then Restrictions.Value (R) = 0) or else Restrictions.Count (R) > Restrictions.Value (R) then - Error_Msg_Sloc := Restrictions_Loc (R); - - -- If we have a location for the Restrictions pragma, output it - - if Error_Msg_Sloc > No_Location - or else Error_Msg_Sloc = System_Location - then - if Restriction_Warnings (R) then - Restriction_Msg ("|violation of restriction %#?", Rimage, N); - else - -- Normally a restriction violation is a non-serious error, - -- but we treat violation of No_Finalization as a serious - -- error, since we want to turn off expansion in this case, - -- expansion just causes too many cascaded errors. - - if R = No_Finalization then - Restriction_Msg ("violation of restriction %#", Rimage, N); - else - Restriction_Msg ("|violation of restriction %#", Rimage, N); - end if; - end if; - - -- Otherwise we have the case of an implicit restriction - -- (e.g. a restriction implicitly set by another pragma) - - else - Restriction_Msg - ("|violation of implicit restriction %", Rimage, N); - end if; + Restriction_Msg (R, N); end if; end Check_Restriction; @@ -543,43 +511,147 @@ package body Restrict is -- Restriction_Msg -- --------------------- - procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is - B : String (1 .. Msg'Length + 2 * R'Length + 1); - P : Natural := 1; + procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is + Msg : String (1 .. 100); + Len : Natural := 0; - begin - Name_Buffer (1 .. R'Last) := R; - Name_Len := R'Length; - Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); - - P := 0; - for J in Msg'Range loop - if Msg (J) = '%' then - P := P + 1; - B (P) := '`'; - - -- Put characters of image in message, quoting upper case letters - - for J in 1 .. Name_Len loop - if Name_Buffer (J) in 'A' .. 'Z' then - P := P + 1; - B (P) := '''; - end if; + procedure Add_Char (C : Character); + -- Append given character to Msg, bumping Len - P := P + 1; - B (P) := Name_Buffer (J); - end loop; + procedure Add_Str (S : String); + -- Append given string to Msg, bumping Len appropriately + + procedure Id_Case (S : String; Quotes : Boolean := True); + -- Given a string S, case it according to current identifier casing, + -- and store in Error_Msg_String. Then append `~` to the message buffer + -- to output the string unchanged surrounded in quotes. The quotes are + -- suppressed if Quotes = False. + + -------------- + -- Add_Char -- + -------------- + + procedure Add_Char (C : Character) is + begin + Len := Len + 1; + Msg (Len) := C; + end Add_Char; + + ------------- + -- Add_Str -- + ------------- - P := P + 1; - B (P) := '`'; + procedure Add_Str (S : String) is + begin + Msg (Len + 1 .. Len + S'Length) := S; + Len := Len + S'Length; + end Add_Str; + ------------- + -- Id_Case -- + ------------- + + procedure Id_Case (S : String; Quotes : Boolean := True) is + begin + Name_Buffer (1 .. S'Last) := S; + Name_Len := S'Length; + Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); + Error_Msg_Strlen := Name_Len; + Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + + if Quotes then + Add_Str ("`~`"); else - P := P + 1; - B (P) := Msg (J); + Add_Char ('~'); + end if; + end Id_Case; + + -- Start of processing for Restriction_Msg + + begin + -- Set warning message if warning + + if Restriction_Warnings (R) then + Add_Char ('?'); + + -- If real violation (not warning), then mark it as non-serious unless + -- it is a violation of No_Finalization in which case we leave it as a + -- serious message, since otherwise we get crashes during attempts to + -- expand stuff that is not properly formed due to assumptions made + -- about no finalization being present. + + elsif R /= No_Finalization then + Add_Char ('|'); + end if; + + Error_Msg_Sloc := Restrictions_Loc (R); + + -- Set main message, adding implicit if no source location + + if Error_Msg_Sloc > No_Location + or else Error_Msg_Sloc = System_Location + then + Add_Str ("violation of restriction "); + else + Add_Str ("violation of implicit restriction "); + Error_Msg_Sloc := No_Location; + end if; + + -- Case of parametrized restriction + + if R in All_Parameter_Restrictions then + Add_Char ('`'); + Id_Case (Restriction_Id'Image (R), Quotes => False); + Add_Str (" = ^`"); + Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R))); + + -- Case of boolean restriction + + else + Id_Case (Restriction_Id'Image (R)); + end if; + + -- Case of no secondary profile continuation message + + if Restriction_Profile_Name (R) = No_Profile then + if Error_Msg_Sloc /= No_Location then + Add_Char ('#'); + end if; + + Add_Char ('!'); + Error_Msg_N (Msg (1 .. Len), N); + + -- Case of secondary profile continuation message present + + else + Add_Char ('!'); + Error_Msg_N (Msg (1 .. Len), N); + + Len := 0; + Add_Char ('\'); + + -- Set as warning if warning case + + if Restriction_Warnings (R) then + Add_Char ('?'); end if; - end loop; - Error_Msg_N (B (1 .. P), N); + -- Set main message + + Add_Str ("from profile "); + Id_Case (Profile_Name'Image (Restriction_Profile_Name (R))); + + -- Add location if we have one + + if Error_Msg_Sloc /= No_Location then + Add_Char ('#'); + end if; + + -- Output unconditional message and we are done + + Add_Char ('!'); + Error_Msg_N (Msg (1 .. Len), N); + end if; end Restriction_Msg; --------------- @@ -634,6 +706,10 @@ package body Restrict is Set_Restriction (J, N, V (J)); end if; + -- Record that this came from a Profile[_Warnings] restriction + + Restriction_Profile_Name (J) := P; + -- Set warning flag, except that we do not set the warning -- flag if the restriction was already active and this is -- the warning case. That avoids a warning overriding a real @@ -683,13 +759,17 @@ package body Restrict is Restricted_Profile_Cached := False; end if; - -- Set location, but preserve location of system - -- restriction for nice error msg with run time name + -- Set location, but preserve location of system restriction for nice + -- error msg with run time name. if Restrictions_Loc (R) /= System_Location then Restrictions_Loc (R) := Sloc (N); end if; + -- Note restriction came from restriction pragma, not profile + + Restriction_Profile_Name (R) := No_Profile; + -- Record the restriction if we are in the main unit, or in the extended -- main unit. The reason that we test separately for Main_Unit is that -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in @@ -731,12 +811,11 @@ package body Restrict is Restrictions_Loc (R) := Sloc (N); end if; - -- Record the restriction if we are in the main unit, - -- or in the extended main unit. The reason that we - -- test separately for Main_Unit is that gnat.adc is - -- processed with Current_Sem_Unit = Main_Unit, but - -- nodes in gnat.adc do not appear to be the extended - -- main source unit (they probably should do ???) + -- Record the restriction if we are in the main unit, or in the extended + -- main unit. The reason that we test separately for Main_Unit is that + -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in + -- gnat.adc do not appear to be the extended main source unit (they + -- probably should do ???) if Current_Sem_Unit = Main_Unit or else In_Extended_Main_Source_Unit (N) @@ -751,6 +830,10 @@ package body Restrict is Main_Restrictions.Value (R) := V; end if; end if; + + -- Note restriction came from restriction pragma, not profile + + Restriction_Profile_Name (R) := No_Profile; end Set_Restriction; ----------------------------------- @@ -758,8 +841,9 @@ package body Restrict is ----------------------------------- procedure Set_Restriction_No_Dependence - (Unit : Node_Id; - Warn : Boolean) + (Unit : Node_Id; + Warn : Boolean; + Profile : Profile_Name := No_Profile) is begin -- Loop to check for duplicate entry @@ -782,7 +866,7 @@ package body Restrict is -- Entry is not currently in table - No_Dependence.Append ((Unit, Warn)); + No_Dependence.Append ((Unit, Warn, Profile)); end Set_Restriction_No_Dependence; ---------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index bb81d85ed79..2553e0444aa 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -50,6 +50,12 @@ package Restrict is -- pragma, and a value of System_Location is used for restrictions -- set from package Standard by the processing in Targparm. + Restriction_Profile_Name : array (All_Restrictions) of Profile_Name; + -- Entries in this array are valid only if the corresponding restriction + -- in Restrictions set. The value is the corresponding profile name if the + -- restriction was set by a Profile or Profile_Warnings pragma. The value + -- is No_Profile in all other cases. + Main_Restrictions : Restrictions_Info := No_Restrictions; -- This variable records only restrictions found in any units of the -- main extended unit. These are the variables used for ali file output, @@ -154,6 +160,10 @@ package Restrict is Warn : Boolean; -- True if from Restriction_Warnings, False if from Restrictions + + Profile : Profile_Name; + -- Set to name of profile from which No_Dependence entry came, or to + -- No_Profile if a pragma Restriction set the No_Dependence entry. end record; package No_Dependence is new Table.Table ( @@ -190,14 +200,13 @@ package Restrict is V : Uint := Uint_Minus_1); -- Checks that the given restriction is not set, and if it is set, an -- appropriate message is posted on the given node. Also records the - -- violation in the appropriate internal arrays. Note that it is - -- mandatory to always use this routine to check if a restriction - -- is violated. Such checks must never be done directly by the caller, - -- since otherwise violations in the absence of restrictions are not - -- properly recorded. The value of V is relevant only for parameter - -- restrictions, and in this case indicates the exact count for the - -- violation. If the exact count is not known, V is left at its - -- default value of -1 which indicates an unknown count. + -- violation in the appropriate internal arrays. Note that it is mandatory + -- to always use this routine to check if a restriction is violated. Such + -- checks must never be done directly by the caller, since otherwise + -- violations in the absence of restrictions are not properly recorded. The + -- value of V is relevant only for parameter restrictions, and in this case + -- indicates the exact count for the violation. If the exact count is not + -- known, V is left at its default of -1 which indicates an unknown count. procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id); -- Called when a dependence on a unit is created (either implicitly, or by @@ -302,18 +311,19 @@ package Restrict is -- parameter restriction, and the corresponding value V is given. procedure Set_Restriction_No_Dependence - (Unit : Node_Id; - Warn : Boolean); + (Unit : Node_Id; + Warn : Boolean; + Profile : Profile_Name := No_Profile); -- Sets given No_Dependence restriction in table if not there already. -- Warn is True if from Restriction_Warnings, or for Restrictions if flag -- Treat_Restrictions_As_Warnings is set. False if from Restrictions and - -- this flag is not set. + -- this flag is not set. Profile is set to a non-default value if the + -- No_Dependence restriction comes from a Profile pragma. function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); - -- Tests to see if tasking operations are allowed by the current - -- restrictions settings. For tasking to be allowed Max_Tasks must - -- be non-zero. + -- Tests if tasking operations are allowed by the current restrictions + -- settings. For tasking to be allowed Max_Tasks must be non-zero. private type Save_Cunit_Boolean_Restrictions is diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index b3bbf6a3539..34e84065907 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -209,6 +209,7 @@ package Rtsfind is System_Compare_Array_Unsigned_64, System_Compare_Array_Unsigned_8, System_DSA_Services, + System_DSA_Types, System_Exception_Table, System_Exceptions, System_Exn_Int, @@ -696,6 +697,8 @@ package Rtsfind is RE_Get_Local_Partition_Id, -- System.DSA_Services RE_Get_Passive_Partition_Id, -- System.DSA_Services + RE_Any_Content_Ptr, -- System.DSA_Types + RE_Register_Exception, -- System.Exception_Table RE_Local_Raise, -- System.Exceptions @@ -1157,6 +1160,7 @@ package Rtsfind is RE_BS_To_Any, -- System.Partition_Interface RE_Any_To_BS, -- System.Partition_Interface + RE_FA_A, -- System.Partition_Interface RE_FA_B, -- System.Partition_Interface RE_FA_C, -- System.Partition_Interface RE_FA_F, -- System.Partition_Interface @@ -1205,7 +1209,7 @@ package Rtsfind is RE_TC_Build, -- System.Partition_Interface RE_Get_TC, -- System.Partition_Interface RE_Set_TC, -- System.Partition_Interface - RE_TC_Any, -- System.Partition_Interface + RE_TC_A, -- System.Partition_Interface RE_TC_B, -- System.Partition_Interface RE_TC_C, -- System.Partition_Interface RE_TC_F, -- System.Partition_Interface @@ -1331,17 +1335,29 @@ package Rtsfind is RE_Str_Concat_5, -- System.String_Ops_Concat_5 RE_String_Input, -- System.Strings.Stream_Ops + RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_String_Output, -- System.Strings.Stream_Ops + RE_String_Output_Blk_IO, -- System.Strings.Stream_Ops RE_String_Read, -- System.Strings.Stream_Ops + RE_String_Read_Blk_IO, -- System.Strings.Stream_Ops RE_String_Write, -- System.Strings.Stream_Ops + RE_String_Write_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_String_Output_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Output_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops RE_Task_Info_Type, -- System.Task_Info RE_Unspecified_Task_Info, -- System.Task_Info @@ -1838,6 +1854,8 @@ package Rtsfind is RE_Get_Local_Partition_Id => System_DSA_Services, RE_Get_Passive_Partition_Id => System_DSA_Services, + RE_Any_Content_Ptr => System_DSA_Types, + RE_Register_Exception => System_Exception_Table, RE_Local_Raise => System_Exceptions, @@ -2290,6 +2308,7 @@ package Rtsfind is RE_BS_To_Any => System_Partition_Interface, RE_Any_To_BS => System_Partition_Interface, + RE_FA_A => System_Partition_Interface, RE_FA_B => System_Partition_Interface, RE_FA_C => System_Partition_Interface, RE_FA_F => System_Partition_Interface, @@ -2338,7 +2357,7 @@ package Rtsfind is RE_TC_Build => System_Partition_Interface, RE_Get_TC => System_Partition_Interface, RE_Set_TC => System_Partition_Interface, - RE_TC_Any => System_Partition_Interface, + RE_TC_A => System_Partition_Interface, RE_TC_B => System_Partition_Interface, RE_TC_C => System_Partition_Interface, RE_TC_F => System_Partition_Interface, @@ -2473,17 +2492,29 @@ package Rtsfind is RE_Str_Concat_5 => System_String_Ops_Concat_5, RE_String_Input => System_Strings_Stream_Ops, + RE_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_String_Output => System_Strings_Stream_Ops, + RE_String_Output_Blk_IO => System_Strings_Stream_Ops, RE_String_Read => System_Strings_Stream_Ops, + RE_String_Read_Blk_IO => System_Strings_Stream_Ops, RE_String_Write => System_Strings_Stream_Ops, + RE_String_Write_Blk_IO => System_Strings_Stream_Ops, RE_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_String_Output_Blk_IO => System_Strings_Stream_Ops, RE_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, RE_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, RE_Wide_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_Wide_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Output_Blk_IO => System_Strings_Stream_Ops, RE_Wide_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, RE_Wide_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, RE_Task_Info_Type => System_Task_Info, RE_Unspecified_Task_Info => System_Task_Info, diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 6df7fa4a7c8..ca19e5a973f 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1316,6 +1316,25 @@ package body System.OS_Lib is return Is_Readable_File (F_Name'Address); end Is_Readable_File; + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File (Name : C_File_Name) return Boolean is + function Is_Executable_File (Name : Address) return Integer; + pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); + begin + return Is_Executable_File (Name) /= 0; + end Is_Executable_File; + + function Is_Executable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Executable_File (F_Name'Address); + end Is_Executable_File; + --------------------- -- Is_Regular_File -- --------------------- @@ -1921,6 +1940,26 @@ package body System.OS_Lib is end; end if; + -- On Windows, remove all double-quotes that are possibly part of the + -- path but can cause problems with other methods. + + if On_Windows then + declare + Index : Natural; + + begin + Index := Path_Buffer'First; + for Current in Path_Buffer'First .. End_Path loop + if Path_Buffer (Current) /= '"' then + Path_Buffer (Index) := Path_Buffer (Current); + Index := Index + 1; + end if; + end loop; + + End_Path := Index - 1; + end; + end if; + -- Start the conversions -- If this is not finished after Max_Iterations, give up and return an diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 8c319c845e1..f841558627f 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -472,6 +472,14 @@ package System.OS_Lib is -- not actually be readable due to some other process having exclusive -- access. + function Is_Executable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is executable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + function Is_Writable_File (Name : String) return Boolean; -- Determines if the given string, Name, is the name of an existing file -- that is writable. Returns True if so, False otherwise. Note that this @@ -608,6 +616,7 @@ package System.OS_Lib is function Is_Regular_File (Name : C_File_Name) return Boolean; function Is_Directory (Name : C_File_Name) return Boolean; function Is_Readable_File (Name : C_File_Name) return Boolean; + function Is_Executable_File (Name : C_File_Name) return Boolean; function Is_Writable_File (Name : C_File_Name) return Boolean; function Is_Symbolic_Link (Name : C_File_Name) return Boolean; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index bbe422377de..9dbaa73ded4 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -50,9 +50,9 @@ package System.Rident is -- The following enumeration type defines the set of restriction -- identifiers that are implemented in GNAT. - -- To add a new restriction identifier, add an entry with the name - -- to be used in the pragma, and add appropriate calls to the - -- Restrict.Check_Restriction routine. + -- To add a new restriction identifier, add an entry with the name to be + -- used in the pragma, and add calls to the Restrict.Check_Restriction + -- routine as appropriate. type Restriction_Id is @@ -102,6 +102,7 @@ package System.Rident is No_Select_Statements, -- GNAT (Ravenscar) No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) No_Standard_Storage_Pools, -- GNAT + No_Stream_Optimizations, -- GNAT No_Streams, -- GNAT No_Task_Allocators, -- (RM D.7(7)) No_Task_Attributes_Package, -- GNAT @@ -198,7 +199,7 @@ package System.Rident is subtype All_Parameter_Restrictions is Restriction_Id range Max_Protected_Entries .. Max_Storage_At_Blocking; - -- All restrictions that are take a parameter + -- All restrictions that take a parameter subtype Checked_Parameter_Restrictions is All_Parameter_Restrictions range @@ -224,8 +225,8 @@ package System.Rident is subtype Checked_Val_Parameter_Restrictions is Checked_Parameter_Restrictions range Max_Protected_Entries .. Max_Tasks; - -- Restrictions with parameter where the count is known at least in - -- some cases by the compiler/binder. + -- Restrictions with parameter where the count is known at least in some + -- cases by the compiler/binder. subtype Checked_Zero_Parameter_Restrictions is Checked_Parameter_Restrictions range @@ -306,24 +307,29 @@ package System.Rident is -- Profile Definitions and Data -- ---------------------------------- - type Profile_Name is (Ravenscar, Restricted); - -- Names of recognized profiles + type Profile_Name is (No_Profile, Ravenscar, Restricted); + -- Names of recognized profiles. No_Profile is used to indicate that a + -- restriction came from pragma Restrictions[_Warning], as opposed to + -- pragma Profile[_Warning]. + + subtype Profile_Name_Actual is Profile_Name range Ravenscar .. Restricted; + -- Actual used profile names type Profile_Data is record Set : Restriction_Flags; - -- Set to True if given restriction must be set for the profile, - -- and False if it need not be set (False does not mean that it - -- must not be set, just that it need not be set). If the flag - -- is True for a parameter restriction, then the Value array - -- gives the maximum value permitted by the profile. + -- Set to True if given restriction must be set for the profile, and + -- False if it need not be set (False does not mean that it must not be + -- set, just that it need not be set). If the flag is True for a + -- parameter restriction, then the Value array gives the maximum value + -- permitted by the profile. Value : Restriction_Values; - -- An entry in this array is meaningful only if the corresponding - -- flag in Set is True. In that case, the value in this array is - -- the maximum value of the parameter permitted by the profile. + -- An entry in this array is meaningful only if the corresponding flag + -- in Set is True. In that case, the value in this array is the maximum + -- value of the parameter permitted by the profile. end record; - Profile_Info : array (Profile_Name) of Profile_Data := + Profile_Info : array (Profile_Name_Actual) of Profile_Data := -- Restricted Profile diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb index 7dca75fbbe0..ca5c880fb31 100644 --- a/gcc/ada/s-ststop.adb +++ b/gcc/ada/s-ststop.adb @@ -43,6 +43,11 @@ with System.Stream_Attributes; use System; package body System.Strings.Stream_Ops is + -- The following type describes the low-level IO mechanism used in package + -- Stream_Ops_Internal. + + type IO_Kind is (Byte_IO, Block_IO); + -- The following package provides an IO framework for strings. Depending -- on the version of System.Stream_Attributes as well as the size of -- formal parameter Character_Type, the package will either utilize block @@ -53,13 +58,24 @@ package body System.Strings.Stream_Ops is type String_Type is array (Positive range <>) of Character_Type; package Stream_Ops_Internal is + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind) return String_Type; + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind); + procedure Read (Strm : access Root_Stream_Type'Class; - Item : out String_Type); + Item : out String_Type; + IO : IO_Kind); procedure Write (Strm : access Root_Stream_Type'Class; - Item : String_Type); + Item : String_Type; + IO : IO_Kind); end Stream_Ops_Internal; ------------------------- @@ -92,24 +108,6 @@ package body System.Strings.Stream_Ops is subtype String_Block is String_Type (1 .. C_In_Default_Block); - Flag : Integer; - pragma Import (C, Flag, "__gl_canonical_streams"); - -- This imported value is used to determine whether configuration pragma - -- Canonical_Streams is present. A value of zero indicates whether any - -- stream-related optimizations are enabled, while a value of one - -- indicates a disabled status. - - Canonical_Streams : constant Boolean := Flag = 1; - - -- Block IO is used when the low level can support block IO, the size - -- of the character type is a multiple of the stream element type and - -- the compilation can use stream optimizations. - - Use_Block_IO : constant Boolean := - Stream_Attributes.Block_IO_OK - and then C_Size mod SE_Size = 0 - and then not Canonical_Streams; - -- Conversions to and from Default_Block function To_Default_Block is @@ -118,13 +116,74 @@ package body System.Strings.Stream_Ops is function To_String_Block is new Ada.Unchecked_Conversion (Default_Block, String_Block); + ----------- + -- Input -- + ----------- + + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind) return String_Type + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + declare + Low : Positive; + High : Positive; + + begin + -- Read the bounds of the string + + Positive'Read (Strm, Low); + Positive'Read (Strm, High); + + declare + Item : String_Type (Low .. High); + + begin + -- Read the character content of the string + + Read (Strm, Item, IO); + + return Item; + end; + end; + end Input; + + ------------ + -- Output -- + ------------ + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Write the bounds of the string + + Positive'Write (Strm, Item'First); + Positive'Write (Strm, Item'Last); + + -- Write the character content of the string + + Write (Strm, Item, IO); + end Output; + ---------- -- Read -- ---------- procedure Read (Strm : access Root_Stream_Type'Class; - Item : out String_Type) + Item : out String_Type; + IO : IO_Kind) is begin if Strm = null then @@ -137,7 +196,11 @@ package body System.Strings.Stream_Ops is return; end if; - if Use_Block_IO then + -- Block IO + + if IO = Block_IO + and then Stream_Attributes.Block_IO_OK + then declare -- Determine the size in BITS of the block necessary to contain -- the whole string. @@ -221,7 +284,7 @@ package body System.Strings.Stream_Ops is end if; end; - -- Character-by-character IO + -- Byte IO else declare @@ -242,7 +305,8 @@ package body System.Strings.Stream_Ops is procedure Write (Strm : access Root_Stream_Type'Class; - Item : String_Type) + Item : String_Type; + IO : IO_Kind) is begin if Strm = null then @@ -255,7 +319,11 @@ package body System.Strings.Stream_Ops is return; end if; - if Use_Block_IO then + -- Block IO + + if IO = Block_IO + and then Stream_Attributes.Block_IO_OK + then declare -- Determine the size in BITS of the block necessary to contain -- the whole string. @@ -309,7 +377,7 @@ package body System.Strings.Stream_Ops is end if; end; - -- Character-by-character IO + -- Byte IO else for Index in Item'First .. Item'Last loop @@ -319,7 +387,7 @@ package body System.Strings.Stream_Ops is end Write; end Stream_Ops_Internal; - -- Specific instantiations for different string types + -- Specific instantiations for all Ada string types package String_Ops is new Stream_Ops_Internal @@ -344,32 +412,19 @@ package body System.Strings.Stream_Ops is (Strm : access Ada.Streams.Root_Stream_Type'Class) return String is begin - if Strm = null then - raise Constraint_Error; - end if; - - declare - Low : Positive; - High : Positive; - - begin - -- Read the bounds of the string - - Positive'Read (Strm, Low); - Positive'Read (Strm, High); - - declare - Item : String (Low .. High); - - begin - -- Read the character content of the string + return String_Ops.Input (Strm, Byte_IO); + end String_Input; - String_Read (Strm, Item); + ------------------------- + -- String_Input_Blk_IO -- + ------------------------- - return Item; - end; - end; - end String_Input; + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Block_IO); + end String_Input_Blk_IO; ------------------- -- String_Output -- @@ -380,19 +435,20 @@ package body System.Strings.Stream_Ops is Item : String) is begin - if Strm = null then - raise Constraint_Error; - end if; - - -- Write the bounds of the string - - Positive'Write (Strm, Item'First); - Positive'Write (Strm, Item'Last); + String_Ops.Output (Strm, Item, Byte_IO); + end String_Output; - -- Write the character content of the string + -------------------------- + -- String_Output_Blk_IO -- + -------------------------- - String_Write (Strm, Item); - end String_Output; + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Block_IO); + end String_Output_Blk_IO; ----------------- -- String_Read -- @@ -403,9 +459,21 @@ package body System.Strings.Stream_Ops is Item : out String) is begin - String_Ops.Read (Strm, Item); + String_Ops.Read (Strm, Item, Byte_IO); end String_Read; + ------------------------ + -- String_Read_Blk_IO -- + ------------------------ + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Block_IO); + end String_Read_Blk_IO; + ------------------ -- String_Write -- ------------------ @@ -415,44 +483,42 @@ package body System.Strings.Stream_Ops is Item : String) is begin - String_Ops.Write (Strm, Item); + String_Ops.Write (Strm, Item, Byte_IO); end String_Write; + ------------------------- + -- String_Write_Blk_IO -- + ------------------------- + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Block_IO); + end String_Write_Blk_IO; + ----------------------- -- Wide_String_Input -- ----------------------- function Wide_String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Wide_String + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String is begin - if Strm = null then - raise Constraint_Error; - end if; - - declare - Low : Positive; - High : Positive; - - begin - -- Read the bounds of the string - - Positive'Read (Strm, Low); - Positive'Read (Strm, High); - - declare - Item : Wide_String (Low .. High); - - begin - -- Read the character content of the string + return Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_String_Input; - Wide_String_Read (Strm, Item); + ------------------------------ + -- Wide_String_Input_Blk_IO -- + ------------------------------ - return Item; - end; - end; - end Wide_String_Input; + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Block_IO); + end Wide_String_Input_Blk_IO; ------------------------ -- Wide_String_Output -- @@ -463,19 +529,20 @@ package body System.Strings.Stream_Ops is Item : Wide_String) is begin - if Strm = null then - raise Constraint_Error; - end if; - - -- Write the bounds of the string - - Positive'Write (Strm, Item'First); - Positive'Write (Strm, Item'Last); + Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_String_Output; - -- Write the character content of the string + ------------------------------- + -- Wide_String_Output_Blk_IO -- + ------------------------------- - Wide_String_Write (Strm, Item); - end Wide_String_Output; + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_String_Output_Blk_IO; ---------------------- -- Wide_String_Read -- @@ -486,9 +553,21 @@ package body System.Strings.Stream_Ops is Item : out Wide_String) is begin - Wide_String_Ops.Read (Strm, Item); + Wide_String_Ops.Read (Strm, Item, Byte_IO); end Wide_String_Read; + ----------------------------- + -- Wide_String_Read_Blk_IO -- + ----------------------------- + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_String_Read_Blk_IO; + ----------------------- -- Wide_String_Write -- ----------------------- @@ -498,44 +577,42 @@ package body System.Strings.Stream_Ops is Item : Wide_String) is begin - Wide_String_Ops.Write (Strm, Item); + Wide_String_Ops.Write (Strm, Item, Byte_IO); end Wide_String_Write; + ------------------------------ + -- Wide_String_Write_Blk_IO -- + ------------------------------ + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_String_Write_Blk_IO; + ---------------------------- -- Wide_Wide_String_Input -- ---------------------------- function Wide_Wide_String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Wide_Wide_String + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String is begin - if Strm = null then - raise Constraint_Error; - end if; - - declare - Low : Positive; - High : Positive; - - begin - -- Read the bounds of the string - - Positive'Read (Strm, Low); - Positive'Read (Strm, High); - - declare - Item : Wide_Wide_String (Low .. High); - - begin - -- Read the character content of the string + return Wide_Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_Wide_String_Input; - Wide_Wide_String_Read (Strm, Item); + ----------------------------------- + -- Wide_Wide_String_Input_Blk_IO -- + ----------------------------------- - return Item; - end; - end; - end Wide_Wide_String_Input; + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Block_IO); + end Wide_Wide_String_Input_Blk_IO; ----------------------------- -- Wide_Wide_String_Output -- @@ -546,19 +623,20 @@ package body System.Strings.Stream_Ops is Item : Wide_Wide_String) is begin - if Strm = null then - raise Constraint_Error; - end if; - - -- Write the bounds of the string - - Positive'Write (Strm, Item'First); - Positive'Write (Strm, Item'Last); + Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_Wide_String_Output; - -- Write the character content of the string + ------------------------------------ + -- Wide_Wide_String_Output_Blk_IO -- + ------------------------------------ - Wide_Wide_String_Write (Strm, Item); - end Wide_Wide_String_Output; + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_Wide_String_Output_Blk_IO; --------------------------- -- Wide_Wide_String_Read -- @@ -569,9 +647,21 @@ package body System.Strings.Stream_Ops is Item : out Wide_Wide_String) is begin - Wide_Wide_String_Ops.Read (Strm, Item); + Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO); end Wide_Wide_String_Read; + ---------------------------------- + -- Wide_Wide_String_Read_Blk_IO -- + ---------------------------------- + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_Wide_String_Read_Blk_IO; + ---------------------------- -- Wide_Wide_String_Write -- ---------------------------- @@ -581,7 +671,19 @@ package body System.Strings.Stream_Ops is Item : Wide_Wide_String) is begin - Wide_Wide_String_Ops.Write (Strm, Item); + Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO); end Wide_Wide_String_Write; + ----------------------------------- + -- Wide_Wide_String_Write_Blk_IO -- + ----------------------------------- + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_Wide_String_Write_Blk_IO; + end System.Strings.Stream_Ops; diff --git a/gcc/ada/s-ststop.ads b/gcc/ada/s-ststop.ads index f954bccfc7b..432b1335d50 100644 --- a/gcc/ada/s-ststop.ads +++ b/gcc/ada/s-ststop.ads @@ -45,6 +45,8 @@ -- will be expanded into: -- -- String_Output (Some_Stream, Some_String); +-- or +-- String_Output_Blk_IO (Some_Stream, Some_String); pragma Warnings (Off); pragma Compiler_Unit; @@ -62,18 +64,34 @@ package System.Strings.Stream_Ops is (Strm : access Ada.Streams.Root_Stream_Type'Class) return String; + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + procedure String_Output (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : String); + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + procedure String_Read (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : out String); + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + procedure String_Write (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : String); + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + ----------------------------------- -- Wide_String stream operations -- ----------------------------------- @@ -82,18 +100,34 @@ package System.Strings.Stream_Ops is (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String; + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + procedure Wide_String_Output (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : Wide_String); + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + procedure Wide_String_Read (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : out Wide_String); + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + procedure Wide_String_Write (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : Wide_String); + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + ---------------------------------------- -- Wide_Wide_String stream operations -- ---------------------------------------- @@ -102,16 +136,32 @@ package System.Strings.Stream_Ops is (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String; + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + procedure Wide_Wide_String_Output (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : Wide_Wide_String); + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + procedure Wide_Wide_String_Read (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : out Wide_Wide_String); + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + procedure Wide_Wide_String_Write (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : Wide_Wide_String); + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + end System.Strings.Stream_Ops; diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 83cc368dee4..e344f74433b 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -338,8 +338,7 @@ package Scans is -- Flag array used to test for reserved word procedure Initialize_Ada_Keywords; - -- Set up Token_Type values in Names table entries for Ada reserved - -- words. + -- Set up Token_Type values in Names table entries for Ada reserved words -------------------------- -- Scan State Variables -- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 76f63f9353b..914c101afdc 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -350,6 +350,7 @@ package body Scng is procedure Error_Illegal_Wide_Character is begin + Scan_Ptr := Scan_Ptr + 1; Error_Msg ("illegal wide character", Wptr); end Error_Illegal_Wide_Character; @@ -1651,7 +1652,7 @@ package body Scng is if Err then Error_Illegal_Wide_Character; - Code := Character'Pos (' '); + Code := Character'Pos (' '); -- In Ada 95 mode we allow any wide character in a character -- literal, but in Ada 2005, the set of characters allowed diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 4b599151f8e..30684916644 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -315,6 +315,9 @@ package body Sem_Attr is -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_PolyORB_Attribute; + -- Validity checking for PolyORB/DSA attribute + procedure Check_Task_Prefix; -- Verify that prefix of attribute N is a task or task type @@ -1380,6 +1383,23 @@ package body Sem_Attr is end if; end Check_Object_Reference; + ---------------------------- + -- Check_PolyORB_Attribute -- + ---------------------------- + + procedure Check_PolyORB_Attribute is + begin + Validate_Non_Static_Attribute_Function_Call; + + Check_Type; + Check_Not_CPP_Type; + + if Get_PCS_Name /= Name_PolyORB_DSA then + Error_Attr + ("attribute% requires the 'Poly'O'R'B 'P'C'S", N); + end if; + end Check_PolyORB_Attribute; + ------------------------ -- Check_Program_Unit -- ------------------------ @@ -2976,6 +2996,15 @@ package body Sem_Attr is Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); + -------------- + -- From_Any -- + -------------- + + when Attribute_From_Any => + Check_E1; + Check_PolyORB_Attribute; + Set_Etype (N, P_Base_Type); + ----------------------- -- Has_Access_Values -- ----------------------- @@ -4238,6 +4267,15 @@ package body Sem_Attr is Analyze_And_Resolve (E1, Any_Integer); Set_Etype (N, RTE (RE_Address)); + ------------ + -- To_Any -- + ------------ + + when Attribute_To_Any => + Check_E1; + Check_PolyORB_Attribute; + Set_Etype (N, RTE (RE_Any)); + ---------------- -- Truncation -- ---------------- @@ -4257,6 +4295,15 @@ package body Sem_Attr is Check_Not_Incomplete_Type; Set_Etype (N, RTE (RE_Type_Class)); + ------------ + -- To_Any -- + ------------ + + when Attribute_TypeCode => + Check_E0; + Check_PolyORB_Attribute; + Set_Etype (N, RTE (RE_TypeCode)); + ----------------- -- UET_Address -- ----------------- @@ -7253,6 +7300,13 @@ package body Sem_Attr is end if; end Width; + -- The following attributes denote function that cannot be folded + + when Attribute_From_Any | + Attribute_To_Any | + Attribute_TypeCode => + null; + -- The following attributes can never be folded, and furthermore we -- should not even have entered the case statement for any of these. -- Note that in some cases, the values have already been folded as diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 626bee47c1a..f81cca8ea12 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2663,7 +2663,7 @@ package body Sem_Ch10 is -- Build name to be used in implicit with_clause. In most cases this -- is the source name, but if renamings are present we must make the -- original unit visible, not the one it renames. The entity in the - -- use clause is the renamed unit, but the identifier is the one from + -- with clause is the renamed unit, but the identifier is the one from -- the source, which allows us to recover the unit renaming. --------------------- @@ -2708,7 +2708,6 @@ package body Sem_Ch10 is Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) = N_Package_Renaming_Declaration then - -- The name in the with_clause is of the form A.B.C, and B -- is given by a renaming declaration. In that case we may -- not have analyzed the unit for B, but replaced it directly diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index b2e7d852487..a4abddf2b2a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3753,6 +3753,38 @@ package body Sem_Ch12 is Analyze_Subprogram_Instantiation (N, E_Procedure); end Analyze_Procedure_Instantiation; + ----------------------------------- + -- Need_Subprogram_Instance_Body -- + ----------------------------------- + + function Need_Subprogram_Instance_Body + (N : Node_Id; + Subp : Entity_Id) return Boolean + is + begin + if (Is_In_Main_Unit (N) + or else Is_Inlined (Subp) + or else Is_Inlined (Alias (Subp))) + and then (Operating_Mode = Generate_Code + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode)) + and then (Expander_Active or else ASIS_Mode) + and then not ABE_Is_Certain (N) + and then not Is_Eliminated (Subp) + then + Pending_Instantiations.Append + ((Inst_Node => N, + Act_Decl => Unit_Declaration_Node (Subp), + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + return True; + else + return False; + end if; + end Need_Subprogram_Instance_Body; + -------------------------------------- -- Analyze_Subprogram_Instantiation -- -------------------------------------- @@ -4144,22 +4176,7 @@ package body Sem_Ch12 is -- If the context requires a full instantiation, mark node for -- subsequent construction of the body. - if (Is_In_Main_Unit (N) - or else Is_Inlined (Act_Decl_Id)) - and then (Operating_Mode = Generate_Code - or else (Operating_Mode = Check_Semantics - and then ASIS_Mode)) - and then (Expander_Active or else ASIS_Mode) - and then not ABE_Is_Certain (N) - and then not Is_Eliminated (Act_Decl_Id) - then - Pending_Instantiations.Append - ((Inst_Node => N, - Act_Decl => Act_Decl, - Expander_Status => Expander_Active, - Current_Sem_Unit => Current_Sem_Unit, - Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then Check_Forward_Instantiation (Gen_Decl); @@ -8699,6 +8716,14 @@ package body Sem_Ch12 is begin Gen_Body_Id := Corresponding_Body (Gen_Decl); + -- Subprogram body may have been created already because of an inline + -- pragma, or because of multiple elaborations of the enclosing package + -- when several instances of the subprogram appear in the main unit. + + if Present (Corresponding_Body (Act_Decl)) then + return; + end if; + Expander_Mode_Save_And_Set (Body_Info.Expander_Status); -- Re-establish the state of information on which checks are suppressed. @@ -10853,11 +10878,11 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (P, False); -- If the current scope is itself an instantiation of a generic - -- nested within P, and we are in the private part of body of - -- this instantiation, restore the full views of P, that were - -- removed in End_Package_Scope above. This obscure case can - -- occur when a subunit of a generic contains an instance of - -- of a child unit of its generic parent unit. + -- nested within P, and we are in the private part of body of this + -- instantiation, restore the full views of P, that were removed + -- in End_Package_Scope above. This obscure case can occur when a + -- subunit of a generic contains an instance of a child unit of + -- its generic parent unit. elsif S = Current_Scope and then Is_Generic_Instance (S) diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index 7ebb2e88342..c3b34173e18 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -106,6 +106,16 @@ package Sem_Ch12 is -- function and procedure instances. The flag Body_Optional has the -- same purpose as described for Instantiate_Package_Body. + function Need_Subprogram_Instance_Body + (N : Node_Id; + Subp : Entity_Id) return Boolean; + + -- If a subprogram instance is inlined, indicate that the body of it + -- must be created, to be used in inlined calls by the back-end. The + -- subprogram may be inlined because the generic itself carries the + -- pragma, or because a pragma appears for the instance in the scope. + -- of the instance. + procedure Save_Global_References (N : Node_Id); -- Traverse the original generic unit, and capture all references to -- entities that are defined outside of the generic in the analyzed diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f67d34d60f8..307b6a158b6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -935,13 +935,25 @@ package body Sem_Ch3 is Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); -- Similarly, if the access definition is the return result of a - -- protected function, create an itype reference for it because it - -- will be used within the function body. + -- function, create an itype reference for it because it + -- will be used within the function body. For a regular function that + -- is not a compilation unit, insert reference after the declaration. + -- For a protected operation, insert it after the enclosing protected + -- type declaration. In either case, do not create a reference for a + -- type obtained through a limited_with clause, because this would + -- introduce semantic dependencies. elsif Nkind (Related_Nod) = N_Function_Specification - and then Ekind (Current_Scope) = E_Protected_Type + and then not From_With_Type (Anon_Type) then - Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); + if Ekind (Current_Scope) = E_Protected_Type then + Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); + + elsif Is_List_Member (Parent (Related_Nod)) + and then Nkind (Parent (N)) /= N_Parameter_Specification + then + Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); + end if; -- Finally, create an itype reference for an object declaration of -- an anonymous access type. This is strictly necessary only for @@ -1042,7 +1054,9 @@ package body Sem_Ch3 is or else Nkind_In (D_Ityp, N_Object_Declaration, N_Object_Renaming_Declaration, + N_Formal_Object_Declaration, N_Formal_Type_Declaration, + N_Formal_Object_Declaration, N_Task_Type_Declaration, N_Protected_Type_Declaration)) loop @@ -1104,13 +1118,32 @@ package body Sem_Ch3 is if Present (Formals) then Push_Scope (Desig_Type); + + -- A bit of a kludge here. These kludges will be removed when Itypes + -- have proper parent pointers to their declarations??? + + -- Kludge 1) Link definining_identifier of formals. Required by + -- First_Formal to provide its functionality. + + declare + F : Node_Id; + + begin + F := First (Formals); + while Present (F) loop + if No (Parent (Defining_Identifier (F))) then + Set_Parent (Defining_Identifier (F), F); + end if; + + Next (F); + end loop; + end; + Process_Formals (Formals, Parent (T_Def)); - -- A bit of a kludge here, End_Scope requires that the parent - -- pointer be set to something reasonable, but Itypes don't have - -- parent pointers. So we set it and then unset it ??? If and when - -- Itypes have proper parent pointers to their declarations, this - -- kludge can be removed. + -- Kludge 2) End_Scope requires that the parent pointer be set to + -- something reasonable, but Itypes don't have parent pointers. So + -- we set it and then unset it ??? Set_Parent (Desig_Type, T_Name); End_Scope; @@ -4428,6 +4461,10 @@ package body Sem_Ch3 is Comp := Object_Definition (N); Acc := Comp; + when N_Function_Specification => + Comp := Result_Definition (N); + Acc := Comp; + when others => raise Program_Error; end case; @@ -4472,6 +4509,10 @@ package body Sem_Ch3 is elsif Nkind (N) = N_Access_Function_Definition then Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + elsif Nkind (N) = N_Function_Specification then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + Set_Etype (Defining_Unit_Name (N), Anon); + else Rewrite (Comp, Make_Component_Definition (Loc, diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d6983b1e648..cd3bb500099 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -498,11 +498,24 @@ package body Sem_Ch4 is Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); - -- Ada 2005 (AI-231) + -- Ada 2005 (AI-231) If the designated type is itself an access + -- type that excludes null, it's default initializastion will + -- be a null object, and we can insert an unconditional raise + -- before the allocator. if Can_Never_Be_Null (Type_Id) then - Error_Msg_N ("(Ada 2005) qualified expression required", - Expression (N)); + declare + Not_Null_Check : constant Node_Id := + Make_Raise_Constraint_Error (Sloc (E), + Reason => CE_Null_Not_Allowed); + begin + if Expander_Active then + Insert_Action (N, Not_Null_Check); + Analyze (Not_Null_Check); + else + Error_Msg_N ("null value not allowed here?", E); + end if; + end; end if; -- Check restriction against dynamically allocated protected @@ -684,12 +697,16 @@ package body Sem_Ch4 is procedure Analyze_Call (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); - Nam : Node_Id := Name (N); + Nam : Node_Id; X : Interp_Index; It : Interp; Nam_Ent : Entity_Id; Success : Boolean := False; + Deref : Boolean := False; + -- Flag indicates whether an interpretation of the prefix is a + -- parameterless call that returns an access_to_subprogram. + function Name_Denotes_Function return Boolean; -- If the type of the name is an access to subprogram, this may be the -- type of a name, or the return type of the function being called. If @@ -762,6 +779,8 @@ package body Sem_Ch4 is Set_Etype (N, Any_Type); + Nam := Name (N); + if not Is_Overloaded (Nam) then -- Only one interpretation to check @@ -874,6 +893,7 @@ package body Sem_Ch4 is while Present (It.Nam) loop Nam_Ent := It.Nam; + Deref := False; -- Name may be call that returns an access to subprogram, or more -- generally an overloaded expression one of whose interpretations @@ -888,11 +908,17 @@ package body Sem_Ch4 is Nam_Ent := Designated_Type (Nam_Ent); elsif Is_Access_Type (Etype (Nam_Ent)) - and then not Is_Entity_Name (Nam) + and then + (not Is_Entity_Name (Nam) + or else Nkind (N) = N_Procedure_Call_Statement) and then Ekind (Designated_Type (Etype (Nam_Ent))) = E_Subprogram_Type then Nam_Ent := Designated_Type (Etype (Nam_Ent)); + + if Is_Entity_Name (Nam) then + Deref := True; + end if; end if; Analyze_One_Call (N, Nam_Ent, False, Success); @@ -904,7 +930,16 @@ package body Sem_Ch4 is -- guation is done directly in Resolve. if Success then - Set_Etype (Nam, It.Typ); + if Deref + and then Nkind (Parent (N)) /= N_Explicit_Dereference + then + Set_Entity (Nam, It.Nam); + Insert_Explicit_Dereference (Nam); + Set_Etype (Nam, Nam_Ent); + + else + Set_Etype (Nam, It.Typ); + end if; elsif Nkind_In (Name (N), N_Selected_Component, N_Function_Call) @@ -1480,14 +1515,15 @@ package body Sem_Ch4 is and then Is_Overloaded (N) then -- The prefix may include access to subprograms and other access - -- types. If the context selects the interpretation that is a call, - -- we cannot rewrite the node yet, but we include the result of - -- the call interpretation. + -- types. If the context selects the interpretation that is a + -- function call (not a procedure call) we cannot rewrite the node + -- yet, but we include the result of the call interpretation. Get_First_Interp (N, I, It); while Present (It.Nam) loop if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement then Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ)); end if; @@ -2104,11 +2140,12 @@ package body Sem_Ch4 is -- is already known to be compatible, and because this may be an -- indexing of a call with default parameters. - Formal : Entity_Id; - Actual : Node_Id; - Is_Indexed : Boolean := False; - Subp_Type : constant Entity_Id := Etype (Nam); - Norm_OK : Boolean; + Formal : Entity_Id; + Actual : Node_Id; + Is_Indexed : Boolean := False; + Is_Indirect : Boolean := False; + Subp_Type : constant Entity_Id := Etype (Nam); + Norm_OK : Boolean; function Operator_Hidden_By (Fun : Entity_Id) return Boolean; -- There may be a user-defined operator that hides the current @@ -2217,6 +2254,13 @@ package body Sem_Ch4 is -- in prefix notation, so that the rebuilt parameter list has more than -- one actual. + if not Is_Overloadable (Nam) + and then Ekind (Nam) /= E_Subprogram_Type + and then Ekind (Nam) /= E_Entry_Family + then + return; + end if; + if Present (Actuals) and then (Needs_No_Actuals (Nam) @@ -2236,11 +2280,13 @@ package body Sem_Ch4 is -- The prefix can also be a parameterless function that returns an -- access to subprogram, in which case this is an indirect call. + -- If this succeeds, an explicit dereference is added later on, + -- in Analyze_Call or Resolve_Call. elsif Is_Access_Type (Subp_Type) and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type then - Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type); + Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type); end if; end if; @@ -2255,13 +2301,21 @@ package body Sem_Ch4 is return; end if; - Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK); + Normalize_Actuals + (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK); if not Norm_OK then + -- If an indirect call is a possible interpretation, indicate + -- success to the caller. + + if Is_Indirect then + Success := True; + return; + -- Mismatch in number or names of parameters - if Debug_Flag_E then + elsif Debug_Flag_E then Write_Str (" normalization fails in call "); Write_Int (Int (N)); Write_Str (" with subprogram "); @@ -2387,7 +2441,7 @@ package body Sem_Ch4 is Write_Eol; end if; - if Report and not Is_Indexed then + if Report and not Is_Indexed and not Is_Indirect then -- Ada 2005 (AI-251): Complete the error notification -- to help new Ada 2005 users diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 11439419a25..139675969a9 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -579,18 +579,15 @@ package body Sem_Ch5 is end if; end if; - -- Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous - -- access type, apply an implicit conversion of the rhs to that type - -- to force appropriate static and run-time accessibility checks. - -- This applies as well to anonymous access-to-subprogram types that + -- Ada 2005 (AI-385): When the lhs type is an anonymous access type, + -- apply an implicit conversion of the rhs to that type to force + -- appropriate static and run-time accessibility checks. This + -- applies as well to anonymous access-to-subprogram types that -- are component subtypes. if Ada_Version >= Ada_05 - and then - Is_Access_Type (T1) - and then - (Is_Local_Anonymous_Access (T1) - or else Can_Never_Be_Null (T1)) + and then Is_Access_Type (T1) + and then Is_Local_Anonymous_Access (T1) then Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); Analyze_And_Resolve (Rhs, T1); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 6583b72537d..ea1a21ed178 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -542,16 +542,33 @@ package body Sem_Ch6 is -- "return access T" case; check that the return statement also has -- "access T", and that the subtypes statically match: + -- if this is an access to subprogram the signatures must match. if R_Type_Is_Anon_Access then if R_Stm_Type_Is_Anon_Access then - if Base_Type (Designated_Type (R_Stm_Type)) /= - Base_Type (Designated_Type (R_Type)) - or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) + if + Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type then - Error_Msg_N - ("subtype must statically match function result subtype", - Subtype_Mark (Subtype_Ind)); + if Base_Type (Designated_Type (R_Stm_Type)) /= + Base_Type (Designated_Type (R_Type)) + or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Mark (Subtype_Ind)); + end if; + + else + -- For two anonymous access to subprogram types, the + -- types themselves must be type conformant. + + if not Conforming_Types + (R_Stm_Type, R_Type, Fully_Conformant) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Ind); + end if; end if; else @@ -589,17 +606,22 @@ package body Sem_Ch6 is -- definition matches the class-wide type. This prevents rejection -- in the case where the object declaration is initialized by a call -- to a build-in-place function with a specific result type and the - -- object entity had its type changed to that specific type. (Note - -- that the ARG believes that return objects should be allowed to - -- have a type covered by a class-wide result type in any case, so - -- once that relaxation is made (see AI05-32), the above check for - -- type compatibility should be changed to test Covers rather than - -- equality, and then the following special test will no longer be - -- needed. ???) + -- object entity had its type changed to that specific type. This is + -- also allowed in the case where Obj_Decl does not come from source, + -- which can occur for an expansion of a simple return statement of + -- a build-in-place class-wide function when the result expression + -- has a specific type, because a return object with a specific type + -- is created. (Note that the ARG believes that return objects should + -- be allowed to have a type covered by a class-wide result type in + -- any case, so once that relaxation is made (see AI05-32), the above + -- check for type compatibility should be changed to test Covers + -- rather than equality, and the following special test will no + -- longer be needed. ???) elsif Is_Class_Wide_Type (R_Type) and then - R_Type = Etype (Object_Definition (Original_Node (Obj_Decl))) + (R_Type = Etype (Object_Definition (Original_Node (Obj_Decl))) + or else not Comes_From_Source (Obj_Decl)) then null; @@ -1240,7 +1262,20 @@ package body Sem_Ch6 is if Result_Definition (N) /= Error then if Nkind (Result_Definition (N)) = N_Access_Definition then - Typ := Access_Definition (N, Result_Definition (N)); + + -- Ada 2005 (AI-254): Handle anonymous access to subprograms + + declare + AD : constant Node_Id := + Access_To_Subprogram_Definition (Result_Definition (N)); + begin + if Present (AD) and then Protected_Present (AD) then + Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N); + else + Typ := Access_Definition (N, Result_Definition (N)); + end if; + end; + Set_Parent (Typ, Result_Definition (N)); Set_Is_Local_Anonymous_Access (Typ); Set_Etype (Designator, Typ); @@ -1564,6 +1599,7 @@ package body Sem_Ch6 is -- Subprogram_Specification. In such cases, we undo the change -- made by the analysis of the specification and try to find the -- spec again. + -- Note that wrappers already have their corresponding specs and -- bodies set during their creation, so if the candidate spec is -- a wrapper, then we definately need to swap all types to their @@ -2405,17 +2441,6 @@ package body Sem_Ch6 is and then No_Return (Ent) then Set_Trivial_Subprogram (Stm); - - -- If the procedure name is Raise_Exception, then also - -- assume that it raises an exception. The main target - -- here is Ada.Exceptions.Raise_Exception, but this name - -- is pretty evocative in any context! Note that the - -- procedure in Ada.Exceptions is not marked No_Return - -- because of the annoying case of the null exception Id - -- when operating in Ada 95 mode. - - elsif Chars (Ent) = Name_Raise_Exception then - Set_Trivial_Subprogram (Stm); end if; end; end if; @@ -7756,6 +7781,7 @@ package body Sem_Ch6 is -- procedure. Note that it is only at the outer level that we -- do this fiddling, for the spec cases, the already preanalyzed -- parameters are not affected. + -- For a postcondition pragma within a generic, preserve the pragma -- for later expansion. @@ -7784,6 +7810,12 @@ package body Sem_Ch6 is -- Start of processing for Process_PPCs begin + -- Nothing to do if we are not generating code + + if Operating_Mode /= Generate_Code then + return; + end if; + -- Grab preconditions from spec if Present (Spec_Id) then @@ -7891,7 +7923,7 @@ package body Sem_Ch6 is end loop; end if; - -- If we had any postconditions and expansion is enabled,, build + -- If we had any postconditions and expansion is enabled, build -- the Postconditions procedure. if Present (Plist) diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 177a39ca671..87a0d054451 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -69,7 +69,7 @@ package body Sem_Mech is ("mechanism for & has already been set", Mech_Name, Ent); end if; - -- MECHANISM_NAME ::= value | reference | descriptor + -- MECHANISM_NAME ::= value | reference | descriptor | short_descriptor if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then @@ -85,6 +85,11 @@ package body Sem_Mech is Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name); return; + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name); + return; + elsif Chars (Mech_Name) = Name_Copy then Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); @@ -95,7 +100,8 @@ package body Sem_Mech is return; end if; - -- MECHANISM_NAME ::= descriptor (CLASS_NAME) + -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | + -- short_descriptor (CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as an indexed component @@ -104,14 +110,16 @@ package body Sem_Mech is Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else Chars (Prefix (Mech_Name)) /= Name_Descriptor + or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else + Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) or else Present (Next (Class)) then Bad_Mechanism; return; end if; - -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) + -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | + -- short_descriptor (Class => CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as a function call @@ -121,7 +129,8 @@ package body Sem_Mech is Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier - or else Chars (Name (Mech_Name)) /= Name_Descriptor + or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else + Chars (Name (Mech_Name)) = Name_Short_Descriptor) or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class @@ -145,27 +154,76 @@ package body Sem_Mech is Bad_Class; return; - elsif Chars (Class) = Name_UBS then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_UBS + then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name); - elsif Chars (Class) = Name_UBSB then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_UBSB + then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name); - elsif Chars (Class) = Name_UBA then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_UBA + then Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name); - elsif Chars (Class) = Name_S then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_S + then Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name); - elsif Chars (Class) = Name_SB then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_SB + then Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name); - elsif Chars (Class) = Name_A then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_A + then Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name); - elsif Chars (Class) = Name_NCA then + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_NCA + then Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name); + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA, Mech_Name); + else Bad_Class; return; diff --git a/gcc/ada/sem_mech.ads b/gcc/ada/sem_mech.ads index 1673a671b0e..93f6080f1f4 100644 --- a/gcc/ada/sem_mech.ads +++ b/gcc/ada/sem_mech.ads @@ -95,6 +95,14 @@ package Sem_Mech is By_Descriptor_SB : constant Mechanism_Type := -8; By_Descriptor_A : constant Mechanism_Type := -9; By_Descriptor_NCA : constant Mechanism_Type := -10; + By_Short_Descriptor : constant Mechanism_Type := -11; + By_Short_Descriptor_UBS : constant Mechanism_Type := -12; + By_Short_Descriptor_UBSB : constant Mechanism_Type := -13; + By_Short_Descriptor_UBA : constant Mechanism_Type := -14; + By_Short_Descriptor_S : constant Mechanism_Type := -15; + By_Short_Descriptor_SB : constant Mechanism_Type := -16; + By_Short_Descriptor_A : constant Mechanism_Type := -17; + By_Short_Descriptor_NCA : constant Mechanism_Type := -18; -- These values are used only in OpenVMS ports of GNAT. Pass by descriptor -- is forced, as described in the OpenVMS ABI. The suffix indicates the -- descriptor type: @@ -113,7 +121,7 @@ package Sem_Mech is -- type based on the Ada type in accordance with the OpenVMS ABI. subtype Descriptor_Codes is Mechanism_Type - range By_Descriptor_NCA .. By_Descriptor; + range By_Short_Descriptor_NCA .. By_Descriptor; -- Subtype including all descriptor mechanisms -- All the above special values are non-positive. Positive values for diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8d162e6b37b..3ad8ff5d21b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -53,6 +53,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; @@ -1424,7 +1425,18 @@ package body Sem_Prag is P := N; while Present (Prev (P)) loop P := Prev (P); - PO := Original_Node (P); + + -- If the previous node is a generic subprogram, do not go to + -- to the original node, which is the unanalyzed tree: we need + -- to attach the pre/postconditions to the analyzed version + -- at this point. They get propagated to the original tree when + -- analyzing the corresponding body. + + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; -- Skip past prior pragma @@ -1450,6 +1462,15 @@ package body Sem_Prag is if Nkind (Parent (N)) = N_Subprogram_Body and then List_Containing (N) = Declarations (Parent (N)) then + if Operating_Mode /= Generate_Code then + + -- Analyze expression in pragma, for correctness + -- and for ASIS use. + + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); + end if; + In_Body := True; return; @@ -2221,7 +2242,6 @@ package body Sem_Prag is Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); begin - GNAT_Pragma; Check_Arg_Count (2); Check_No_Identifiers; Check_Arg_Is_Static_Expression (Arg2, Standard_String); @@ -2638,8 +2658,6 @@ package body Sem_Prag is Code_Val : Uint; begin - GNAT_Pragma; - if not OpenVMS_On_Target then Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)"); @@ -2697,8 +2715,6 @@ package body Sem_Prag is (Arg_Internal : Node_Id := Empty) is begin - GNAT_Pragma; - if No (Arg_Internal) then Error_Pragma ("Internal parameter required for pragma%"); end if; @@ -3315,7 +3331,6 @@ package body Sem_Prag is Exp : Node_Id; begin - GNAT_Pragma; Check_No_Identifiers; Check_At_Least_N_Arguments (1); @@ -3752,6 +3767,22 @@ package body Sem_Prag is and then Present (Corresponding_Body (Decl)) then Set_Inline_Flags (Corresponding_Body (Decl)); + + elsif Is_Generic_Instance (Subp) then + + -- Indicate that the body needs to be created for + -- inlining subsequent calls. The instantiation + -- node follows the declaration of the wrapper + -- package created for it. + + if Scope (Subp) /= Standard_Standard + and then + Need_Subprogram_Instance_Body + (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), + Subp) + then + null; + end if; end if; end if; @@ -3870,17 +3901,23 @@ package body Sem_Prag is Link_Nam : Node_Id; String_Val : String_Id; - procedure Check_Form_Of_Interface_Name (SN : Node_Id); + procedure Check_Form_Of_Interface_Name + (SN : Node_Id; + Ext_Name_Case : Boolean); -- SN is a string literal node for an interface name. This routine -- performs some minimal checks that the name is reasonable. In -- particular that no spaces or other obviously incorrect characters -- appear. This is only a warning, since any characters are allowed. + -- Ext_Name_Case is True for an External_Name, False for a Link_Name. ---------------------------------- -- Check_Form_Of_Interface_Name -- ---------------------------------- - procedure Check_Form_Of_Interface_Name (SN : Node_Id) is + procedure Check_Form_Of_Interface_Name + (SN : Node_Id; + Ext_Name_Case : Boolean) + is S : constant String_Id := Strval (Expr_Value_S (SN)); SL : constant Nat := String_Length (S); C : Char_Code; @@ -3893,15 +3930,28 @@ package body Sem_Prag is for J in 1 .. SL loop C := Get_String_Char (S, J); - if Warn_On_Export_Import - and then - (not In_Character_Range (C) - or else (Get_Character (C) = ' ' - and then VM_Target /= CLI_Target) - or else Get_Character (C) = ',') + -- Look for dubious character and issue unconditional warning. + -- Definitely dubious if not in character range. + + if not In_Character_Range (C) + + -- For all cases except external names on CLI target, + -- commas, spaces and slashes are dubious (in CLI, we use + -- spaces and commas in external names to specify assembly + -- version and public key). + + or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) + and then (Get_Character (C) = ' ' + or else + Get_Character (C) = ',' + or else + Get_Character (C) = '/' + or else + Get_Character (C) = '\')) then - Error_Msg_N - ("?interface name contains illegal character", SN); + Error_Msg + ("?interface name contains illegal character", + Sloc (SN) + Source_Ptr (J)); end if; end loop; end Check_Form_Of_Interface_Name; @@ -3946,13 +3996,13 @@ package body Sem_Prag is if Present (Ext_Nam) then Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); - Check_Form_Of_Interface_Name (Ext_Nam); + Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); - -- Verify that the external name is not the name of a local - -- entity, which would hide the imported one and lead to - -- run-time surprises. The problem can only arise for entities - -- declared in a package body (otherwise the external name is - -- fully qualified and won't conflict). + -- Verify that external name is not the name of a local entity, + -- which would hide the imported one and could lead to run-time + -- surprises. The problem can only arise for entities declared in + -- a package body (otherwise the external name is fully qualified + -- and will not conflict). declare Nam : Name_Id; @@ -3975,10 +4025,10 @@ package body Sem_Prag is Par := Parent (E); while Present (Par) loop if Nkind (Par) = N_Package_Body then - Error_Msg_Sloc := Sloc (E); + Error_Msg_Sloc := Sloc (E); Error_Msg_NE ("imported entity is hidden by & declared#", - Ext_Arg, E); + Ext_Arg, E); exit; end if; @@ -3991,7 +4041,7 @@ package body Sem_Prag is if Present (Link_Nam) then Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); - Check_Form_Of_Interface_Name (Link_Nam); + Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); end if; -- If there is no link name, just set the external name @@ -4622,6 +4672,7 @@ package body Sem_Prag is procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is Class : Node_Id; Param : Node_Id; + Mech_Name_Id : Name_Id; procedure Bad_Class; -- Signal bad descriptor class name @@ -4655,7 +4706,8 @@ package body Sem_Prag is ("mechanism for & has already been set", Mech_Name, Ent); end if; - -- MECHANISM_NAME ::= value | reference | descriptor + -- MECHANISM_NAME ::= value | reference | descriptor | + -- short_descriptor if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then @@ -4671,6 +4723,11 @@ package body Sem_Prag is Set_Mechanism (Ent, By_Descriptor); return; + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism (Ent, By_Short_Descriptor); + return; + elsif Chars (Mech_Name) = Name_Copy then Error_Pragma_Arg ("bad mechanism name, Value assumed", Mech_Name); @@ -4679,22 +4736,28 @@ package body Sem_Prag is Bad_Mechanism; end if; - -- MECHANISM_NAME ::= descriptor (CLASS_NAME) + -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | + -- short_descriptor (CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as an indexed component elsif Nkind (Mech_Name) = N_Indexed_Component then + Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else Chars (Prefix (Mech_Name)) /= Name_Descriptor - or else Present (Next (Class)) + or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else + Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) + or else Present (Next (Class)) then Bad_Mechanism; + else + Mech_Name_Id := Chars (Prefix (Mech_Name)); end if; - -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) + -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | + -- short_descriptor (Class => CLASS_NAME) -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca -- Note: this form is parsed as a function call @@ -4704,7 +4767,8 @@ package body Sem_Prag is Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier - or else Chars (Name (Mech_Name)) /= Name_Descriptor + or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else + Chars (Name (Mech_Name)) = Name_Short_Descriptor) or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class @@ -4712,6 +4776,7 @@ package body Sem_Prag is Bad_Mechanism; else Class := Explicit_Actual_Parameter (Param); + Mech_Name_Id := Chars (Name (Mech_Name)); end if; else @@ -4725,27 +4790,76 @@ package body Sem_Prag is if Nkind (Class) /= N_Identifier then Bad_Class; - elsif Chars (Class) = Name_UBS then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBS + then Set_Mechanism (Ent, By_Descriptor_UBS); - elsif Chars (Class) = Name_UBSB then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBSB + then Set_Mechanism (Ent, By_Descriptor_UBSB); - elsif Chars (Class) = Name_UBA then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBA + then Set_Mechanism (Ent, By_Descriptor_UBA); - elsif Chars (Class) = Name_S then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_S + then Set_Mechanism (Ent, By_Descriptor_S); - elsif Chars (Class) = Name_SB then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_SB + then Set_Mechanism (Ent, By_Descriptor_SB); - elsif Chars (Class) = Name_A then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_A + then Set_Mechanism (Ent, By_Descriptor_A); - elsif Chars (Class) = Name_NCA then + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_NCA + then Set_Mechanism (Ent, By_Descriptor_NCA); + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism (Ent, By_Short_Descriptor_UBS); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism (Ent, By_Short_Descriptor_UBSB); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism (Ent, By_Short_Descriptor_UBA); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism (Ent, By_Short_Descriptor_S); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism (Ent, By_Short_Descriptor_SB); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism (Ent, By_Short_Descriptor_A); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism (Ent, By_Short_Descriptor_NCA); + else Bad_Class; end if; @@ -5540,18 +5654,6 @@ package body Sem_Prag is end if; end C_Pass_By_Copy; - ----------------------- - -- Canonical_Streams -- - ----------------------- - - -- pragma Canonical_Streams; - - when Pragma_Canonical_Streams => - GNAT_Pragma; - Check_Arg_Count (0); - Check_Valid_Configuration_Pragma; - Canonical_Streams := True; - ----------- -- Check -- ----------- @@ -5715,11 +5817,11 @@ package body Sem_Prag is -- pragma Comment (static_string_EXPRESSION) - -- Processing for pragma Comment shares the circuitry for - -- pragma Ident. The only differences are that Ident enforces - -- a limit of 31 characters on its argument, and also enforces - -- limitations on placement for DEC compatibility. Pragma - -- Comment shares neither of these restrictions. + -- Processing for pragma Comment shares the circuitry for pragma + -- Ident. The only differences are that Ident enforces a limit of 31 + -- characters on its argument, and also enforces limitations on + -- placement for DEC compatibility. Pragma Comment shares neither of + -- these restrictions. ------------------- -- Common_Object -- @@ -5740,6 +5842,7 @@ package body Sem_Prag is -- (boolean_EXPRESSION, static_string_EXPRESSION); when Pragma_Compile_Time_Error => + GNAT_Pragma; Process_Compile_Time_Warning_Or_Error; -------------------------- @@ -5750,6 +5853,7 @@ package body Sem_Prag is -- (boolean_EXPRESSION, static_string_EXPRESSION); when Pragma_Compile_Time_Warning => + GNAT_Pragma; Process_Compile_Time_Warning_Or_Error; ------------------- @@ -6124,6 +6228,8 @@ package body Sem_Prag is when Pragma_CPP_Virtual => CPP_Virtual : declare begin + GNAT_Pragma; + if Warn_On_Obsolescent_Feature then Error_Msg_N ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " & @@ -6137,6 +6243,8 @@ package body Sem_Prag is when Pragma_CPP_Vtable => CPP_Vtable : declare begin + GNAT_Pragma; + if Warn_On_Obsolescent_Feature then Error_Msg_N ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " & @@ -6656,6 +6764,8 @@ package body Sem_Prag is Code : Node_Id renames Args (4); begin + GNAT_Pragma; + if Inside_A_Generic then Error_Pragma ("pragma% cannot be used for generic entities"); end if; @@ -7125,6 +7235,7 @@ package body Sem_Prag is Typ : Entity_Id; begin + GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); @@ -7458,6 +7569,7 @@ package body Sem_Prag is Code : Node_Id renames Args (4); begin + GNAT_Pragma; Gather_Associations (Names, Args); if Present (External) and then Present (Code) then @@ -7743,6 +7855,7 @@ package body Sem_Prag is -- pragma Inline_Always ( NAME {, NAME} ); when Pragma_Inline_Always => + GNAT_Pragma; Process_Inline (True); -------------------- @@ -7752,6 +7865,7 @@ package body Sem_Prag is -- pragma Inline_Generic (NAME {, NAME}); when Pragma_Inline_Generic => + GNAT_Pragma; Process_Generic_List; ---------------------- @@ -8782,6 +8896,7 @@ package body Sem_Prag is -- it was misplaced. when Pragma_No_Body => + GNAT_Pragma; Pragma_Misplaced; --------------- @@ -8848,13 +8963,43 @@ package body Sem_Prag is end loop; end No_Return; + ----------------- + -- No_Run_Time -- + ----------------- + + -- pragma No_Run_Time; + + -- Note: this pragma is retained for backwards compatibility. + -- See body of Rtsfind for full details on its handling. + + when Pragma_No_Run_Time => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + + No_Run_Time_Mode := True; + Configurable_Run_Time_Mode := True; + + -- Set Duration to 32 bits if word size is 32 + + if Ttypes.System_Word_Size = 32 then + Duration_32_Bits_On_Target := True; + end if; + + -- Set appropriate restrictions + + Set_Restriction (No_Finalization, N); + Set_Restriction (No_Exception_Handlers, N); + Set_Restriction (Max_Tasks, N, 0); + Set_Restriction (No_Tasking, N); + ------------------------ -- No_Strict_Aliasing -- ------------------------ -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; - when Pragma_No_Strict_Aliasing => No_Strict_Alias : declare + when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare E_Id : Entity_Id; begin @@ -8878,7 +9023,20 @@ package body Sem_Prag is Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); end if; - end No_Strict_Alias; + end No_Strict_Aliasing; + + ----------------------- + -- Normalize_Scalars -- + ----------------------- + + -- pragma Normalize_Scalars; + + when Pragma_Normalize_Scalars => + Check_Ada_83_Warning; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Normalize_Scalars := True; + Init_Or_Norm_Scalars := True; ----------------- -- Obsolescent -- @@ -9086,49 +9244,6 @@ package body Sem_Prag is end if; end Obsolescent; - ----------------- - -- No_Run_Time -- - ----------------- - - -- pragma No_Run_Time - - -- Note: this pragma is retained for backwards compatibility. - -- See body of Rtsfind for full details on its handling. - - when Pragma_No_Run_Time => - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (0); - - No_Run_Time_Mode := True; - Configurable_Run_Time_Mode := True; - - -- Set Duration to 32 bits if word size is 32 - - if Ttypes.System_Word_Size = 32 then - Duration_32_Bits_On_Target := True; - end if; - - -- Set appropriate restrictions - - Set_Restriction (No_Finalization, N); - Set_Restriction (No_Exception_Handlers, N); - Set_Restriction (Max_Tasks, N, 0); - Set_Restriction (No_Tasking, N); - - ----------------------- - -- Normalize_Scalars -- - ----------------------- - - -- pragma Normalize_Scalars; - - when Pragma_Normalize_Scalars => - Check_Ada_83_Warning; - Check_Arg_Count (0); - Check_Valid_Configuration_Pragma; - Normalize_Scalars := True; - Init_Or_Norm_Scalars := True; - -------------- -- Optimize -- -------------- @@ -9365,19 +9480,6 @@ package body Sem_Prag is end if; end Preelab_Init; - ------------- - -- Polling -- - ------------- - - -- pragma Polling (ON | OFF); - - when Pragma_Polling => - GNAT_Pragma; - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); - Polling_Required := (Chars (Expression (Arg1)) = Name_On); - -------------------- -- Persistent_BSS -- -------------------- @@ -9436,6 +9538,19 @@ package body Sem_Prag is end if; end Persistent_BSS; + ------------- + -- Polling -- + ------------- + + -- pragma Polling (ON | OFF); + + when Pragma_Polling => + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + Polling_Required := (Chars (Expression (Arg1)) = Name_On); + ------------------- -- Postcondition -- ------------------- @@ -10952,6 +11067,7 @@ package body Sem_Prag is -- or the identifier GCC, no other identifiers are acceptable. when Pragma_System_Name => + GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); @@ -11200,7 +11316,7 @@ package body Sem_Prag is Variant : Node_Id; begin - GNAT_Pragma; + Ada_2005_Pragma; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); @@ -11567,7 +11683,7 @@ package body Sem_Prag is -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); when Pragma_Unsuppress => - GNAT_Pragma; + Ada_2005_Pragma; Process_Suppress_Unsuppress (False); ------------------- @@ -11891,6 +12007,7 @@ package body Sem_Prag is -- pragma Wide_Character_Encoding (IDENTIFIER); when Pragma_Wide_Character_Encoding => + GNAT_Pragma; -- Nothing to do, handled in parser. Note that we do not enforce -- configuration pragma placement, this pragma can appear at any @@ -12093,7 +12210,6 @@ package body Sem_Prag is Pragma_Atomic => 0, Pragma_Atomic_Components => 0, Pragma_Attach_Handler => -1, - Pragma_Canonical_Streams => -1, Pragma_Check => 99, Pragma_Check_Name => 0, Pragma_Check_Policy => 0, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e0118685ea0..4e0e0dedfcd 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -446,16 +446,18 @@ package body Sem_Res is return; end if; - -- Detect a common beginner error: + -- Detect a common error: -- type R (D : Positive := 100) is record -- Name : String (1 .. D); -- end record; - -- The default value causes an object of type R to be - -- allocated with room for Positive'Last characters. + -- The default value causes an object of type R to be allocated + -- with room for Positive'Last characters. The RM does not mandate + -- the allocation of the maximum size, but that is what GNAT does + -- so we should warn the programmer that there is a problem. - declare + Check_Large : declare SI : Node_Id; T : Entity_Id; TB : Node_Id; @@ -480,9 +482,11 @@ package body Sem_Res is and then Compile_Time_Known_Value (Type_High_Bound (T)) and then Minimum_Size (T, Biased => True) >= - Esize (Standard_Integer) - 1; + RM_Size (Standard_Positive); end Large_Storage_Type; + -- Start of processing for Check_Large + begin -- Check that the Disc has a large range @@ -553,7 +557,7 @@ package body Sem_Res is <<No_Danger>> null; - end; + end Check_Large; end if; -- Legal case is in index or discriminant constraint @@ -754,7 +758,22 @@ package body Sem_Res is C := N; loop P := Parent (C); + + -- If no parent, then we were not inside a subprogram, this can for + -- example happen when processing certain pragmas in a spec. Just + -- return False in this case. + + if No (P) then + return False; + end if; + + -- Done if we get to subprogram body, this is definitely an infinite + -- recursion case if we did not find anything to stop us. + exit when Nkind (P) = N_Subprogram_Body; + + -- If appearing in conditional, result is false + if Nkind_In (P, N_Or_Else, N_And_Then, N_If_Statement, @@ -4677,6 +4696,25 @@ package body Sem_Res is end loop; end if; + if Ekind (Etype (Nam)) = E_Access_Subprogram_Type + and then Ekind (Typ) /= E_Access_Subprogram_Type + and then Nkind (Subp) /= N_Explicit_Dereference + and then Present (Parameter_Associations (N)) + then + -- The prefix is a parameterless function call that returns an + -- access to subprogram. If parameters are present in the current + -- call add an explicit dereference. + + -- The dereference is added either in Analyze_Call or here. Should + -- be consolidated ??? + + Set_Is_Overloaded (Subp, False); + Set_Etype (Subp, Etype (Nam)); + Insert_Explicit_Dereference (Subp); + Nam := Designated_Type (Etype (Nam)); + Resolve (Subp, Nam); + end if; + -- Check that a call to Current_Task does not occur in an entry body if Is_RTE (Nam, RE_Current_Task) then @@ -6538,8 +6576,8 @@ package body Sem_Res is procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is pragma Warnings (Off, Typ); - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); T : Entity_Id; begin @@ -6604,6 +6642,8 @@ package body Sem_Res is ------------------ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + begin -- Handle restriction against anonymous null access values This -- restriction can be turned off using -gnatdj. @@ -6632,6 +6672,26 @@ package body Sem_Res is end if; end if; + -- Ada 2005 (AI-231): Generate the null-excluding check in case of + -- assignment to a null-excluding object + + if Ada_Version >= Ada_05 + and then Can_Never_Be_Null (Typ) + and then Nkind (Parent (N)) = N_Assignment_Statement + then + if not Inside_Init_Proc then + Insert_Action + (Compile_Time_Constraint_Error (N, + "(Ada 2005) null not allowed in null-excluding objects?"), + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + end if; + -- In a distributed context, null for a remote access to subprogram -- may need to be replaced with a special record aggregate. In this -- case, return after having done the transformation. @@ -9459,7 +9519,27 @@ package body Sem_Res is (not Is_Constrained (Opnd) or else not Is_Constrained (Target))) then - return True; + -- Special case, if Value_Size has been used to make the + -- sizes different, the conversion is not allowed even + -- though the subtypes statically match. + + if Known_Static_RM_Size (Target) + and then Known_Static_RM_Size (Opnd) + and then RM_Size (Target) /= RM_Size (Opnd) + then + Error_Msg_NE + ("target designated subtype not compatible with }", + N, Opnd); + Error_Msg_NE + ("\because sizes of the two designated subtypes differ", + N, Opnd); + return False; + + -- Normal case where conversion is allowed + + else + return True; + end if; else Error_Msg_NE @@ -9472,16 +9552,21 @@ package body Sem_Res is -- Access to subprogram types. If the operand is an access parameter, -- the type has a deeper accessibility that any master, and cannot - -- be assigned. + -- be assigned. We must make an exception if the conversion is part + -- of an assignment and the target is the return object of an extended + -- return statement, because in that case the accessibility check + -- takes place after the return. - elsif (Ekind (Target_Type) = E_Access_Subprogram_Type - or else - Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type) + elsif Ekind (Target_Type) in Access_Subprogram_Kind and then No (Corresponding_Remote_Type (Opnd_Type)) then if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type and then Is_Entity_Name (Operand) and then Ekind (Entity (Operand)) = E_In_Parameter + and then + (Nkind (Parent (N)) /= N_Assignment_Statement + or else not Is_Entity_Name (Name (Parent (N))) + or else not Is_Return_Object (Entity (Name (Parent (N))))) then Error_Msg_N ("illegal attempt to store anonymous access to subprogram", diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index aae54d1f67e..bdd1c388220 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -766,7 +766,7 @@ package body Sem_Type is if T1 = T2 then return True; - elsif BT1 = BT2 + elsif BT1 = BT2 or else BT1 = T2 or else BT2 = T1 then diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 64d5cfb674b..00c1e380d88 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -246,7 +246,7 @@ package Sem_Util is -- families constrained by discriminants. function Denotes_Variable (N : Node_Id) return Boolean; - -- Returns True if node N denotes a single variable without parentheses. + -- Returns True if node N denotes a single variable without parentheses function Depends_On_Discriminant (N : Node_Id) return Boolean; -- Returns True if N denotes a discriminant or if N is a range, a subtype diff --git a/gcc/ada/sequenio.ads b/gcc/ada/sequenio.ads index 7fdf72d782f..42522fb9072 100644 --- a/gcc/ada/sequenio.ads +++ b/gcc/ada/sequenio.ads @@ -15,9 +15,9 @@ pragma Ada_2005; -- Explicit setting of Ada 2005 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and Text_IO is not considered to --- be an internal unit that is automatically compiled in Ada 2005 mode (since --- a user is allowed to redeclare Sequential_IO). +-- child unit (not possible in Ada 83 mode), and Sequential_IO is not +-- considered to be an internal unit that is automatically compiled in Ada +-- 2005 mode (since a user is allowed to redeclare Sequential_IO). with Ada.Sequential_IO; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index eee61f664e0..8bb6778fbd7 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -28,6 +28,8 @@ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; +with Fname; use Fname; +with Hostparm; with Opt; use Opt; with Osint; use Osint; with Output; use Output; @@ -39,6 +41,8 @@ with Sinfo; use Sinfo; with Snames; use Snames; with System; use System; +with System.OS_Lib; use System.OS_Lib; + with Unchecked_Conversion; package body Sinput.L is @@ -319,7 +323,7 @@ package body Sinput.L is -- source will be the last created, and we will be able to replace it -- and modify Hi without stepping on another buffer. - if T = Osint.Source then + if T = Osint.Source and then not Is_Internal_File_Name (N) then Prepare_To_Preprocess (Source => N, Preprocessing_Needed => Preprocessing_Needed); end if; @@ -475,6 +479,8 @@ package body Sinput.L is -- Saved state of the Style_Check flag (which needs to be -- temporarily set to False during preprocessing, see below). + Modified : Boolean; + begin -- If this is the first time we preprocess a source, allocate -- the preprocessing buffer. @@ -512,7 +518,7 @@ package body Sinput.L is Save_Style_Check := Opt.Style_Check; Opt.Style_Check := False; - Preprocess; + Preprocess (Modified); -- Reset the scanner to its standard behavior, and restore the -- Style_Checks flag. @@ -531,6 +537,54 @@ package body Sinput.L is return No_Source_File; else + -- Output the result of the preprocessing, if requested and + -- the source has been modified by the preprocessing. + + if Generate_Processed_File and then Modified then + declare + FD : File_Descriptor; + NB : Integer; + Status : Boolean; + + begin + Get_Name_String (N); + + if Hostparm.OpenVMS then + Add_Str_To_Name_Buffer ("_prep"); + else + Add_Str_To_Name_Buffer (".prep"); + end if; + + Delete_File (Name_Buffer (1 .. Name_Len), Status); + + FD := + Create_New_File (Name_Buffer (1 .. Name_Len), Text); + + Status := FD /= Invalid_FD; + + if Status then + NB := + Write + (FD, + Prep_Buffer (1)'Address, + Integer (Prep_Buffer_Last)); + Status := NB = Integer (Prep_Buffer_Last); + end if; + + if Status then + Close (FD, Status); + end if; + + if not Status then + Errout.Error_Msg + ("could not write processed file """ & + Name_Buffer (1 .. Name_Len) & '"', + Lo); + return No_Source_File; + end if; + end; + end if; + -- Set the new value of Hi Hi := Lo + Source_Ptr (Prep_Buffer_Last); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index aaea3c8c15d..3936b5b311f 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -649,7 +649,7 @@ package body Sinput is Chr : constant Character := Source (P); begin - if Chr = CR then + if Chr = CR then if Source (P + 1) = LF then P := P + 2; else diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index e97ef15c19c..d038e4372a4 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -104,9 +104,6 @@ package body Snames is "finalize#" & "next#" & "prev#" & - "_typecode#" & - "_from_any#" & - "_to_any#" & "allocate#" & "deallocate#" & "dereference#" & @@ -183,7 +180,6 @@ package body Snames is "ada_2005#" & "assertion_policy#" & "c_pass_by_copy#" & - "canonical_streams#" & "check_name#" & "check_policy#" & "compile_time_error#" & @@ -415,6 +411,7 @@ package body Snames is "secondary_stack_size#" & "section#" & "semaphore#" & + "short_descriptor#" & "simple_barriers#" & "spec_file_name#" & "state#" & @@ -557,6 +554,7 @@ package body Snames is "copy_sign#" & "floor#" & "fraction#" & + "from_any#" & "image#" & "input#" & "machine#" & @@ -567,7 +565,9 @@ package body Snames is "remainder#" & "rounding#" & "succ#" & + "to_any#" & "truncation#" & + "typecode#" & "value#" & "wide_image#" & "wide_wide_image#" & @@ -727,6 +727,7 @@ package body Snames is "extends#" & "externally_built#" & "finder#" & + "global_compilation_switches#" & "global_configuration_pragmas#" & "global_config_file#" & "gnatls#" & @@ -779,6 +780,7 @@ package body Snames is "objects_path#" & "objects_path_file#" & "object_dir#" & + "path_syntax#" & "pic_option#" & "pretty_printer#" & "prefix#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 3a93bef1fa6..8037ee18934 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -40,7 +40,7 @@ package Snames is -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. --- WARNING: There is a C file, a-snames.h which duplicates some of the +-- WARNING: There is a C file, snames.h which duplicates some of the -- definitions in this file and must be kept properly synchronized. -- If you change this package, you should run xsnames. @@ -199,116 +199,110 @@ package Snames is Name_Next : constant Name_Id := N + 044; Name_Prev : constant Name_Id := N + 045; - -- Names of TSS routines for implementation of DSA over PolyORB - - Name_uTypeCode : constant Name_Id := N + 046; - Name_uFrom_Any : constant Name_Id := N + 047; - Name_uTo_Any : constant Name_Id := N + 048; - -- Names of allocation routines, also needed by expander - Name_Allocate : constant Name_Id := N + 049; - Name_Deallocate : constant Name_Id := N + 050; - Name_Dereference : constant Name_Id := N + 051; + Name_Allocate : constant Name_Id := N + 046; + Name_Deallocate : constant Name_Id := N + 047; + Name_Dereference : constant Name_Id := N + 048; -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) - First_Text_IO_Package : constant Name_Id := N + 052; - Name_Decimal_IO : constant Name_Id := N + 052; - Name_Enumeration_IO : constant Name_Id := N + 053; - Name_Fixed_IO : constant Name_Id := N + 054; - Name_Float_IO : constant Name_Id := N + 055; - Name_Integer_IO : constant Name_Id := N + 056; - Name_Modular_IO : constant Name_Id := N + 057; - Last_Text_IO_Package : constant Name_Id := N + 057; + First_Text_IO_Package : constant Name_Id := N + 049; + Name_Decimal_IO : constant Name_Id := N + 049; + Name_Enumeration_IO : constant Name_Id := N + 050; + Name_Fixed_IO : constant Name_Id := N + 051; + Name_Float_IO : constant Name_Id := N + 052; + Name_Integer_IO : constant Name_Id := N + 053; + Name_Modular_IO : constant Name_Id := N + 054; + Last_Text_IO_Package : constant Name_Id := N + 054; subtype Text_IO_Package_Name is Name_Id range First_Text_IO_Package .. Last_Text_IO_Package; -- Some miscellaneous names used for error detection/recovery - Name_Const : constant Name_Id := N + 058; - Name_Error : constant Name_Id := N + 059; - Name_Go : constant Name_Id := N + 060; - Name_Put : constant Name_Id := N + 061; - Name_Put_Line : constant Name_Id := N + 062; - Name_To : constant Name_Id := N + 063; + Name_Const : constant Name_Id := N + 055; + Name_Error : constant Name_Id := N + 056; + Name_Go : constant Name_Id := N + 057; + Name_Put : constant Name_Id := N + 058; + Name_Put_Line : constant Name_Id := N + 059; + Name_To : constant Name_Id := N + 060; -- Names for packages that are treated specially by the compiler - Name_Exception_Traces : constant Name_Id := N + 064; - Name_Finalization : constant Name_Id := N + 065; - Name_Finalization_Root : constant Name_Id := N + 066; - Name_Interfaces : constant Name_Id := N + 067; - Name_Most_Recent_Exception : constant Name_Id := N + 068; - Name_Standard : constant Name_Id := N + 069; - Name_System : constant Name_Id := N + 070; - Name_Text_IO : constant Name_Id := N + 071; - Name_Wide_Text_IO : constant Name_Id := N + 072; - Name_Wide_Wide_Text_IO : constant Name_Id := N + 073; + Name_Exception_Traces : constant Name_Id := N + 061; + Name_Finalization : constant Name_Id := N + 062; + Name_Finalization_Root : constant Name_Id := N + 063; + Name_Interfaces : constant Name_Id := N + 064; + Name_Most_Recent_Exception : constant Name_Id := N + 065; + Name_Standard : constant Name_Id := N + 066; + Name_System : constant Name_Id := N + 067; + Name_Text_IO : constant Name_Id := N + 068; + Name_Wide_Text_IO : constant Name_Id := N + 069; + Name_Wide_Wide_Text_IO : constant Name_Id := N + 070; -- Names of implementations of the distributed systems annex - First_PCS_Name : constant Name_Id := N + 074; - Name_No_DSA : constant Name_Id := N + 074; - Name_GARLIC_DSA : constant Name_Id := N + 075; - Name_PolyORB_DSA : constant Name_Id := N + 076; - Last_PCS_Name : constant Name_Id := N + 076; + First_PCS_Name : constant Name_Id := N + 071; + Name_No_DSA : constant Name_Id := N + 071; + Name_GARLIC_DSA : constant Name_Id := N + 072; + Name_PolyORB_DSA : constant Name_Id := N + 073; + Last_PCS_Name : constant Name_Id := N + 073; subtype PCS_Names is Name_Id range First_PCS_Name .. Last_PCS_Name; -- Names of identifiers used in expanding distribution stubs - Name_Addr : constant Name_Id := N + 077; - Name_Async : constant Name_Id := N + 078; - Name_Get_Active_Partition_ID : constant Name_Id := N + 079; - Name_Get_RCI_Package_Receiver : constant Name_Id := N + 080; - Name_Get_RCI_Package_Ref : constant Name_Id := N + 081; - Name_Origin : constant Name_Id := N + 082; - Name_Params : constant Name_Id := N + 083; - Name_Partition : constant Name_Id := N + 084; - Name_Partition_Interface : constant Name_Id := N + 085; - Name_Ras : constant Name_Id := N + 086; - Name_uCall : constant Name_Id := N + 087; - Name_RCI_Name : constant Name_Id := N + 088; - Name_Receiver : constant Name_Id := N + 089; - Name_Rpc : constant Name_Id := N + 090; - Name_Subp_Id : constant Name_Id := N + 091; - Name_Operation : constant Name_Id := N + 092; - Name_Argument : constant Name_Id := N + 093; - Name_Arg_Modes : constant Name_Id := N + 094; - Name_Handler : constant Name_Id := N + 095; - Name_Target : constant Name_Id := N + 096; - Name_Req : constant Name_Id := N + 097; - Name_Obj_TypeCode : constant Name_Id := N + 098; - Name_Stub : constant Name_Id := N + 099; + Name_Addr : constant Name_Id := N + 074; + Name_Async : constant Name_Id := N + 075; + Name_Get_Active_Partition_ID : constant Name_Id := N + 076; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + 077; + Name_Get_RCI_Package_Ref : constant Name_Id := N + 078; + Name_Origin : constant Name_Id := N + 079; + Name_Params : constant Name_Id := N + 080; + Name_Partition : constant Name_Id := N + 081; + Name_Partition_Interface : constant Name_Id := N + 082; + Name_Ras : constant Name_Id := N + 083; + Name_uCall : constant Name_Id := N + 084; + Name_RCI_Name : constant Name_Id := N + 085; + Name_Receiver : constant Name_Id := N + 086; + Name_Rpc : constant Name_Id := N + 087; + Name_Subp_Id : constant Name_Id := N + 088; + Name_Operation : constant Name_Id := N + 089; + Name_Argument : constant Name_Id := N + 090; + Name_Arg_Modes : constant Name_Id := N + 091; + Name_Handler : constant Name_Id := N + 092; + Name_Target : constant Name_Id := N + 093; + Name_Req : constant Name_Id := N + 094; + Name_Obj_TypeCode : constant Name_Id := N + 095; + Name_Stub : constant Name_Id := N + 096; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". - First_Operator_Name : constant Name_Id := N + 100; - Name_Op_Abs : constant Name_Id := N + 100; -- "abs" - Name_Op_And : constant Name_Id := N + 101; -- "and" - Name_Op_Mod : constant Name_Id := N + 102; -- "mod" - Name_Op_Not : constant Name_Id := N + 103; -- "not" - Name_Op_Or : constant Name_Id := N + 104; -- "or" - Name_Op_Rem : constant Name_Id := N + 105; -- "rem" - Name_Op_Xor : constant Name_Id := N + 106; -- "xor" - Name_Op_Eq : constant Name_Id := N + 107; -- "=" - Name_Op_Ne : constant Name_Id := N + 108; -- "/=" - Name_Op_Lt : constant Name_Id := N + 109; -- "<" - Name_Op_Le : constant Name_Id := N + 110; -- "<=" - Name_Op_Gt : constant Name_Id := N + 111; -- ">" - Name_Op_Ge : constant Name_Id := N + 112; -- ">=" - Name_Op_Add : constant Name_Id := N + 113; -- "+" - Name_Op_Subtract : constant Name_Id := N + 114; -- "-" - Name_Op_Concat : constant Name_Id := N + 115; -- "&" - Name_Op_Multiply : constant Name_Id := N + 116; -- "*" - Name_Op_Divide : constant Name_Id := N + 117; -- "/" - Name_Op_Expon : constant Name_Id := N + 118; -- "**" - Last_Operator_Name : constant Name_Id := N + 118; + First_Operator_Name : constant Name_Id := N + 097; + Name_Op_Abs : constant Name_Id := N + 097; -- "abs" + Name_Op_And : constant Name_Id := N + 098; -- "and" + Name_Op_Mod : constant Name_Id := N + 099; -- "mod" + Name_Op_Not : constant Name_Id := N + 100; -- "not" + Name_Op_Or : constant Name_Id := N + 101; -- "or" + Name_Op_Rem : constant Name_Id := N + 102; -- "rem" + Name_Op_Xor : constant Name_Id := N + 103; -- "xor" + Name_Op_Eq : constant Name_Id := N + 104; -- "=" + Name_Op_Ne : constant Name_Id := N + 105; -- "/=" + Name_Op_Lt : constant Name_Id := N + 106; -- "<" + Name_Op_Le : constant Name_Id := N + 107; -- "<=" + Name_Op_Gt : constant Name_Id := N + 108; -- ">" + Name_Op_Ge : constant Name_Id := N + 109; -- ">=" + Name_Op_Add : constant Name_Id := N + 110; -- "+" + Name_Op_Subtract : constant Name_Id := N + 111; -- "-" + Name_Op_Concat : constant Name_Id := N + 112; -- "&" + Name_Op_Multiply : constant Name_Id := N + 113; -- "*" + Name_Op_Divide : constant Name_Id := N + 114; -- "/" + Name_Op_Expon : constant Name_Id := N + 115; -- "**" + Last_Operator_Name : constant Name_Id := N + 115; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. @@ -331,32 +325,31 @@ package Snames is -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. - First_Pragma_Name : constant Name_Id := N + 119; + First_Pragma_Name : constant Name_Id := N + 116; -- Configuration pragmas are grouped at start - Name_Ada_83 : constant Name_Id := N + 119; -- GNAT - Name_Ada_95 : constant Name_Id := N + 120; -- GNAT - Name_Ada_05 : constant Name_Id := N + 121; -- GNAT - Name_Ada_2005 : constant Name_Id := N + 122; -- GNAT - Name_Assertion_Policy : constant Name_Id := N + 123; -- Ada 05 - Name_C_Pass_By_Copy : constant Name_Id := N + 124; -- GNAT - Name_Canonical_Streams : constant Name_Id := N + 125; -- GNAT - Name_Check_Name : constant Name_Id := N + 126; -- GNAT - Name_Check_Policy : constant Name_Id := N + 127; -- GNAT - Name_Compile_Time_Error : constant Name_Id := N + 128; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 129; -- GNAT - Name_Compiler_Unit : constant Name_Id := N + 130; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 131; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 132; -- GNAT - Name_Debug_Policy : constant Name_Id := N + 133; -- GNAT - Name_Detect_Blocking : constant Name_Id := N + 134; -- Ada 05 - Name_Discard_Names : constant Name_Id := N + 135; - Name_Elaboration_Checks : constant Name_Id := N + 136; -- GNAT - Name_Eliminate : constant Name_Id := N + 137; -- GNAT - Name_Extend_System : constant Name_Id := N + 138; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 139; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 140; -- GNAT + Name_Ada_83 : constant Name_Id := N + 116; -- GNAT + Name_Ada_95 : constant Name_Id := N + 117; -- GNAT + Name_Ada_05 : constant Name_Id := N + 118; -- GNAT + Name_Ada_2005 : constant Name_Id := N + 119; -- GNAT + Name_Assertion_Policy : constant Name_Id := N + 120; -- Ada 05 + Name_C_Pass_By_Copy : constant Name_Id := N + 121; -- GNAT + Name_Check_Name : constant Name_Id := N + 122; -- GNAT + Name_Check_Policy : constant Name_Id := N + 123; -- GNAT + Name_Compile_Time_Error : constant Name_Id := N + 124; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 125; -- GNAT + Name_Compiler_Unit : constant Name_Id := N + 126; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 127; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 128; -- GNAT + Name_Debug_Policy : constant Name_Id := N + 129; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + 130; -- Ada 05 + Name_Discard_Names : constant Name_Id := N + 131; + Name_Elaboration_Checks : constant Name_Id := N + 132; -- GNAT + Name_Eliminate : constant Name_Id := N + 133; -- GNAT + Name_Extend_System : constant Name_Id := N + 134; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 135; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 136; -- GNAT -- Note: Fast_Math is not in this list because its name matches -- GNAT -- the name of the corresponding attribute. However, it is @@ -364,49 +357,49 @@ package Snames is -- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and -- correctly recognize and process Fast_Math. - Name_Favor_Top_Level : constant Name_Id := N + 141; -- GNAT - Name_Float_Representation : constant Name_Id := N + 142; -- GNAT - Name_Implicit_Packing : constant Name_Id := N + 143; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 144; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 145; -- GNAT - Name_License : constant Name_Id := N + 146; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 147; - Name_Long_Float : constant Name_Id := N + 148; -- VMS - Name_No_Run_Time : constant Name_Id := N + 149; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 150; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 151; - Name_Optimize_Alignment : constant Name_Id := N + 152; -- GNAT - Name_Persistent_BSS : constant Name_Id := N + 153; -- GNAT - Name_Polling : constant Name_Id := N + 154; -- GNAT - Name_Priority_Specific_Dispatching : constant Name_Id := N + 155; -- Ada 05 - Name_Profile : constant Name_Id := N + 156; -- Ada 05 - Name_Profile_Warnings : constant Name_Id := N + 157; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 158; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 159; - Name_Ravenscar : constant Name_Id := N + 160; -- GNAT - Name_Restricted_Run_Time : constant Name_Id := N + 161; -- GNAT - Name_Restrictions : constant Name_Id := N + 162; - Name_Restriction_Warnings : constant Name_Id := N + 163; -- GNAT - Name_Reviewable : constant Name_Id := N + 164; - Name_Source_File_Name : constant Name_Id := N + 165; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 166; -- GNAT - Name_Style_Checks : constant Name_Id := N + 167; -- GNAT - Name_Suppress : constant Name_Id := N + 168; - Name_Suppress_Exception_Locations : constant Name_Id := N + 169; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 170; - Name_Universal_Data : constant Name_Id := N + 171; -- AAMP - Name_Unsuppress : constant Name_Id := N + 172; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 173; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 174; -- GNAT - Name_Warnings : constant Name_Id := N + 175; -- GNAT - Name_Wide_Character_Encoding : constant Name_Id := N + 176; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 176; + Name_Favor_Top_Level : constant Name_Id := N + 137; -- GNAT + Name_Float_Representation : constant Name_Id := N + 138; -- GNAT + Name_Implicit_Packing : constant Name_Id := N + 139; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 140; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 141; -- GNAT + Name_License : constant Name_Id := N + 142; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 143; + Name_Long_Float : constant Name_Id := N + 144; -- VMS + Name_No_Run_Time : constant Name_Id := N + 145; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 146; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 147; + Name_Optimize_Alignment : constant Name_Id := N + 148; -- GNAT + Name_Persistent_BSS : constant Name_Id := N + 149; -- GNAT + Name_Polling : constant Name_Id := N + 150; -- GNAT + Name_Priority_Specific_Dispatching : constant Name_Id := N + 151; -- Ada 05 + Name_Profile : constant Name_Id := N + 152; -- Ada 05 + Name_Profile_Warnings : constant Name_Id := N + 153; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 154; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 155; + Name_Ravenscar : constant Name_Id := N + 156; -- GNAT + Name_Restricted_Run_Time : constant Name_Id := N + 157; -- GNAT + Name_Restrictions : constant Name_Id := N + 158; + Name_Restriction_Warnings : constant Name_Id := N + 159; -- GNAT + Name_Reviewable : constant Name_Id := N + 160; + Name_Source_File_Name : constant Name_Id := N + 161; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 162; -- GNAT + Name_Style_Checks : constant Name_Id := N + 163; -- GNAT + Name_Suppress : constant Name_Id := N + 164; + Name_Suppress_Exception_Locations : constant Name_Id := N + 165; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 166; + Name_Universal_Data : constant Name_Id := N + 167; -- AAMP + Name_Unsuppress : constant Name_Id := N + 168; -- Ada 05 + Name_Use_VADS_Size : constant Name_Id := N + 169; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 170; -- GNAT + Name_Warnings : constant Name_Id := N + 171; -- GNAT + Name_Wide_Character_Encoding : constant Name_Id := N + 172; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 172; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 177; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 178; - Name_Annotate : constant Name_Id := N + 179; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 173; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 174; + Name_Annotate : constant Name_Id := N + 175; -- GNAT -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is @@ -414,77 +407,83 @@ package Snames is -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Name_AST_Entry. - Name_Assert : constant Name_Id := N + 180; -- Ada 05 - Name_Asynchronous : constant Name_Id := N + 181; - Name_Atomic : constant Name_Id := N + 182; - Name_Atomic_Components : constant Name_Id := N + 183; - Name_Attach_Handler : constant Name_Id := N + 184; - Name_Check : constant Name_Id := N + 185; -- GNAT - Name_CIL_Constructor : constant Name_Id := N + 186; -- GNAT - Name_Comment : constant Name_Id := N + 187; -- GNAT - Name_Common_Object : constant Name_Id := N + 188; -- GNAT - Name_Complete_Representation : constant Name_Id := N + 189; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 190; -- GNAT - Name_Controlled : constant Name_Id := N + 191; - Name_Convention : constant Name_Id := N + 192; - Name_CPP_Class : constant Name_Id := N + 193; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 194; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 195; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 196; -- GNAT - Name_Debug : constant Name_Id := N + 197; -- GNAT - Name_Elaborate : constant Name_Id := N + 198; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 199; - Name_Elaborate_Body : constant Name_Id := N + 200; - Name_Export : constant Name_Id := N + 201; - Name_Export_Exception : constant Name_Id := N + 202; -- VMS - Name_Export_Function : constant Name_Id := N + 203; -- GNAT - Name_Export_Object : constant Name_Id := N + 204; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 205; -- GNAT - Name_Export_Value : constant Name_Id := N + 206; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 207; -- GNAT - Name_External : constant Name_Id := N + 208; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 209; -- GNAT - Name_Ident : constant Name_Id := N + 210; -- VMS - Name_Implemented_By_Entry : constant Name_Id := N + 211; -- Ada 05 - Name_Import : constant Name_Id := N + 212; - Name_Import_Exception : constant Name_Id := N + 213; -- VMS - Name_Import_Function : constant Name_Id := N + 214; -- GNAT - Name_Import_Object : constant Name_Id := N + 215; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 216; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 217; -- GNAT - Name_Inline : constant Name_Id := N + 218; - Name_Inline_Always : constant Name_Id := N + 219; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 220; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 221; - Name_Interface_Name : constant Name_Id := N + 222; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 223; - Name_Interrupt_Priority : constant Name_Id := N + 224; - Name_Java_Constructor : constant Name_Id := N + 225; -- GNAT - Name_Java_Interface : constant Name_Id := N + 226; -- GNAT - Name_Keep_Names : constant Name_Id := N + 227; -- GNAT - Name_Link_With : constant Name_Id := N + 228; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 229; -- GNAT - Name_Linker_Constructor : constant Name_Id := N + 230; -- GNAT - Name_Linker_Destructor : constant Name_Id := N + 231; -- GNAT - Name_Linker_Options : constant Name_Id := N + 232; - Name_Linker_Section : constant Name_Id := N + 233; -- GNAT - Name_List : constant Name_Id := N + 234; - Name_Machine_Attribute : constant Name_Id := N + 235; -- GNAT - Name_Main : constant Name_Id := N + 236; -- GNAT - Name_Main_Storage : constant Name_Id := N + 237; -- GNAT - Name_Memory_Size : constant Name_Id := N + 238; -- Ada 83 - Name_No_Body : constant Name_Id := N + 239; -- GNAT - Name_No_Return : constant Name_Id := N + 240; -- GNAT - Name_Obsolescent : constant Name_Id := N + 241; -- GNAT - Name_Optimize : constant Name_Id := N + 242; - Name_Pack : constant Name_Id := N + 243; - Name_Page : constant Name_Id := N + 244; - Name_Passive : constant Name_Id := N + 245; -- GNAT - Name_Postcondition : constant Name_Id := N + 246; -- GNAT - Name_Precondition : constant Name_Id := N + 247; -- GNAT - Name_Preelaborable_Initialization : constant Name_Id := N + 248; -- Ada 05 - Name_Preelaborate : constant Name_Id := N + 249; - Name_Preelaborate_05 : constant Name_Id := N + 250; -- GNAT + Name_Assert : constant Name_Id := N + 176; -- Ada 05 + Name_Asynchronous : constant Name_Id := N + 177; + Name_Atomic : constant Name_Id := N + 178; + Name_Atomic_Components : constant Name_Id := N + 179; + Name_Attach_Handler : constant Name_Id := N + 180; + Name_Check : constant Name_Id := N + 181; -- GNAT + Name_CIL_Constructor : constant Name_Id := N + 182; -- GNAT + Name_Comment : constant Name_Id := N + 183; -- GNAT + Name_Common_Object : constant Name_Id := N + 184; -- GNAT + Name_Complete_Representation : constant Name_Id := N + 185; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 186; -- GNAT + Name_Controlled : constant Name_Id := N + 187; + Name_Convention : constant Name_Id := N + 188; + Name_CPP_Class : constant Name_Id := N + 189; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 190; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 191; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 192; -- GNAT + Name_Debug : constant Name_Id := N + 193; -- GNAT + Name_Elaborate : constant Name_Id := N + 194; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 195; + Name_Elaborate_Body : constant Name_Id := N + 196; + Name_Export : constant Name_Id := N + 197; + Name_Export_Exception : constant Name_Id := N + 198; -- VMS + Name_Export_Function : constant Name_Id := N + 199; -- GNAT + Name_Export_Object : constant Name_Id := N + 200; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 201; -- GNAT + Name_Export_Value : constant Name_Id := N + 202; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 203; -- GNAT + Name_External : constant Name_Id := N + 204; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 205; -- GNAT + Name_Ident : constant Name_Id := N + 206; -- VMS + Name_Implemented_By_Entry : constant Name_Id := N + 207; -- Ada 05 + Name_Import : constant Name_Id := N + 208; + Name_Import_Exception : constant Name_Id := N + 209; -- VMS + Name_Import_Function : constant Name_Id := N + 210; -- GNAT + Name_Import_Object : constant Name_Id := N + 211; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 212; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 213; -- GNAT + Name_Inline : constant Name_Id := N + 214; + Name_Inline_Always : constant Name_Id := N + 215; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 216; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 217; + + -- Note: Interface is not in this list because its name matches -- GNAT + -- an Ada 2005 keyword. However it is included in the definition + -- of the type Attribute_Id, and the functions Get_Pragma_Id and + -- Is_Pragma_Id correctly recognize and process Name_Storage_Size. + + Name_Interface_Name : constant Name_Id := N + 218; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 219; + Name_Interrupt_Priority : constant Name_Id := N + 220; + Name_Java_Constructor : constant Name_Id := N + 221; -- GNAT + Name_Java_Interface : constant Name_Id := N + 222; -- GNAT + Name_Keep_Names : constant Name_Id := N + 223; -- GNAT + Name_Link_With : constant Name_Id := N + 224; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 225; -- GNAT + Name_Linker_Constructor : constant Name_Id := N + 226; -- GNAT + Name_Linker_Destructor : constant Name_Id := N + 227; -- GNAT + Name_Linker_Options : constant Name_Id := N + 228; + Name_Linker_Section : constant Name_Id := N + 229; -- GNAT + Name_List : constant Name_Id := N + 230; + Name_Machine_Attribute : constant Name_Id := N + 231; -- GNAT + Name_Main : constant Name_Id := N + 232; -- GNAT + Name_Main_Storage : constant Name_Id := N + 233; -- GNAT + Name_Memory_Size : constant Name_Id := N + 234; -- Ada 83 + Name_No_Body : constant Name_Id := N + 235; -- GNAT + Name_No_Return : constant Name_Id := N + 236; -- GNAT + Name_Obsolescent : constant Name_Id := N + 237; -- GNAT + Name_Optimize : constant Name_Id := N + 238; + Name_Pack : constant Name_Id := N + 239; + Name_Page : constant Name_Id := N + 240; + Name_Passive : constant Name_Id := N + 241; -- GNAT + Name_Postcondition : constant Name_Id := N + 242; -- GNAT + Name_Precondition : constant Name_Id := N + 243; -- GNAT + Name_Preelaborable_Initialization : constant Name_Id := N + 244; -- Ada 05 + Name_Preelaborate : constant Name_Id := N + 245; + Name_Preelaborate_05 : constant Name_Id := N + 246; -- GNAT -- Note: Priority is not in this list because its name matches -- the name of the corresponding attribute. However, it is @@ -492,16 +491,16 @@ package Snames is -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Priority. Priority is a standard Ada 95 pragma. - Name_Psect_Object : constant Name_Id := N + 251; -- VMS - Name_Pure : constant Name_Id := N + 252; - Name_Pure_05 : constant Name_Id := N + 253; -- GNAT - Name_Pure_Function : constant Name_Id := N + 254; -- GNAT - Name_Relative_Deadline : constant Name_Id := N + 255; -- Ada 05 - Name_Remote_Call_Interface : constant Name_Id := N + 256; - Name_Remote_Types : constant Name_Id := N + 257; - Name_Share_Generic : constant Name_Id := N + 258; -- GNAT - Name_Shared : constant Name_Id := N + 259; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 260; + Name_Psect_Object : constant Name_Id := N + 247; -- VMS + Name_Pure : constant Name_Id := N + 248; + Name_Pure_05 : constant Name_Id := N + 249; -- GNAT + Name_Pure_Function : constant Name_Id := N + 250; -- GNAT + Name_Relative_Deadline : constant Name_Id := N + 251; -- Ada 05 + Name_Remote_Call_Interface : constant Name_Id := N + 252; + Name_Remote_Types : constant Name_Id := N + 253; + Name_Share_Generic : constant Name_Id := N + 254; -- GNAT + Name_Shared : constant Name_Id := N + 255; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 256; -- Note: Storage_Size is not in this list because its name -- matches the name of the corresponding attribute. However, @@ -512,30 +511,30 @@ 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 + 261; -- GNAT - Name_Static_Elaboration_Desired : constant Name_Id := N + 262; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 263; -- GNAT - Name_Subtitle : constant Name_Id := N + 264; -- GNAT - Name_Suppress_All : constant Name_Id := N + 265; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 266; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 267; -- GNAT - Name_System_Name : constant Name_Id := N + 268; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 269; -- GNAT - Name_Task_Name : constant Name_Id := N + 270; -- GNAT - Name_Task_Storage : constant Name_Id := N + 271; -- VMS - Name_Time_Slice : constant Name_Id := N + 272; -- GNAT - Name_Title : constant Name_Id := N + 273; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 274; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 275; -- GNAT - Name_Universal_Aliasing : constant Name_Id := N + 276; -- GNAT - Name_Unmodified : constant Name_Id := N + 277; -- GNAT - Name_Unreferenced : constant Name_Id := N + 278; -- GNAT - Name_Unreferenced_Objects : constant Name_Id := N + 279; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 280; -- GNAT - Name_Volatile : constant Name_Id := N + 281; - Name_Volatile_Components : constant Name_Id := N + 282; - Name_Weak_External : constant Name_Id := N + 283; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 283; + Name_Source_Reference : constant Name_Id := N + 257; -- GNAT + Name_Static_Elaboration_Desired : constant Name_Id := N + 258; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 259; -- GNAT + Name_Subtitle : constant Name_Id := N + 260; -- GNAT + Name_Suppress_All : constant Name_Id := N + 261; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 262; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 263; -- GNAT + Name_System_Name : constant Name_Id := N + 264; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 265; -- GNAT + Name_Task_Name : constant Name_Id := N + 266; -- GNAT + Name_Task_Storage : constant Name_Id := N + 267; -- VMS + Name_Time_Slice : constant Name_Id := N + 268; -- GNAT + Name_Title : constant Name_Id := N + 269; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 270; -- Ada 05 + Name_Unimplemented_Unit : constant Name_Id := N + 271; -- GNAT + Name_Universal_Aliasing : constant Name_Id := N + 272; -- GNAT + Name_Unmodified : constant Name_Id := N + 273; -- GNAT + Name_Unreferenced : constant Name_Id := N + 274; -- GNAT + Name_Unreferenced_Objects : constant Name_Id := N + 275; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 276; -- GNAT + Name_Volatile : constant Name_Id := N + 277; + Name_Volatile_Components : constant Name_Id := N + 278; + Name_Weak_External : constant Name_Id := N + 279; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 279; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -546,119 +545,120 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 284; - Name_Ada : constant Name_Id := N + 284; - Name_Assembler : constant Name_Id := N + 285; - Name_CIL : constant Name_Id := N + 286; - Name_COBOL : constant Name_Id := N + 287; - Name_CPP : constant Name_Id := N + 288; - Name_Fortran : constant Name_Id := N + 289; - Name_Intrinsic : constant Name_Id := N + 290; - Name_Java : constant Name_Id := N + 291; - Name_Stdcall : constant Name_Id := N + 292; - Name_Stubbed : constant Name_Id := N + 293; - Last_Convention_Name : constant Name_Id := N + 293; + First_Convention_Name : constant Name_Id := N + 280; + Name_Ada : constant Name_Id := N + 280; + Name_Assembler : constant Name_Id := N + 281; + Name_CIL : constant Name_Id := N + 282; + Name_COBOL : constant Name_Id := N + 283; + Name_CPP : constant Name_Id := N + 284; + Name_Fortran : constant Name_Id := N + 285; + Name_Intrinsic : constant Name_Id := N + 286; + Name_Java : constant Name_Id := N + 287; + Name_Stdcall : constant Name_Id := N + 288; + Name_Stubbed : constant Name_Id := N + 289; + Last_Convention_Name : constant Name_Id := N + 289; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 294; - Name_Assembly : constant Name_Id := N + 295; + Name_Asm : constant Name_Id := N + 290; + Name_Assembly : constant Name_Id := N + 291; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 296; + Name_Default : constant Name_Id := N + 292; -- Name_External (previously defined as pragma) -- The following names are preset as synonyms for CPP - Name_C_Plus_Plus : constant Name_Id := N + 297; + Name_C_Plus_Plus : constant Name_Id := N + 293; -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 298; - Name_Win32 : constant Name_Id := N + 299; + Name_DLL : constant Name_Id := N + 294; + Name_Win32 : constant Name_Id := N + 295; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 300; - Name_Assertion : constant Name_Id := N + 301; - Name_Attribute_Name : constant Name_Id := N + 302; - Name_Body_File_Name : constant Name_Id := N + 303; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 304; - Name_Casing : constant Name_Id := N + 305; - Name_Code : constant Name_Id := N + 306; - Name_Component : constant Name_Id := N + 307; - Name_Component_Size_4 : constant Name_Id := N + 308; - Name_Copy : constant Name_Id := N + 309; - Name_D_Float : constant Name_Id := N + 310; - Name_Descriptor : constant Name_Id := N + 311; - Name_Dot_Replacement : constant Name_Id := N + 312; - Name_Dynamic : constant Name_Id := N + 313; - Name_Entity : constant Name_Id := N + 314; - Name_Entry_Count : constant Name_Id := N + 315; - Name_External_Name : constant Name_Id := N + 316; - Name_First_Optional_Parameter : constant Name_Id := N + 317; - Name_Form : constant Name_Id := N + 318; - Name_G_Float : constant Name_Id := N + 319; - Name_Gcc : constant Name_Id := N + 320; - Name_Gnat : constant Name_Id := N + 321; - Name_GPL : constant Name_Id := N + 322; - Name_IEEE_Float : constant Name_Id := N + 323; - Name_Ignore : constant Name_Id := N + 324; - Name_Info : constant Name_Id := N + 325; - Name_Internal : constant Name_Id := N + 326; - Name_Link_Name : constant Name_Id := N + 327; - Name_Lowercase : constant Name_Id := N + 328; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 329; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 330; - Name_Max_Size : constant Name_Id := N + 331; - Name_Mechanism : constant Name_Id := N + 332; - Name_Message : constant Name_Id := N + 333; - Name_Mixedcase : constant Name_Id := N + 334; - Name_Modified_GPL : constant Name_Id := N + 335; - Name_Name : constant Name_Id := N + 336; - Name_NCA : constant Name_Id := N + 337; - Name_No : constant Name_Id := N + 338; - Name_No_Dependence : constant Name_Id := N + 339; - Name_No_Dynamic_Attachment : constant Name_Id := N + 340; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 341; - Name_No_Requeue : constant Name_Id := N + 342; - Name_No_Requeue_Statements : constant Name_Id := N + 343; - Name_No_Task_Attributes : constant Name_Id := N + 344; - Name_No_Task_Attributes_Package : constant Name_Id := N + 345; - Name_On : constant Name_Id := N + 346; - Name_Parameter_Types : constant Name_Id := N + 347; - Name_Reference : constant Name_Id := N + 348; - Name_Restricted : constant Name_Id := N + 349; - Name_Result_Mechanism : constant Name_Id := N + 350; - Name_Result_Type : constant Name_Id := N + 351; - Name_Runtime : constant Name_Id := N + 352; - Name_SB : constant Name_Id := N + 353; - Name_Secondary_Stack_Size : constant Name_Id := N + 354; - Name_Section : constant Name_Id := N + 355; - Name_Semaphore : constant Name_Id := N + 356; - Name_Simple_Barriers : constant Name_Id := N + 357; - Name_Spec_File_Name : constant Name_Id := N + 358; - Name_State : constant Name_Id := N + 359; - Name_Static : constant Name_Id := N + 360; - Name_Stack_Size : constant Name_Id := N + 361; - Name_Subunit_File_Name : constant Name_Id := N + 362; - Name_Task_Stack_Size_Default : constant Name_Id := N + 363; - Name_Task_Type : constant Name_Id := N + 364; - Name_Time_Slicing_Enabled : constant Name_Id := N + 365; - Name_Top_Guard : constant Name_Id := N + 366; - Name_UBA : constant Name_Id := N + 367; - Name_UBS : constant Name_Id := N + 368; - Name_UBSB : constant Name_Id := N + 369; - Name_Unit_Name : constant Name_Id := N + 370; - Name_Unknown : constant Name_Id := N + 371; - Name_Unrestricted : constant Name_Id := N + 372; - Name_Uppercase : constant Name_Id := N + 373; - Name_User : constant Name_Id := N + 374; - Name_VAX_Float : constant Name_Id := N + 375; - Name_VMS : constant Name_Id := N + 376; - Name_Vtable_Ptr : constant Name_Id := N + 377; - Name_Working_Storage : constant Name_Id := N + 378; + Name_As_Is : constant Name_Id := N + 296; + Name_Assertion : constant Name_Id := N + 297; + Name_Attribute_Name : constant Name_Id := N + 298; + Name_Body_File_Name : constant Name_Id := N + 299; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 300; + Name_Casing : constant Name_Id := N + 301; + Name_Code : constant Name_Id := N + 302; + Name_Component : constant Name_Id := N + 303; + Name_Component_Size_4 : constant Name_Id := N + 304; + Name_Copy : constant Name_Id := N + 305; + Name_D_Float : constant Name_Id := N + 306; + Name_Descriptor : constant Name_Id := N + 307; + Name_Dot_Replacement : constant Name_Id := N + 308; + Name_Dynamic : constant Name_Id := N + 309; + Name_Entity : constant Name_Id := N + 310; + Name_Entry_Count : constant Name_Id := N + 311; + Name_External_Name : constant Name_Id := N + 312; + Name_First_Optional_Parameter : constant Name_Id := N + 313; + Name_Form : constant Name_Id := N + 314; + Name_G_Float : constant Name_Id := N + 315; + Name_Gcc : constant Name_Id := N + 316; + Name_Gnat : constant Name_Id := N + 317; + Name_GPL : constant Name_Id := N + 318; + Name_IEEE_Float : constant Name_Id := N + 319; + Name_Ignore : constant Name_Id := N + 320; + Name_Info : constant Name_Id := N + 321; + Name_Internal : constant Name_Id := N + 322; + Name_Link_Name : constant Name_Id := N + 323; + Name_Lowercase : constant Name_Id := N + 324; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 325; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 326; + Name_Max_Size : constant Name_Id := N + 327; + Name_Mechanism : constant Name_Id := N + 328; + Name_Message : constant Name_Id := N + 329; + Name_Mixedcase : constant Name_Id := N + 330; + Name_Modified_GPL : constant Name_Id := N + 331; + Name_Name : constant Name_Id := N + 332; + Name_NCA : constant Name_Id := N + 333; + Name_No : constant Name_Id := N + 334; + Name_No_Dependence : constant Name_Id := N + 335; + Name_No_Dynamic_Attachment : constant Name_Id := N + 336; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 337; + Name_No_Requeue : constant Name_Id := N + 338; + Name_No_Requeue_Statements : constant Name_Id := N + 339; + Name_No_Task_Attributes : constant Name_Id := N + 340; + Name_No_Task_Attributes_Package : constant Name_Id := N + 341; + Name_On : constant Name_Id := N + 342; + Name_Parameter_Types : constant Name_Id := N + 343; + Name_Reference : constant Name_Id := N + 344; + Name_Restricted : constant Name_Id := N + 345; + Name_Result_Mechanism : constant Name_Id := N + 346; + Name_Result_Type : constant Name_Id := N + 347; + Name_Runtime : constant Name_Id := N + 348; + Name_SB : constant Name_Id := N + 349; + Name_Secondary_Stack_Size : constant Name_Id := N + 350; + Name_Section : constant Name_Id := N + 351; + Name_Semaphore : constant Name_Id := N + 352; + Name_Short_Descriptor : constant Name_Id := N + 353; + Name_Simple_Barriers : constant Name_Id := N + 354; + Name_Spec_File_Name : constant Name_Id := N + 355; + Name_State : constant Name_Id := N + 356; + Name_Static : constant Name_Id := N + 357; + Name_Stack_Size : constant Name_Id := N + 358; + Name_Subunit_File_Name : constant Name_Id := N + 359; + Name_Task_Stack_Size_Default : constant Name_Id := N + 360; + Name_Task_Type : constant Name_Id := N + 361; + Name_Time_Slicing_Enabled : constant Name_Id := N + 362; + Name_Top_Guard : constant Name_Id := N + 363; + Name_UBA : constant Name_Id := N + 364; + Name_UBS : constant Name_Id := N + 365; + Name_UBSB : constant Name_Id := N + 366; + Name_Unit_Name : constant Name_Id := N + 367; + Name_Unknown : constant Name_Id := N + 368; + Name_Unrestricted : constant Name_Id := N + 369; + Name_Uppercase : constant Name_Id := N + 370; + Name_User : constant Name_Id := N + 371; + Name_VAX_Float : constant Name_Id := N + 372; + Name_VMS : constant Name_Id := N + 373; + Name_Vtable_Ptr : constant Name_Id := N + 374; + Name_Working_Storage : constant Name_Id := N + 375; -- 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 @@ -672,144 +672,147 @@ 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 + 379; - Name_Abort_Signal : constant Name_Id := N + 379; -- GNAT - Name_Access : constant Name_Id := N + 380; - Name_Address : constant Name_Id := N + 381; - Name_Address_Size : constant Name_Id := N + 382; -- GNAT - Name_Aft : constant Name_Id := N + 383; - Name_Alignment : constant Name_Id := N + 384; - Name_Asm_Input : constant Name_Id := N + 385; -- GNAT - Name_Asm_Output : constant Name_Id := N + 386; -- GNAT - Name_AST_Entry : constant Name_Id := N + 387; -- VMS - Name_Bit : constant Name_Id := N + 388; -- GNAT - Name_Bit_Order : constant Name_Id := N + 389; - Name_Bit_Position : constant Name_Id := N + 390; -- GNAT - Name_Body_Version : constant Name_Id := N + 391; - Name_Callable : constant Name_Id := N + 392; - Name_Caller : constant Name_Id := N + 393; - Name_Code_Address : constant Name_Id := N + 394; -- GNAT - Name_Component_Size : constant Name_Id := N + 395; - Name_Compose : constant Name_Id := N + 396; - Name_Constrained : constant Name_Id := N + 397; - Name_Count : constant Name_Id := N + 398; - Name_Default_Bit_Order : constant Name_Id := N + 399; -- GNAT - Name_Definite : constant Name_Id := N + 400; - Name_Delta : constant Name_Id := N + 401; - Name_Denorm : constant Name_Id := N + 402; - Name_Digits : constant Name_Id := N + 403; - Name_Elaborated : constant Name_Id := N + 404; -- GNAT - Name_Emax : constant Name_Id := N + 405; -- Ada 83 - Name_Enabled : constant Name_Id := N + 406; -- GNAT - Name_Enum_Rep : constant Name_Id := N + 407; -- GNAT - Name_Enum_Val : constant Name_Id := N + 408; -- GNAT - Name_Epsilon : constant Name_Id := N + 409; -- Ada 83 - Name_Exponent : constant Name_Id := N + 410; - Name_External_Tag : constant Name_Id := N + 411; - Name_Fast_Math : constant Name_Id := N + 412; -- GNAT - Name_First : constant Name_Id := N + 413; - Name_First_Bit : constant Name_Id := N + 414; - Name_Fixed_Value : constant Name_Id := N + 415; -- GNAT - Name_Fore : constant Name_Id := N + 416; - Name_Has_Access_Values : constant Name_Id := N + 417; -- GNAT - Name_Has_Discriminants : constant Name_Id := N + 418; -- GNAT - Name_Has_Tagged_Values : constant Name_Id := N + 419; -- GNAT - Name_Identity : constant Name_Id := N + 420; - Name_Img : constant Name_Id := N + 421; -- GNAT - Name_Integer_Value : constant Name_Id := N + 422; -- GNAT - Name_Invalid_Value : constant Name_Id := N + 423; -- GNAT - Name_Large : constant Name_Id := N + 424; -- Ada 83 - Name_Last : constant Name_Id := N + 425; - Name_Last_Bit : constant Name_Id := N + 426; - Name_Leading_Part : constant Name_Id := N + 427; - Name_Length : constant Name_Id := N + 428; - Name_Machine_Emax : constant Name_Id := N + 429; - Name_Machine_Emin : constant Name_Id := N + 430; - Name_Machine_Mantissa : constant Name_Id := N + 431; - Name_Machine_Overflows : constant Name_Id := N + 432; - Name_Machine_Radix : constant Name_Id := N + 433; - Name_Machine_Rounding : constant Name_Id := N + 434; -- Ada 05 - Name_Machine_Rounds : constant Name_Id := N + 435; - Name_Machine_Size : constant Name_Id := N + 436; -- GNAT - Name_Mantissa : constant Name_Id := N + 437; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 438; - Name_Maximum_Alignment : constant Name_Id := N + 439; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 440; -- GNAT - Name_Mod : constant Name_Id := N + 441; -- Ada 05 - Name_Model_Emin : constant Name_Id := N + 442; - Name_Model_Epsilon : constant Name_Id := N + 443; - Name_Model_Mantissa : constant Name_Id := N + 444; - Name_Model_Small : constant Name_Id := N + 445; - Name_Modulus : constant Name_Id := N + 446; - Name_Null_Parameter : constant Name_Id := N + 447; -- GNAT - Name_Object_Size : constant Name_Id := N + 448; -- GNAT - Name_Old : constant Name_Id := N + 449; -- GNAT - Name_Partition_ID : constant Name_Id := N + 450; - Name_Passed_By_Reference : constant Name_Id := N + 451; -- GNAT - Name_Pool_Address : constant Name_Id := N + 452; - Name_Pos : constant Name_Id := N + 453; - Name_Position : constant Name_Id := N + 454; - Name_Priority : constant Name_Id := N + 455; -- Ada 05 - Name_Range : constant Name_Id := N + 456; - Name_Range_Length : constant Name_Id := N + 457; -- GNAT - Name_Result : constant Name_Id := N + 458; -- GNAT - Name_Round : constant Name_Id := N + 459; - Name_Safe_Emax : constant Name_Id := N + 460; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 461; - Name_Safe_Large : constant Name_Id := N + 462; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 463; - Name_Safe_Small : constant Name_Id := N + 464; -- Ada 83 - Name_Scale : constant Name_Id := N + 465; - Name_Scaling : constant Name_Id := N + 466; - Name_Signed_Zeros : constant Name_Id := N + 467; - Name_Size : constant Name_Id := N + 468; - Name_Small : constant Name_Id := N + 469; - Name_Storage_Size : constant Name_Id := N + 470; - Name_Storage_Unit : constant Name_Id := N + 471; -- GNAT - Name_Stream_Size : constant Name_Id := N + 472; -- Ada 05 - Name_Tag : constant Name_Id := N + 473; - Name_Target_Name : constant Name_Id := N + 474; -- GNAT - Name_Terminated : constant Name_Id := N + 475; - Name_To_Address : constant Name_Id := N + 476; -- GNAT - Name_Type_Class : constant Name_Id := N + 477; -- GNAT - Name_UET_Address : constant Name_Id := N + 478; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 479; - Name_Unchecked_Access : constant Name_Id := N + 480; - Name_Unconstrained_Array : constant Name_Id := N + 481; - Name_Universal_Literal_String : constant Name_Id := N + 482; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 483; -- GNAT - Name_VADS_Size : constant Name_Id := N + 484; -- GNAT - Name_Val : constant Name_Id := N + 485; - Name_Valid : constant Name_Id := N + 486; - Name_Value_Size : constant Name_Id := N + 487; -- GNAT - Name_Version : constant Name_Id := N + 488; - Name_Wchar_T_Size : constant Name_Id := N + 489; -- GNAT - Name_Wide_Wide_Width : constant Name_Id := N + 490; -- Ada 05 - Name_Wide_Width : constant Name_Id := N + 491; - Name_Width : constant Name_Id := N + 492; - Name_Word_Size : constant Name_Id := N + 493; -- GNAT + First_Attribute_Name : constant Name_Id := N + 376; + Name_Abort_Signal : constant Name_Id := N + 376; -- GNAT + Name_Access : constant Name_Id := N + 377; + Name_Address : constant Name_Id := N + 378; + Name_Address_Size : constant Name_Id := N + 379; -- GNAT + Name_Aft : constant Name_Id := N + 380; + Name_Alignment : constant Name_Id := N + 381; + Name_Asm_Input : constant Name_Id := N + 382; -- GNAT + Name_Asm_Output : constant Name_Id := N + 383; -- GNAT + Name_AST_Entry : constant Name_Id := N + 384; -- VMS + Name_Bit : constant Name_Id := N + 385; -- GNAT + Name_Bit_Order : constant Name_Id := N + 386; + Name_Bit_Position : constant Name_Id := N + 387; -- GNAT + Name_Body_Version : constant Name_Id := N + 388; + Name_Callable : constant Name_Id := N + 389; + Name_Caller : constant Name_Id := N + 390; + Name_Code_Address : constant Name_Id := N + 391; -- GNAT + Name_Component_Size : constant Name_Id := N + 392; + Name_Compose : constant Name_Id := N + 393; + Name_Constrained : constant Name_Id := N + 394; + Name_Count : constant Name_Id := N + 395; + Name_Default_Bit_Order : constant Name_Id := N + 396; -- GNAT + Name_Definite : constant Name_Id := N + 397; + Name_Delta : constant Name_Id := N + 398; + Name_Denorm : constant Name_Id := N + 399; + Name_Digits : constant Name_Id := N + 400; + Name_Elaborated : constant Name_Id := N + 401; -- GNAT + Name_Emax : constant Name_Id := N + 402; -- Ada 83 + Name_Enabled : constant Name_Id := N + 403; -- GNAT + Name_Enum_Rep : constant Name_Id := N + 404; -- GNAT + Name_Enum_Val : constant Name_Id := N + 405; -- GNAT + Name_Epsilon : constant Name_Id := N + 406; -- Ada 83 + Name_Exponent : constant Name_Id := N + 407; + Name_External_Tag : constant Name_Id := N + 408; + Name_Fast_Math : constant Name_Id := N + 409; -- GNAT + Name_First : constant Name_Id := N + 410; + Name_First_Bit : constant Name_Id := N + 411; + Name_Fixed_Value : constant Name_Id := N + 412; -- GNAT + Name_Fore : constant Name_Id := N + 413; + Name_Has_Access_Values : constant Name_Id := N + 414; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + 415; -- GNAT + Name_Has_Tagged_Values : constant Name_Id := N + 416; -- GNAT + Name_Identity : constant Name_Id := N + 417; + Name_Img : constant Name_Id := N + 418; -- GNAT + Name_Integer_Value : constant Name_Id := N + 419; -- GNAT + Name_Invalid_Value : constant Name_Id := N + 420; -- GNAT + Name_Large : constant Name_Id := N + 421; -- Ada 83 + Name_Last : constant Name_Id := N + 422; + Name_Last_Bit : constant Name_Id := N + 423; + Name_Leading_Part : constant Name_Id := N + 424; + Name_Length : constant Name_Id := N + 425; + Name_Machine_Emax : constant Name_Id := N + 426; + Name_Machine_Emin : constant Name_Id := N + 427; + Name_Machine_Mantissa : constant Name_Id := N + 428; + Name_Machine_Overflows : constant Name_Id := N + 429; + Name_Machine_Radix : constant Name_Id := N + 430; + Name_Machine_Rounding : constant Name_Id := N + 431; -- Ada 05 + Name_Machine_Rounds : constant Name_Id := N + 432; + Name_Machine_Size : constant Name_Id := N + 433; -- GNAT + Name_Mantissa : constant Name_Id := N + 434; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 435; + Name_Maximum_Alignment : constant Name_Id := N + 436; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 437; -- GNAT + Name_Mod : constant Name_Id := N + 438; -- Ada 05 + Name_Model_Emin : constant Name_Id := N + 439; + Name_Model_Epsilon : constant Name_Id := N + 440; + Name_Model_Mantissa : constant Name_Id := N + 441; + Name_Model_Small : constant Name_Id := N + 442; + Name_Modulus : constant Name_Id := N + 443; + Name_Null_Parameter : constant Name_Id := N + 444; -- GNAT + Name_Object_Size : constant Name_Id := N + 445; -- GNAT + Name_Old : constant Name_Id := N + 446; -- GNAT + Name_Partition_ID : constant Name_Id := N + 447; + Name_Passed_By_Reference : constant Name_Id := N + 448; -- GNAT + Name_Pool_Address : constant Name_Id := N + 449; + Name_Pos : constant Name_Id := N + 450; + Name_Position : constant Name_Id := N + 451; + Name_Priority : constant Name_Id := N + 452; -- Ada 05 + Name_Range : constant Name_Id := N + 453; + Name_Range_Length : constant Name_Id := N + 454; -- GNAT + Name_Result : constant Name_Id := N + 455; -- GNAT + Name_Round : constant Name_Id := N + 456; + Name_Safe_Emax : constant Name_Id := N + 457; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 458; + Name_Safe_Large : constant Name_Id := N + 459; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 460; + Name_Safe_Small : constant Name_Id := N + 461; -- Ada 83 + Name_Scale : constant Name_Id := N + 462; + Name_Scaling : constant Name_Id := N + 463; + Name_Signed_Zeros : constant Name_Id := N + 464; + Name_Size : constant Name_Id := N + 465; + Name_Small : constant Name_Id := N + 466; + Name_Storage_Size : constant Name_Id := N + 467; + Name_Storage_Unit : constant Name_Id := N + 468; -- GNAT + Name_Stream_Size : constant Name_Id := N + 469; -- Ada 05 + Name_Tag : constant Name_Id := N + 470; + Name_Target_Name : constant Name_Id := N + 471; -- GNAT + Name_Terminated : constant Name_Id := N + 472; + Name_To_Address : constant Name_Id := N + 473; -- GNAT + Name_Type_Class : constant Name_Id := N + 474; -- GNAT + Name_UET_Address : constant Name_Id := N + 475; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 476; + Name_Unchecked_Access : constant Name_Id := N + 477; + Name_Unconstrained_Array : constant Name_Id := N + 478; + Name_Universal_Literal_String : constant Name_Id := N + 479; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 480; -- GNAT + Name_VADS_Size : constant Name_Id := N + 481; -- GNAT + Name_Val : constant Name_Id := N + 482; + Name_Valid : constant Name_Id := N + 483; + Name_Value_Size : constant Name_Id := N + 484; -- GNAT + Name_Version : constant Name_Id := N + 485; + Name_Wchar_T_Size : constant Name_Id := N + 486; -- GNAT + Name_Wide_Wide_Width : constant Name_Id := N + 487; -- Ada 05 + Name_Wide_Width : constant Name_Id := N + 488; + Name_Width : constant Name_Id := N + 489; + Name_Word_Size : constant Name_Id := N + 490; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value and that -- have non-universal arguments. - First_Renamable_Function_Attribute : constant Name_Id := N + 494; - Name_Adjacent : constant Name_Id := N + 494; - Name_Ceiling : constant Name_Id := N + 495; - Name_Copy_Sign : constant Name_Id := N + 496; - Name_Floor : constant Name_Id := N + 497; - Name_Fraction : constant Name_Id := N + 498; - Name_Image : constant Name_Id := N + 499; - Name_Input : constant Name_Id := N + 500; - Name_Machine : constant Name_Id := N + 501; - Name_Max : constant Name_Id := N + 502; - Name_Min : constant Name_Id := N + 503; - Name_Model : constant Name_Id := N + 504; - Name_Pred : constant Name_Id := N + 505; - Name_Remainder : constant Name_Id := N + 506; - Name_Rounding : constant Name_Id := N + 507; - Name_Succ : constant Name_Id := N + 508; - Name_Truncation : constant Name_Id := N + 509; + First_Renamable_Function_Attribute : constant Name_Id := N + 491; + Name_Adjacent : constant Name_Id := N + 491; + Name_Ceiling : constant Name_Id := N + 492; + Name_Copy_Sign : constant Name_Id := N + 493; + Name_Floor : constant Name_Id := N + 494; + Name_Fraction : constant Name_Id := N + 495; + Name_From_Any : constant Name_Id := N + 496; -- GNAT + Name_Image : constant Name_Id := N + 497; + Name_Input : constant Name_Id := N + 498; + Name_Machine : constant Name_Id := N + 499; + Name_Max : constant Name_Id := N + 500; + Name_Min : constant Name_Id := N + 501; + Name_Model : constant Name_Id := N + 502; + Name_Pred : constant Name_Id := N + 503; + Name_Remainder : constant Name_Id := N + 504; + Name_Rounding : constant Name_Id := N + 505; + Name_Succ : constant Name_Id := N + 506; + Name_To_Any : constant Name_Id := N + 507; -- GNAT + Name_Truncation : constant Name_Id := N + 508; + Name_TypeCode : constant Name_Id := N + 509; -- GNAT Name_Value : constant Name_Id := N + 510; Name_Wide_Image : constant Name_Id := N + 511; Name_Wide_Wide_Image : constant Name_Id := N + 512; @@ -1048,105 +1051,107 @@ package Snames is Name_Extends : constant Name_Id := N + 666; Name_Externally_Built : constant Name_Id := N + 667; Name_Finder : constant Name_Id := N + 668; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 669; - Name_Global_Config_File : constant Name_Id := N + 670; - Name_Gnatls : constant Name_Id := N + 671; - Name_Gnatstub : constant Name_Id := N + 672; - Name_Implementation : constant Name_Id := N + 673; - Name_Implementation_Exceptions : constant Name_Id := N + 674; - Name_Implementation_Suffix : constant Name_Id := N + 675; - Name_Include_Switches : constant Name_Id := N + 676; - Name_Include_Path : constant Name_Id := N + 677; - Name_Include_Path_File : constant Name_Id := N + 678; - Name_Inherit_Source_Path : constant Name_Id := N + 679; - Name_Language_Kind : constant Name_Id := N + 680; - Name_Language_Processing : constant Name_Id := N + 681; - Name_Languages : constant Name_Id := N + 682; - Name_Library : constant Name_Id := N + 683; - Name_Library_Ali_Dir : constant Name_Id := N + 684; - Name_Library_Auto_Init : constant Name_Id := N + 685; - Name_Library_Auto_Init_Supported : constant Name_Id := N + 686; - Name_Library_Builder : constant Name_Id := N + 687; - Name_Library_Dir : constant Name_Id := N + 688; - Name_Library_GCC : constant Name_Id := N + 689; - Name_Library_Interface : constant Name_Id := N + 690; - Name_Library_Kind : constant Name_Id := N + 691; - Name_Library_Name : constant Name_Id := N + 692; - Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 693; - Name_Library_Options : constant Name_Id := N + 694; - Name_Library_Partial_Linker : constant Name_Id := N + 695; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 696; - Name_Library_Src_Dir : constant Name_Id := N + 697; - Name_Library_Support : constant Name_Id := N + 698; - Name_Library_Symbol_File : constant Name_Id := N + 699; - Name_Library_Symbol_Policy : constant Name_Id := N + 700; - Name_Library_Version : constant Name_Id := N + 701; - Name_Library_Version_Switches : constant Name_Id := N + 702; - Name_Linker : constant Name_Id := N + 703; - Name_Linker_Executable_Option : constant Name_Id := N + 704; - Name_Linker_Lib_Dir_Option : constant Name_Id := N + 705; - Name_Linker_Lib_Name_Option : constant Name_Id := N + 706; - Name_Local_Config_File : constant Name_Id := N + 707; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 708; - Name_Locally_Removed_Files : constant Name_Id := N + 709; - Name_Map_File_Option : constant Name_Id := N + 710; - Name_Mapping_File_Switches : constant Name_Id := N + 711; - Name_Mapping_Spec_Suffix : constant Name_Id := N + 712; - Name_Mapping_Body_Suffix : constant Name_Id := N + 713; - Name_Metrics : constant Name_Id := N + 714; - Name_Naming : constant Name_Id := N + 715; - Name_Object_Generated : constant Name_Id := N + 716; - Name_Objects_Linked : constant Name_Id := N + 717; - Name_Objects_Path : constant Name_Id := N + 718; - Name_Objects_Path_File : constant Name_Id := N + 719; - Name_Object_Dir : constant Name_Id := N + 720; - Name_Pic_Option : constant Name_Id := N + 721; - Name_Pretty_Printer : constant Name_Id := N + 722; - Name_Prefix : constant Name_Id := N + 723; - Name_Project : constant Name_Id := N + 724; - Name_Roots : constant Name_Id := N + 725; - Name_Required_Switches : constant Name_Id := N + 726; - Name_Run_Path_Option : constant Name_Id := N + 727; - Name_Runtime_Project : constant Name_Id := N + 728; - Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 729; - Name_Shared_Library_Prefix : constant Name_Id := N + 730; - Name_Shared_Library_Suffix : constant Name_Id := N + 731; - Name_Separate_Suffix : constant Name_Id := N + 732; - Name_Source_Dirs : constant Name_Id := N + 733; - Name_Source_Files : constant Name_Id := N + 734; - Name_Source_List_File : constant Name_Id := N + 735; - Name_Spec : constant Name_Id := N + 736; - Name_Spec_Suffix : constant Name_Id := N + 737; - Name_Specification : constant Name_Id := N + 738; - Name_Specification_Exceptions : constant Name_Id := N + 739; - Name_Specification_Suffix : constant Name_Id := N + 740; - Name_Stack : constant Name_Id := N + 741; - Name_Switches : constant Name_Id := N + 742; - Name_Symbolic_Link_Supported : constant Name_Id := N + 743; - Name_Sync : constant Name_Id := N + 744; - Name_Synchronize : constant Name_Id := N + 745; - Name_Toolchain_Description : constant Name_Id := N + 746; - Name_Toolchain_Version : constant Name_Id := N + 747; - Name_Runtime_Library_Dir : constant Name_Id := N + 748; + Name_Global_Compilation_Switches : constant Name_Id := N + 669; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 670; + Name_Global_Config_File : constant Name_Id := N + 671; + Name_Gnatls : constant Name_Id := N + 672; + Name_Gnatstub : constant Name_Id := N + 673; + Name_Implementation : constant Name_Id := N + 674; + Name_Implementation_Exceptions : constant Name_Id := N + 675; + Name_Implementation_Suffix : constant Name_Id := N + 676; + Name_Include_Switches : constant Name_Id := N + 677; + Name_Include_Path : constant Name_Id := N + 678; + Name_Include_Path_File : constant Name_Id := N + 679; + Name_Inherit_Source_Path : constant Name_Id := N + 680; + Name_Language_Kind : constant Name_Id := N + 681; + Name_Language_Processing : constant Name_Id := N + 682; + Name_Languages : constant Name_Id := N + 683; + Name_Library : constant Name_Id := N + 684; + Name_Library_Ali_Dir : constant Name_Id := N + 685; + Name_Library_Auto_Init : constant Name_Id := N + 686; + Name_Library_Auto_Init_Supported : constant Name_Id := N + 687; + Name_Library_Builder : constant Name_Id := N + 688; + Name_Library_Dir : constant Name_Id := N + 689; + Name_Library_GCC : constant Name_Id := N + 690; + Name_Library_Interface : constant Name_Id := N + 691; + Name_Library_Kind : constant Name_Id := N + 692; + Name_Library_Name : constant Name_Id := N + 693; + Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 694; + Name_Library_Options : constant Name_Id := N + 695; + Name_Library_Partial_Linker : constant Name_Id := N + 696; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 697; + Name_Library_Src_Dir : constant Name_Id := N + 698; + Name_Library_Support : constant Name_Id := N + 699; + Name_Library_Symbol_File : constant Name_Id := N + 700; + Name_Library_Symbol_Policy : constant Name_Id := N + 701; + Name_Library_Version : constant Name_Id := N + 702; + Name_Library_Version_Switches : constant Name_Id := N + 703; + Name_Linker : constant Name_Id := N + 704; + Name_Linker_Executable_Option : constant Name_Id := N + 705; + Name_Linker_Lib_Dir_Option : constant Name_Id := N + 706; + Name_Linker_Lib_Name_Option : constant Name_Id := N + 707; + Name_Local_Config_File : constant Name_Id := N + 708; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 709; + Name_Locally_Removed_Files : constant Name_Id := N + 710; + Name_Map_File_Option : constant Name_Id := N + 711; + Name_Mapping_File_Switches : constant Name_Id := N + 712; + Name_Mapping_Spec_Suffix : constant Name_Id := N + 713; + Name_Mapping_Body_Suffix : constant Name_Id := N + 714; + Name_Metrics : constant Name_Id := N + 715; + Name_Naming : constant Name_Id := N + 716; + Name_Object_Generated : constant Name_Id := N + 717; + Name_Objects_Linked : constant Name_Id := N + 718; + Name_Objects_Path : constant Name_Id := N + 719; + Name_Objects_Path_File : constant Name_Id := N + 720; + Name_Object_Dir : constant Name_Id := N + 721; + Name_Path_Syntax : constant Name_Id := N + 722; + Name_Pic_Option : constant Name_Id := N + 723; + Name_Pretty_Printer : constant Name_Id := N + 724; + Name_Prefix : constant Name_Id := N + 725; + Name_Project : constant Name_Id := N + 726; + Name_Roots : constant Name_Id := N + 727; + Name_Required_Switches : constant Name_Id := N + 728; + Name_Run_Path_Option : constant Name_Id := N + 729; + Name_Runtime_Project : constant Name_Id := N + 730; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 731; + Name_Shared_Library_Prefix : constant Name_Id := N + 732; + Name_Shared_Library_Suffix : constant Name_Id := N + 733; + Name_Separate_Suffix : constant Name_Id := N + 734; + Name_Source_Dirs : constant Name_Id := N + 735; + Name_Source_Files : constant Name_Id := N + 736; + Name_Source_List_File : constant Name_Id := N + 737; + Name_Spec : constant Name_Id := N + 738; + Name_Spec_Suffix : constant Name_Id := N + 739; + Name_Specification : constant Name_Id := N + 740; + Name_Specification_Exceptions : constant Name_Id := N + 741; + Name_Specification_Suffix : constant Name_Id := N + 742; + Name_Stack : constant Name_Id := N + 743; + Name_Switches : constant Name_Id := N + 744; + Name_Symbolic_Link_Supported : constant Name_Id := N + 745; + Name_Sync : constant Name_Id := N + 746; + Name_Synchronize : constant Name_Id := N + 747; + Name_Toolchain_Description : constant Name_Id := N + 748; + Name_Toolchain_Version : constant Name_Id := N + 749; + Name_Runtime_Library_Dir : constant Name_Id := N + 750; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 749; + Name_Unaligned_Valid : constant Name_Id := N + 751; -- Ada 2005 reserved words - First_2005_Reserved_Word : constant Name_Id := N + 750; - Name_Interface : constant Name_Id := N + 750; - Name_Overriding : constant Name_Id := N + 751; - Name_Synchronized : constant Name_Id := N + 752; - Last_2005_Reserved_Word : constant Name_Id := N + 752; + First_2005_Reserved_Word : constant Name_Id := N + 752; + Name_Interface : constant Name_Id := N + 752; + Name_Overriding : constant Name_Id := N + 753; + Name_Synchronized : constant Name_Id := N + 754; + Last_2005_Reserved_Word : constant Name_Id := N + 754; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 752; + Last_Predefined_Name : constant Name_Id := N + 754; --------------------------------------- -- Subtypes Defining Name Categories -- @@ -1286,6 +1291,7 @@ package Snames is Attribute_Copy_Sign, Attribute_Floor, Attribute_Fraction, + Attribute_From_Any, Attribute_Image, Attribute_Input, Attribute_Machine, @@ -1296,7 +1302,9 @@ package Snames is Attribute_Remainder, Attribute_Rounding, Attribute_Succ, + Attribute_To_Any, Attribute_Truncation, + Attribute_TypeCode, Attribute_Value, Attribute_Wide_Image, Attribute_Wide_Wide_Image, @@ -1387,7 +1395,6 @@ package Snames is Pragma_Ada_2005, Pragma_Assertion_Policy, Pragma_C_Pass_By_Copy, - Pragma_Canonical_Streams, Pragma_Check_Name, Pragma_Check_Policy, Pragma_Compile_Time_Error, diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 5c52b59ac57..8f1367f7184 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -164,31 +164,34 @@ extern unsigned char Get_Attribute_Id (int); #define Attr_Copy_Sign 117 #define Attr_Floor 118 #define Attr_Fraction 119 -#define Attr_Image 120 -#define Attr_Input 121 -#define Attr_Machine 122 -#define Attr_Max 123 -#define Attr_Min 124 -#define Attr_Model 125 -#define Attr_Pred 126 -#define Attr_Remainder 127 -#define Attr_Rounding 128 -#define Attr_Succ 129 -#define Attr_Truncation 130 -#define Attr_Value 131 -#define Attr_Wide_Image 132 -#define Attr_Wide_Wide_Image 133 -#define Attr_Wide_Value 134 -#define Attr_Wide_Wide_Value 135 -#define Attr_Output 136 -#define Attr_Read 137 -#define Attr_Write 138 -#define Attr_Elab_Body 139 -#define Attr_Elab_Spec 140 -#define Attr_Storage_Pool 141 -#define Attr_Base 142 -#define Attr_Class 143 -#define Attr_Stub_Type 144 +#define Attr_From_Any 120 +#define Attr_Image 121 +#define Attr_Input 122 +#define Attr_Machine 123 +#define Attr_Max 124 +#define Attr_Min 125 +#define Attr_Model 126 +#define Attr_Pred 127 +#define Attr_Remainder 128 +#define Attr_Rounding 129 +#define Attr_Succ 130 +#define Attr_To_Any 131 +#define Attr_Truncation 132 +#define Attr_TypeCode 133 +#define Attr_Value 134 +#define Attr_Wide_Image 135 +#define Attr_Wide_Wide_Image 136 +#define Attr_Wide_Value 137 +#define Attr_Wide_Wide_Value 138 +#define Attr_Output 139 +#define Attr_Read 140 +#define Attr_Write 141 +#define Attr_Elab_Body 142 +#define Attr_Elab_Spec 143 +#define Attr_Storage_Pool 144 +#define Attr_Base 145 +#define Attr_Class 146 +#define Attr_Stub_Type 147 /* Define the numeric values for the conventions. */ @@ -227,170 +230,169 @@ extern unsigned char Get_Pragma_Id (int); #define Pragma_Ada_2005 3 #define Pragma_Assertion_Policy 4 #define Pragma_C_Pass_By_Copy 5 -#define Pragma_Canonical_Streams 6 -#define Pragma_Check_Name 7 -#define Pragma_Check_Policy 8 -#define Pragma_Compile_Time_Error 9 -#define Pragma_Compile_Time_Warning 10 -#define Pragma_Compiler_Unit 11 -#define Pragma_Component_Alignment 12 -#define Pragma_Convention_Identifier 13 -#define Pragma_Debug_Policy 14 -#define Pragma_Detect_Blocking 15 -#define Pragma_Discard_Names 16 -#define Pragma_Elaboration_Checks 17 -#define Pragma_Eliminate 18 -#define Pragma_Extend_System 19 -#define Pragma_Extensions_Allowed 20 -#define Pragma_External_Name_Casing 21 -#define Pragma_Favor_Top_Level 22 -#define Pragma_Float_Representation 23 -#define Pragma_Implicit_Packing 24 -#define Pragma_Initialize_Scalars 25 -#define Pragma_Interrupt_State 26 -#define Pragma_License 27 -#define Pragma_Locking_Policy 28 -#define Pragma_Long_Float 29 -#define Pragma_No_Run_Time 30 -#define Pragma_No_Strict_Aliasing 31 -#define Pragma_Normalize_Scalars 32 -#define Pragma_Optimize_Alignment 33 -#define Pragma_Persistent_BSS 34 -#define Pragma_Polling 35 -#define Pragma_Priority_Specific_Dispatching 36 -#define Pragma_Profile 37 -#define Pragma_Profile_Warnings 38 -#define Pragma_Propagate_Exceptions 39 -#define Pragma_Queuing_Policy 40 -#define Pragma_Ravenscar 41 -#define Pragma_Restricted_Run_Time 42 -#define Pragma_Restrictions 43 -#define Pragma_Restriction_Warnings 44 -#define Pragma_Reviewable 45 -#define Pragma_Source_File_Name 46 -#define Pragma_Source_File_Name_Project 47 -#define Pragma_Style_Checks 48 -#define Pragma_Suppress 49 -#define Pragma_Suppress_Exception_Locations 50 -#define Pragma_Task_Dispatching_Policy 51 -#define Pragma_Universal_Data 52 -#define Pragma_Unsuppress 53 -#define Pragma_Use_VADS_Size 54 -#define Pragma_Validity_Checks 55 -#define Pragma_Warnings 56 -#define Pragma_Wide_Character_Encoding 57 -#define Pragma_Abort_Defer 58 -#define Pragma_All_Calls_Remote 59 -#define Pragma_Annotate 60 -#define Pragma_Assert 61 -#define Pragma_Asynchronous 62 -#define Pragma_Atomic 63 -#define Pragma_Atomic_Components 64 -#define Pragma_Attach_Handler 65 -#define Pragma_Check 66 -#define Pragma_CIL_Constructor 67 -#define Pragma_Comment 68 -#define Pragma_Common_Object 69 -#define Pragma_Complete_Representation 70 -#define Pragma_Complex_Representation 71 -#define Pragma_Controlled 72 -#define Pragma_Convention 73 -#define Pragma_CPP_Class 74 -#define Pragma_CPP_Constructor 75 -#define Pragma_CPP_Virtual 76 -#define Pragma_CPP_Vtable 77 -#define Pragma_Debug 78 -#define Pragma_Elaborate 79 -#define Pragma_Elaborate_All 80 -#define Pragma_Elaborate_Body 81 -#define Pragma_Export 82 -#define Pragma_Export_Exception 83 -#define Pragma_Export_Function 84 -#define Pragma_Export_Object 85 -#define Pragma_Export_Procedure 86 -#define Pragma_Export_Value 87 -#define Pragma_Export_Valued_Procedure 88 -#define Pragma_External 89 -#define Pragma_Finalize_Storage_Only 90 -#define Pragma_Ident 91 -#define Pragma_Implemented_By_Entry 92 -#define Pragma_Import 93 -#define Pragma_Import_Exception 94 -#define Pragma_Import_Function 95 -#define Pragma_Import_Object 96 -#define Pragma_Import_Procedure 97 -#define Pragma_Import_Valued_Procedure 98 -#define Pragma_Inline 99 -#define Pragma_Inline_Always 100 -#define Pragma_Inline_Generic 101 -#define Pragma_Inspection_Point 102 -#define Pragma_Interface_Name 103 -#define Pragma_Interrupt_Handler 104 -#define Pragma_Interrupt_Priority 105 -#define Pragma_Java_Constructor 106 -#define Pragma_Java_Interface 107 -#define Pragma_Keep_Names 108 -#define Pragma_Link_With 109 -#define Pragma_Linker_Alias 110 -#define Pragma_Linker_Constructor 111 -#define Pragma_Linker_Destructor 112 -#define Pragma_Linker_Options 113 -#define Pragma_Linker_Section 114 -#define Pragma_List 115 -#define Pragma_Machine_Attribute 116 -#define Pragma_Main 117 -#define Pragma_Main_Storage 118 -#define Pragma_Memory_Size 119 -#define Pragma_No_Body 120 -#define Pragma_No_Return 121 -#define Pragma_Obsolescent 122 -#define Pragma_Optimize 123 -#define Pragma_Pack 124 -#define Pragma_Page 125 -#define Pragma_Passive 126 -#define Pragma_Postcondition 127 -#define Pragma_Precondition 128 -#define Pragma_Preelaborable_Initialization 129 -#define Pragma_Preelaborate 130 -#define Pragma_Preelaborate_05 131 -#define Pragma_Psect_Object 132 -#define Pragma_Pure 133 -#define Pragma_Pure_05 134 -#define Pragma_Pure_Function 135 -#define Pragma_Relative_Deadline 136 -#define Pragma_Remote_Call_Interface 137 -#define Pragma_Remote_Types 138 -#define Pragma_Share_Generic 139 -#define Pragma_Shared 140 -#define Pragma_Shared_Passive 141 -#define Pragma_Source_Reference 142 -#define Pragma_Static_Elaboration_Desired 143 -#define Pragma_Stream_Convert 144 -#define Pragma_Subtitle 145 -#define Pragma_Suppress_All 146 -#define Pragma_Suppress_Debug_Info 147 -#define Pragma_Suppress_Initialization 148 -#define Pragma_System_Name 149 -#define Pragma_Task_Info 150 -#define Pragma_Task_Name 151 -#define Pragma_Task_Storage 152 -#define Pragma_Time_Slice 153 -#define Pragma_Title 154 -#define Pragma_Unchecked_Union 155 -#define Pragma_Unimplemented_Unit 156 -#define Pragma_Universal_Aliasing 157 -#define Pragma_Unmodified 158 -#define Pragma_Unreferenced 159 -#define Pragma_Unreferenced_Objects 160 -#define Pragma_Unreserve_All_Interrupts 161 -#define Pragma_Volatile 162 -#define Pragma_Volatile_Components 163 -#define Pragma_Weak_External 164 -#define Pragma_AST_Entry 165 -#define Pragma_Fast_Math 166 -#define Pragma_Interface 167 -#define Pragma_Priority 168 -#define Pragma_Storage_Size 169 -#define Pragma_Storage_Unit 170 +#define Pragma_Check_Name 6 +#define Pragma_Check_Policy 7 +#define Pragma_Compile_Time_Error 8 +#define Pragma_Compile_Time_Warning 9 +#define Pragma_Compiler_Unit 10 +#define Pragma_Component_Alignment 11 +#define Pragma_Convention_Identifier 12 +#define Pragma_Debug_Policy 13 +#define Pragma_Detect_Blocking 14 +#define Pragma_Discard_Names 15 +#define Pragma_Elaboration_Checks 16 +#define Pragma_Eliminate 17 +#define Pragma_Extend_System 18 +#define Pragma_Extensions_Allowed 19 +#define Pragma_External_Name_Casing 20 +#define Pragma_Favor_Top_Level 21 +#define Pragma_Float_Representation 22 +#define Pragma_Implicit_Packing 23 +#define Pragma_Initialize_Scalars 24 +#define Pragma_Interrupt_State 25 +#define Pragma_License 26 +#define Pragma_Locking_Policy 27 +#define Pragma_Long_Float 28 +#define Pragma_No_Run_Time 29 +#define Pragma_No_Strict_Aliasing 30 +#define Pragma_Normalize_Scalars 31 +#define Pragma_Optimize_Alignment 32 +#define Pragma_Persistent_BSS 33 +#define Pragma_Polling 34 +#define Pragma_Priority_Specific_Dispatching 35 +#define Pragma_Profile 36 +#define Pragma_Profile_Warnings 37 +#define Pragma_Propagate_Exceptions 38 +#define Pragma_Queuing_Policy 39 +#define Pragma_Ravenscar 40 +#define Pragma_Restricted_Run_Time 41 +#define Pragma_Restrictions 42 +#define Pragma_Restriction_Warnings 43 +#define Pragma_Reviewable 44 +#define Pragma_Source_File_Name 45 +#define Pragma_Source_File_Name_Project 46 +#define Pragma_Style_Checks 47 +#define Pragma_Suppress 48 +#define Pragma_Suppress_Exception_Locations 49 +#define Pragma_Task_Dispatching_Policy 50 +#define Pragma_Universal_Data 51 +#define Pragma_Unsuppress 52 +#define Pragma_Use_VADS_Size 53 +#define Pragma_Validity_Checks 54 +#define Pragma_Warnings 55 +#define Pragma_Wide_Character_Encoding 56 +#define Pragma_Abort_Defer 57 +#define Pragma_All_Calls_Remote 58 +#define Pragma_Annotate 59 +#define Pragma_Assert 60 +#define Pragma_Asynchronous 61 +#define Pragma_Atomic 62 +#define Pragma_Atomic_Components 63 +#define Pragma_Attach_Handler 64 +#define Pragma_Check 65 +#define Pragma_CIL_Constructor 66 +#define Pragma_Comment 67 +#define Pragma_Common_Object 68 +#define Pragma_Complete_Representation 69 +#define Pragma_Complex_Representation 70 +#define Pragma_Controlled 71 +#define Pragma_Convention 72 +#define Pragma_CPP_Class 73 +#define Pragma_CPP_Constructor 74 +#define Pragma_CPP_Virtual 75 +#define Pragma_CPP_Vtable 76 +#define Pragma_Debug 77 +#define Pragma_Elaborate 78 +#define Pragma_Elaborate_All 79 +#define Pragma_Elaborate_Body 80 +#define Pragma_Export 81 +#define Pragma_Export_Exception 82 +#define Pragma_Export_Function 83 +#define Pragma_Export_Object 84 +#define Pragma_Export_Procedure 85 +#define Pragma_Export_Value 86 +#define Pragma_Export_Valued_Procedure 87 +#define Pragma_External 88 +#define Pragma_Finalize_Storage_Only 89 +#define Pragma_Ident 90 +#define Pragma_Implemented_By_Entry 91 +#define Pragma_Import 92 +#define Pragma_Import_Exception 93 +#define Pragma_Import_Function 94 +#define Pragma_Import_Object 95 +#define Pragma_Import_Procedure 96 +#define Pragma_Import_Valued_Procedure 97 +#define Pragma_Inline 98 +#define Pragma_Inline_Always 99 +#define Pragma_Inline_Generic 100 +#define Pragma_Inspection_Point 101 +#define Pragma_Interface_Name 102 +#define Pragma_Interrupt_Handler 103 +#define Pragma_Interrupt_Priority 104 +#define Pragma_Java_Constructor 105 +#define Pragma_Java_Interface 106 +#define Pragma_Keep_Names 107 +#define Pragma_Link_With 108 +#define Pragma_Linker_Alias 109 +#define Pragma_Linker_Constructor 110 +#define Pragma_Linker_Destructor 111 +#define Pragma_Linker_Options 112 +#define Pragma_Linker_Section 113 +#define Pragma_List 114 +#define Pragma_Machine_Attribute 115 +#define Pragma_Main 116 +#define Pragma_Main_Storage 117 +#define Pragma_Memory_Size 118 +#define Pragma_No_Body 119 +#define Pragma_No_Return 120 +#define Pragma_Obsolescent 121 +#define Pragma_Optimize 122 +#define Pragma_Pack 123 +#define Pragma_Page 124 +#define Pragma_Passive 125 +#define Pragma_Postcondition 126 +#define Pragma_Precondition 127 +#define Pragma_Preelaborable_Initialization 128 +#define Pragma_Preelaborate 129 +#define Pragma_Preelaborate_05 130 +#define Pragma_Psect_Object 131 +#define Pragma_Pure 132 +#define Pragma_Pure_05 133 +#define Pragma_Pure_Function 134 +#define Pragma_Relative_Deadline 135 +#define Pragma_Remote_Call_Interface 136 +#define Pragma_Remote_Types 137 +#define Pragma_Share_Generic 138 +#define Pragma_Shared 139 +#define Pragma_Shared_Passive 140 +#define Pragma_Source_Reference 141 +#define Pragma_Static_Elaboration_Desired 142 +#define Pragma_Stream_Convert 143 +#define Pragma_Subtitle 144 +#define Pragma_Suppress_All 145 +#define Pragma_Suppress_Debug_Info 146 +#define Pragma_Suppress_Initialization 147 +#define Pragma_System_Name 148 +#define Pragma_Task_Info 149 +#define Pragma_Task_Name 150 +#define Pragma_Task_Storage 151 +#define Pragma_Time_Slice 152 +#define Pragma_Title 153 +#define Pragma_Unchecked_Union 154 +#define Pragma_Unimplemented_Unit 155 +#define Pragma_Universal_Aliasing 156 +#define Pragma_Unmodified 157 +#define Pragma_Unreferenced 158 +#define Pragma_Unreferenced_Objects 159 +#define Pragma_Unreserve_All_Interrupts 160 +#define Pragma_Volatile 161 +#define Pragma_Volatile_Components 162 +#define Pragma_Weak_External 163 +#define Pragma_AST_Entry 164 +#define Pragma_Fast_Math 165 +#define Pragma_Interface 166 +#define Pragma_Priority 167 +#define Pragma_Storage_Size 168 +#define Pragma_Storage_Unit 169 /* End of snames.h (C version of Snames package spec) */ diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index cf59c8198cd..63a1a6d83aa 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -371,6 +371,16 @@ package body Switch.C is Full_Path_Name_For_Brief_Errors := True; return; + -- -gnateG (save preprocessor output) + + when 'G' => + if Ptr < Max then + Bad_Switch (Switch_Chars); + end if; + + Generate_Processed_File := True; + Ptr := Ptr + 1; + -- -gnateI (index of unit in multi-unit source) when 'I' => diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 20761f417cd..7be075d9896 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -267,14 +267,16 @@ package body Switch.M is when 'e' => - -- Only -gnateD and -gnatep= need storing in ALI file + -- Store -gnateD, -gnatep= and -gnateG in the ALI file. + -- The other -gnate switches do not need to be stored. Storing (First_Stored) := 'e'; Ptr := Ptr + 1; if Ptr > Max or else (Switch_Chars (Ptr) /= 'D' - and then Switch_Chars (Ptr) /= 'p') + and then Switch_Chars (Ptr) /= 'G' + and then Switch_Chars (Ptr) /= 'p') then Last := 0; return; @@ -292,7 +294,7 @@ package body Switch.M is -- Processing for -gnatep= - else + elsif Switch_Chars (Ptr) = 'p' then Ptr := Ptr + 1; if Ptr = Max then @@ -316,6 +318,9 @@ package body Switch.M is Switch_Chars (Ptr .. Max); Add_Switch_Component (To_Store); end; + + elsif Switch_Chars (Ptr) = 'G' then + Add_Switch_Component ("-gnateG"); end if; return; diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads index 04cdbbcf94f..1b846813d4b 100644 --- a/gcc/ada/system-darwin-x86.ads +++ b/gcc/ada/system-darwin-x86.ads @@ -51,7 +51,7 @@ package System is Max_Int : constant := Long_Long_Integer'Last; Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/system-mingw-x86_64.ads b/gcc/ada/system-mingw-x86_64.ads new file mode 100644 index 00000000000..332b283b0a0 --- /dev/null +++ b/gcc/ada/system-mingw-x86_64.ads @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Windows Version) -- +-- -- +-- Copyright (C) 1992-2008, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + --------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + (Priority'First .. + Default_Priority - 8 => -15, + Default_Priority - 7 => -7, + Default_Priority - 6 => -6, + Default_Priority - 5 => -5, + Default_Priority - 4 => -4, + Default_Priority - 3 => -3, + Default_Priority - 2 => -2, + Default_Priority - 1 => -1, + Default_Priority => 0, + Default_Priority + 1 => 1, + Default_Priority + 2 => 2, + Default_Priority + 3 => 3, + Default_Priority + 4 => 4, + Default_Priority + 5 => 5, + Default_Priority + 6 .. + Priority'Last => 6, + Interrupt_Priority => 15); + -- The default mapping preserves the standard 31 priorities of the Ada + -- model, but maps them using compression onto the 7 priority levels + -- available in NT and on the 16 priority levels available in 2000/XP. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile using Makefile.adalib + -- which can be found under the adalib directory of your gnat installation + + pragma Linker_Options ("-Wl,--stack=0x2000000"); + -- This is used to change the default stack (32 MB) size for non tasking + -- programs. We change this value for GNAT on Windows here because the + -- binutils on this platform have switched to a too low value for Ada + -- programs. Note that we also set the stack size for tasking programs in + -- System.Task_Primitives.Operations. + +end System; diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index b3ddd631946..4f25eda7462 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -498,7 +498,7 @@ package body Tbuild is Get_Name_String (Related_Id); if Prefix /= ' ' then - pragma Assert (Is_OK_Internal_Letter (Prefix)); + pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_'); for J in reverse 1 .. Name_Len loop Name_Buffer (J + 1) := Name_Buffer (J); diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index a25cfae44fa..5fb53ae339e 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -531,17 +531,44 @@ package body Treepr is begin case M is - when Default_Mechanism => Write_Str ("Default"); - when By_Copy => Write_Str ("By_Copy"); - when By_Reference => Write_Str ("By_Reference"); - when By_Descriptor => Write_Str ("By_Descriptor"); - when By_Descriptor_UBS => Write_Str ("By_Descriptor_UBS"); - when By_Descriptor_UBSB => Write_Str ("By_Descriptor_UBSB"); - when By_Descriptor_UBA => Write_Str ("By_Descriptor_UBA"); - when By_Descriptor_S => Write_Str ("By_Descriptor_S"); - when By_Descriptor_SB => Write_Str ("By_Descriptor_SB"); - when By_Descriptor_A => Write_Str ("By_Descriptor_A"); - when By_Descriptor_NCA => Write_Str ("By_Descriptor_NCA"); + when Default_Mechanism + => Write_Str ("Default"); + when By_Copy + => Write_Str ("By_Copy"); + when By_Reference + => Write_Str ("By_Reference"); + when By_Descriptor + => Write_Str ("By_Descriptor"); + when By_Descriptor_UBS + => Write_Str ("By_Descriptor_UBS"); + when By_Descriptor_UBSB + => Write_Str ("By_Descriptor_UBSB"); + when By_Descriptor_UBA + => Write_Str ("By_Descriptor_UBA"); + when By_Descriptor_S + => Write_Str ("By_Descriptor_S"); + when By_Descriptor_SB + => Write_Str ("By_Descriptor_SB"); + when By_Descriptor_A + => Write_Str ("By_Descriptor_A"); + when By_Descriptor_NCA + => Write_Str ("By_Descriptor_NCA"); + when By_Short_Descriptor + => Write_Str ("By_Short_Descriptor"); + when By_Short_Descriptor_UBS + => Write_Str ("By_Short_Descriptor_UBS"); + when By_Short_Descriptor_UBSB + => Write_Str ("By_Short_Descriptor_UBSB"); + when By_Short_Descriptor_UBA + => Write_Str ("By_Short_Descriptor_UBA"); + when By_Short_Descriptor_S + => Write_Str ("By_Short_Descriptor_S"); + when By_Short_Descriptor_SB + => Write_Str ("By_Short_Descriptor_SB"); + when By_Short_Descriptor_A + => Write_Str ("By_Short_Descriptor_A"); + when By_Short_Descriptor_NCA + => Write_Str ("By_Short_Descriptor_NCA"); when 1 .. Mechanism_Type'Last => Write_Str ("By_Copy if size <= "); diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 9b4bfb825e4..de9c54bfe5f 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -736,7 +736,7 @@ package Types is -- passing mechanism. See specification of Sem_Mech for full details. -- The following subtype is used to represent values of this type: - subtype Mechanism_Type is Int range -10 .. Int'Last; + subtype Mechanism_Type is Int range -18 .. Int'Last; -- Type used to represent a mechanism value. This is a subtype rather -- than a type to avoid some annoying processing problems with certain -- routines in Einfo (processing them to create the corresponding C). diff --git a/gcc/ada/types.h b/gcc/ada/types.h index fb218c203a6..1d4fd67065b 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -328,6 +328,15 @@ typedef Int Mechanism_Type; #define By_Descriptor_A (-9) #define By_Descriptor_NCA (-10) #define By_Descriptor_Last (-10) +#define By_Short_Descriptor (-11) +#define By_Short_Descriptor_UBS (-12) +#define By_Short_Descriptor_UBSB (-13) +#define By_Short_Descriptor_UBA (-14) +#define By_Short_Descriptor_S (-15) +#define By_Short_Descriptor_SB (-16) +#define By_Short_Descriptor_A (-17) +#define By_Short_Descriptor_NCA (-18) +#define By_Short_Descriptor_Last (-18) /* Internal to Gigi. */ #define By_Copy_Return (-128) diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 7f8e9577e86..2cab6da2dea 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -61,6 +61,7 @@ gcc -c ^ GNAT COMPILE -gnatec ^ /CONFIGURATION_PRAGMAS_FILE -gnateD ^ /SYMBOL_PREPROCESSING -gnatef ^ /FULL_PATH_IN_BRIEF_MESSAGES +-gnateG ^ /GENERATE_PROCESSED_SOURCE -gnatem ^ /MAPPING_FILE -gnatep ^ /DATA_PREPROCESSING -gnatE ^ /CHECKS=ELABORATION diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 5a1f4827eab..e4a9446ef2c 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -167,6 +167,11 @@ begin Write_Switch_Char ("ef"); Write_Line ("Full source path in brief error messages"); + -- Line for -gnateG switch + + Write_Switch_Char ("eG"); + Write_Line ("Generate preprocessed source"); + -- Line for -gnateI switch Write_Switch_Char ("eInn"); @@ -450,10 +455,10 @@ begin Write_Line (" .X* turn off warnings for non-local exceptions"); Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); - Write_Line (" z* turn on convention/size/align warnings for " & - "unchecked conversion"); - Write_Line (" Z turn off convention/size/align warnings for " & - "unchecked conversion"); + Write_Line (" z* turn on warnings for convention/size/align " & + "mismatch on unchecked conversion"); + Write_Line (" Z turn off warnings for convention/size/align " & + "mismatch on unchecked conversion"); Write_Line (" * indicates default in above list"); -- Line for -gnatW switch diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 3270e8f55b5..63ba1df8d05 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1526,6 +1526,14 @@ package VMS_Data is -- /VERBOSE), then error lines start with the full path name of the -- project file, rather than its simple file name. + S_GCC_Generate : aliased constant S := "/GENERATE_PROCESSED_SOURCE " & + "-gnateG"; + -- /NOGENERATE_PROCESSED_SOURCE (D) + -- /GENERATE_PROCESSED_SOURCE + -- + -- Generate a file <source>_prep if the integrated preprocessing + -- is modifying the source text. + S_GCC_GNAT : aliased constant S := "/GNAT_INTERNAL " & "-gnatg"; -- /NOGNAT_INTERNAL (D) @@ -1745,6 +1753,15 @@ package VMS_Data is -- a body is compiled, the corresponding spec is also listed, along -- with any subunits. + S_GCC_Machine : aliased constant S := "/MACHINE_CODE_LISTING " & + "-source-listing"; + -- /NOMACHINE_CODE_LISTING (D) + -- /MACHINE_CODE_LISTING + -- + -- Cause a full machine code listing of the file to be generated to + -- <filename>.lis. Interspersed source is included if the /DEBUG + -- qualifier is also present. + S_GCC_Mapping : aliased constant S := "/MAPPING_FILE=<" & "-gnatem>"; -- /MAPPING_FILE=file_name @@ -3302,6 +3319,7 @@ package VMS_Data is S_GCC_Follow 'Access, S_GCC_Force 'Access, S_GCC_Full 'Access, + S_GCC_Generate'Access, S_GCC_GNAT 'Access, S_GCC_Help 'Access, S_GCC_Ident 'Access, @@ -3316,6 +3334,7 @@ package VMS_Data is S_GCC_Length 'Access, S_GCC_List 'Access, S_GCC_Output 'Access, + S_GCC_Machine 'Access, S_GCC_Mapping 'Access, S_GCC_Mess 'Access, S_GCC_Nesting 'Access, diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index b09cc70e773..116f364bea1 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -903,7 +903,6 @@ package body Xref_Lib is P_Line, P_Column : Natural; pragma Warnings (Off, P_Line); pragma Warnings (Off, P_Column); - begin Ptr := Ptr + 1; Parse_Number (Ali, Ptr, P_Line); |