diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-05-07 11:53:17 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-05-07 11:53:17 +0000 |
| commit | c789d03839a7a90a88e0ca6758788263fc8524cb (patch) | |
| tree | ba0a466bb52ca32720ca9abc6b47333977f626e2 /gcc/ada | |
| parent | d87dd2579cf376a08bfa49a61f805ef153721aee (diff) | |
| download | gcc-c789d03839a7a90a88e0ca6758788263fc8524cb.tar.gz | |
2009-05-07 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk r147228
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@147231 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
109 files changed, 2510 insertions, 901 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c11325e1197..473d8f37bbe 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,383 @@ +2009-05-07 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies + +2009-05-06 Laurent GUERBY <laurent@guerby.net> + + * s-linux.ads, s-linux-alpha.ads, s-linux-hppa.ads, + osinte-linux.ads: Define sa_handler_pos. + * s-osinte-linux.ads: Use it. + * s-linux-mipsel.ads: New. + * system-linux-mips64el.ads: New. + * gcc-interface/Makefile.in: Multilib handling for + mipsel-linux and mips64el-linux. + +2009-05-06 Arnaud Charlet <charlet@adacore.com> + + * exp_ch5.adb, exp_util.adb, exp_attr.adb, sem_util.adb, sem_res.adb, + targparm.adb, targparm.ads, exp_ch4.adb, exp_ch6.adb, exp_disp.adb, + opt.ads, exp_aggr.adb, exp_intr.adb, sem_disp.adb, exp_ch3.adb + (Tagged_Type_Expansion): New flag. + Replace use of VM_Target related to tagged types expansion by + Tagged_Type_Expansion, since tagged type expansion is not necessarily + linked to VM targets. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * sem_attr.adb: Add processing for Standard'Compiler_Version + + * sinput.adb (Expr_Last_Char): Fix some copy-paste errors for paren + skipping. + (Expr_First_Char): Add ??? comment that paren skipping needs work + (Expr_Last_Char): Add ??? comment that paren skipping needs work + + * exp_attr.adb: Add processing for Compiler_Version + + * sem_attr.adb: New attribute Compiler_Version + + * snames.ads-tmpl: Add entries for Compiler_Version attribute + + * gnat_rm.texi: Document Compiler_Version attribute + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * errout.adb: Minor reformatting + + * scng.adb, sem_prag.adb, par-ch4.adb, sem_res.adb, par-ch6.adb, + sem_ch6.adb, par-prag.adb, sem_ch8.adb, sem_warn.adb, par-util.adb, + styleg.adb: Add stylized comments to error messages that are included + in the codefix circuitry of IDE's such as GPS. + +2009-05-06 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: For Misnamed_Identifiers rule all description of the + new form of the rule parameter that allows to specify the suffix for + access-to-access type names. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * sem_warn.adb (Warn_On_Useless_Assignment): Avoid false negative for + out parameter assigned when exception handlers are present. + + * sem_ch5.adb (Analyze_Exit_Statement): Kill current value last + assignments on exit. + + * par-ch9.adb, sem_aggr.adb, par-endh.adb, sem_res.adb, par-ch6.adb, + sinput-l.adb, par-load.adb, errout.ads, sem_ch4.adb, lib-load.adb, + prj-dect.adb, par-ch12.adb, sem_ch8.adb, par-util.adb, par-ch3.adb, + par-tchk.adb, par-ch5.adb: This patch adds stylized comments to error + messages that are included in the codefix circuitry of IDE's such as + GPS. + + * sinput.ads, sinput.adb (Expr_First_Char): New function + (Expr_Last_Char): New function + +2009-05-06 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Add subsection for Exits_From_Conditional_Loops rule + Add formal definition for extra exit point metric + +2009-05-06 Pascal Obry <obry@adacore.com> + + * adaint.c: Support for setting attributes on unicode filename on + Windows. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * sem_warn.adb: Minor reformatting + +2009-05-06 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb (Process_Import_Or_Interface): Imported CPP types must + not have discriminants or components with default expressions. + (Analyze_Pragma): For pragma CPP_Class check that imported types + have no discriminants and components have no default expression. + + * sem_aggr.adb (Resolve_Aggr_Expr): Add missing check on wrong use of + class-wide types in the expression of a record component association. + +2009-05-06 Sergey Rybin <rybin@adacore.com> + + * vms_data.ads: Add qualifier for gnatmetric extra exit points metric + + * gnat_ugn.texi: Add description for the new extra exit points metric + (gnatmetric section). + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * s-fileio.adb: Minor comment update + + * sem_ch8.adb: Minor reformatting + + * exp_ch3.adb: Update comments. + +2009-05-06 Tristan Gingold <gingold@adacore.com> + + * init.c, s-osinte-darwin.ads: Reduce alternate stack size + +2009-05-06 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in: Update LIBGNAT_TARGET_PAIRS for Xenomai. + Fix missing unit for rtp-smp runtime on both ppc and x86 vxworks + + * gcc-interface/Make-lang.in: Update dependencies + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): Revert previous + change. The context clause of a generic instance declaration must be + preserved until the end of the compilation, because it may have to be + installed/removed repeatedly. + The latest change to sem.adb ensures that the context of both spec and + body of an instance is traversed before the instance itself, making + this patch redundant. + +2009-05-06 Gary Dismukes <dismukes@adacore.com> + + * sem_aggr.adb: Fix typo. + +2009-05-06 Thomas Quinot <quinot@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): For a controlled object + declaration, do not adjust if the declaration is to be rewritten into + a renaming. + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Find_Type): Reject the use of a task type in its own + discriminant part. + +2009-05-06 Bob Duff <duff@adacore.com> + + * s-fileio.adb (File_IO_Clean_Up_Type): Make this type limited, since + otherwise the compiler would be allowed to optimize away the cleanup + code. + +2009-05-06 Gary Dismukes <dismukes@adacore.com> + + * gnat_ugn.texi: Fix typo. + +2009-05-06 Thomas Quinot <quinot@adacore.com> + + * g-debuti.adb: Minor reformatting + + * exp_attr.adb: Minor reformatting + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * sem_aggr.adb: Minor reformatting. + + * g-socthi-vms.adb: Minor reformatting + +2009-05-06 Bob Duff <duff@adacore.com> + + * g-table.ads, g-table.adb, g-dyntab.ads, g-dyntab.adb: + (Append_All): Add Append_All to g-table and g-dyntab, similar to table. + +2009-05-06 Bob Duff <duff@adacore.com> + + * gnat_ugn.texi, gnat_rm.texi: Add missing documentation for warnings + flags. + +2009-05-06 Javier Miranda <miranda@adacore.com> + + * sem_aggr.adb (Valid_Ancestor_Type): Add support for C++ constructors. + (Resolve_Extension_Aggregate): Do not reject C++ constructors in + extension aggregates. + (Resolve_Record_Aggregate): Add support for C++ constructors in + extension aggregates. + + * exp_aggr.adb (Build_Record_Aggr_Code): Add support for C++ + constructors in extension aggregates. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Record_Type): Improve error msg for bad size + clause. + +2009-05-06 Thomas Quinot <quinot@adacore.com> + + * g-socthi-vms.adb (C_Recvmsg, C_Sendmsg): Convert Msg to appropriate + packed type, since on OpenVMS, struct msghdr is packed. + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Analyze_Object_Renaming): If the object is a function + call returning an unconstrained composite value, create the proper + subtype for it, as is done for object dclarations with unconstrained + nominal subtypes. Perform this transformation regarless of whether + call comes from source. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Record_Type): Implement Implicit_Packing for + records + + * gnat_rm.texi: + Add documentation for pragma Implicit_Packing applied to record + types. + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem.adb (Walk_Library_Items): Place all with_clauses of an + instantiation on the spec, because late instance bodies may generate + with_clauses for the instance body but are inserted in the instance + spec. + +2009-05-06 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb (Locate_Directory): Remove unused parameters, and add + support for returning the directory even if it doesn't exist. This is + used for the object directory, since we are always setting it to a + non-null value, and we should set it to an absolute name rather than a + relative name for the sake of external tools that might depend on it. + (Check_Library_Attributes): When Project.Library_Dir is known, check + that the directory exists. + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Check_Dereference): If the prefix of an attribute + reference is an implicit dereference, do not freeze the designated type + if within a default expression or when preanalyzing a pre/postcondtion. + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Analyze_Object_Renaming): If the object is a function + call returning an unconstrained composite value, create the proper + subtype for it, as is done for object dclarations with unconstrained + nominal subtypes + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Check_Constant_Address_Clause): Minor error message + improvements + + * freeze.adb: Minor reformatting + +2009-05-06 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb (Access_Type_Declaration): An access type whose + designated type is a limited view from a limited with clause (flagged + From_With_Type) is not itself such a limited view. + +2009-05-06 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb: Remove unused variable. + + * clean.adb, gnatcmd.adb, makeutl.ads, prj-pars.adb, prj-pars.ads, + prj-proc.ads, prj.ads, switch-m.adb (Subdirs_Option): Moved to + makeutl.ads, since not all users of prj.ads need this. + +2009-05-06 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): Add implicit call to the C++ + constructor in case of aggregates whose type is a CPP_Class type. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb: Minor comment additions + + * osint.adb: Minor reformatting + +2009-05-06 Pascal Obry <obry@adacore.com> + + * initialize.c: On Windows, keep full pathname to expanded command + line patterns. + +2009-05-06 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Resolve_Record_Aggregate): If a defaulted component of + an aggregate with box default is of a discriminated private type, do + not build a subaggregate for it. + A proper call to the initialization procedure is generated for it. + +2009-05-06 Thomas Quinot <quinot@adacore.com> + + * rtsfind.adb, rtsfind.ads, exp_dist.adb, exp_dist.ads + (Exp_Dist.Build_TC_Call, Build_From_Any_Call, Build_To_Any_Call): + Use PolyORB strings to represent Ada.Strings.Unbounded_String value; + use standard array code for Standard.String. + (Exp_Dist): Bump PolyORB s-parint API version to 3. + (Rtsfind): New entities TA_Std_String, Unbounded_String. + +2009-05-06 Robert Dewar <dewar@adacore.com> + + * g-comlin.ads: Minor reformatting + + * xoscons.adb: Minor reformatting + +2009-05-06 Gary Dismukes <dismukes@adacore.com> + + * sem_aggr.adb (Resolve_Record_Aggregate): In step 5, get the + Underlying_Type before retrieving the type definition for gathering + components, to account for the case where the type is private. + +2009-05-06 Tristan Gingold <gingold@adacore.com> + + * g-comlin.ads: Fix minor typos (Getopt instead of Get_Opt). + +2009-05-06 Thomas Quinot <quinot@adacore.com> + + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.adb g-socthi-mingw.ads, + g-socthi.adb, g-stsifd-sockets.adb, g-socthi.ads, g-socket.adb + (GNAT.Sockets.Thin.C_Sendmsg, GNAT.Sockets.Thin.C_Recvmsg, + Windows versions): Fix incorrect base + address of Iovec (it's Msg_Iov, not Msg_Iov'Address). + (GNAT.Sockets.Thin.C_Sendto, GNAT.Sockets.Thin.C_Recvfrom): Use a + System.Address for the To parameter instead of a Sockaddr_In_Access, to + achieve independance from AF_INET family, and also to allow this + parameter to be retrieved from a Msghdr for the Windows case where + these routines are used to implement C_Sendmsg and C_Recvmsg. + +2009-05-06 Bob Duff <duff@adacore.com> + + * g-expect.adb, g-expect.ads: Minor reformatting + + * sdefault.ads: Minor comment fix + + * g-expect-vms.adb: Minor reformatting + + * table.ads, table.adb (Append_All): New convenience procedure for + appending a whole array. + + * comperr.adb (Compiler_Abort): Mention the -gnatd.n switch in the bug + box message. Call Osint.Dump_Source_File_Names to print out the file + list, instead of rummaging around in various data structures. + + * debug.adb: New switch -gnatd.n, to print source file names as they + are read. + + * alloc.ads: Add parameters for Osint.File_Name_Chars. + + * osint.ads, osint.adb (Dump_Source_File_Names): New procedure to print + out source file names during a "bug box". + (Include_Dir_Default_Prefix): Use memo-izing to avoid repeated new/free. + (Read_Source_File): Print out the file name, if requested via -gnatd.n. + If it's not part of the runtimes, store it for later printing by + Dump_Source_File_Names. + +2009-05-06 Javier Miranda <miranda@adacore.com> + + * gnat_rm.texi (CPP_Constructor): Avoid duplication of the + documentation and add reference to the GNAT user guide for further + details. + +2009-05-06 Javier Miranda <miranda@adacore.com> + + * gnat_ugn.texi: Complete documentation for CPP_Constructor and remove + also wrong examples that use extension aggregates. + +2009-05-06 Albert Lee <lee@adacore.com> + + * s-oscons-tmplt.c (System.OS_Constants): Do not use special definition + of Msg_Iovlen_T for VMS. + +2009-05-04 Laurent GUERBY <laurent@guerby.net> + + PR ada/38874 + * make.adb (Scan_Make_Arg): Pass --param= to compiler and linker. + 2009-04-29 Ed Schonberg <schonberg@adacore.com> * sem_ch8.adb (Analyze_Subprogram_Renaming): Improve error message on diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 83da18b4e5b..1f5e1546796 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -3369,6 +3369,63 @@ __gnat_copy_attribs (char *from, char *to, int mode) { #if defined (VMS) || defined (__vxworks) || defined (__nucleus__) return -1; + +#elif defined (_WIN32) && !defined (RTX) + TCHAR wfrom [GNAT_MAX_PATH_LEN + 2]; + TCHAR wto [GNAT_MAX_PATH_LEN + 2]; + BOOL res; + FILETIME fct, flat, flwt; + HANDLE hfrom, hto; + + S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2); + S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2); + + /* retrieve from times */ + + hfrom = CreateFile + (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (hfrom == INVALID_HANDLE_VALUE) + return -1; + + res = GetFileTime (hfrom, &fct, &flat, &flwt); + + CloseHandle (hfrom); + + if (res == 0) + return -1; + + /* retrieve from times */ + + hto = CreateFile + (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (hto == INVALID_HANDLE_VALUE) + return -1; + + res = SetFileTime (hto, NULL, &flat, &flwt); + + CloseHandle (hto); + + if (res == 0) + return -1; + + /* Set file attributes in full mode. */ + + if (mode == 1) + { + DWORD attribs = GetFileAttributes (wfrom); + + if (attribs == INVALID_FILE_ATTRIBUTES) + return -1; + + res = SetFileAttributes (wto, attribs); + if (res == 0) + return -1; + } + + return 0; + #else struct stat fbuf; struct utimbuf tbuf; diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 61c3ba867f4..fa6c9d123f5 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -61,6 +61,9 @@ package Alloc is Elmts_Initial : constant := 1_200; -- Elists Elmts_Increment : constant := 100; + File_Name_Chars_Initial : constant := 10_000; -- Osint + File_Name_Chars_Increment : constant := 100; + Inlined_Bodies_Initial : constant := 50; -- Inline Inlined_Bodies_Increment : constant := 200; diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 04512e7778f..2c08d49daaf 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -25,7 +25,7 @@ with ALI; use ALI; with Csets; -with Makeutl; +with Makeutl; use Makeutl; with MLib.Tgt; use MLib.Tgt; with Namet; use Namet; with Opt; use Opt; diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 157945bb0d9..43680b1b4bb 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,9 +30,7 @@ with Atree; use Atree; with Debug; use Debug; with Errout; use Errout; -with Fname; use Fname; with Gnatvsn; use Gnatvsn; -with Lib; use Lib; with Namet; use Namet; with Osint; use Osint; with Output; use Output; @@ -395,26 +393,19 @@ package body Comperr is Write_Line ("Note that list may not be accurate in some cases, "); Write_Line ("so please double check that the problem can still "); Write_Line ("be reproduced with the set of files listed."); + Write_Line ("Consider also -gnatd.n switch (see debug.adb)."); Write_Eol; - for U in Main_Unit .. Last_Unit loop - begin - if not Is_Internal_File_Name - (File_Name (Source_Index (U))) - then - Write_Name (Full_File_Name (Source_Index (U))); - Write_Eol; - end if; + begin + Dump_Source_File_Names; - -- No point in double bug box if we blow up trying to print - -- the list of file names! Output informative msg and quit. + -- If we blow up trying to print the list of file names, just output + -- informative msg and continue. - exception - when others => - Write_Str ("list may be incomplete"); - exit; - end; - end loop; + exception + when others => + Write_Str ("list may be incomplete"); + end; Write_Eol; Set_Standard_Output; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 8cb47ac5886..d0b285abf34 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -104,7 +104,7 @@ package body Debug is -- d.k -- d.l Use Ada 95 semantics for limited function returns -- d.m For -gnatl, print full source only for main unit - -- d.n + -- d.n Print source file names -- d.o -- d.p -- d.q @@ -523,6 +523,10 @@ package body Debug is -- main source (this corresponds to a previous behavior of -gnatl and -- is used for running the ACATS tests). + -- d.n Print source file names as they are loaded. This is useful if the + -- compiler has a bug -- these are the files that need to be included + -- in a bug report. + -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 76d465a05f3..c762be166fc 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -53,9 +53,9 @@ with Uname; use Uname; package body Errout is Errors_Must_Be_Ignored : Boolean := False; - -- Set to True by procedure Set_Ignore_Errors (True), when calls to - -- error message procedures should be ignored (when parsing irrelevant - -- text in sources being preprocessed). + -- Set to True by procedure Set_Ignore_Errors (True), when calls to error + -- message procedures should be ignored (when parsing irrelevant text in + -- sources being preprocessed). Finalize_Called : Boolean := False; -- Set True if the Finalize routine has been called diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 41daf243bab..e4d8a62e6dc 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -581,6 +581,33 @@ package Errout is -- Triggering switch. If non-zero, then ignore errors mode is activated. -- This is a counter to allow convenient nesting of enable/disable. + ----------------------- + -- CODEFIX Facility -- + ----------------------- + + -- The GPS and GNATBench IDE's have a codefix facility that allows for + -- automatic correction of a subset of the errors and warnings issued + -- by the compiler. This is done by recognizing the text of specific + -- messages using appropriate matching patterns. + + -- The text of such messages should not be altered without coordinating + -- with the codefix code. All such messages are marked by a specific + -- style of comments, as shown by the following example: + + -- Error_Msg_N -- CODEFIX + -- (parameters ....) + + -- Any message marked with this -- CODEFIX comment should not be modified + -- without appropriate coordination. If new messages are added which may + -- be susceptible to automatic codefix action, they are marked using: + + -- Error_Msg -- CODEFIX??? + -- (parameters) + + -- And subsequently either the appropriate code is added to codefix and the + -- ??? are removed, or it is determined that this is not an appropriate + -- case for codefix action, and the comment is removed. + ------------------------------ -- Error Output Subprograms -- ------------------------------ diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 516905f8873..db9e1d7784c 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -56,7 +56,6 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -623,7 +622,9 @@ package body Exp_Aggr is -- with tagged components, but not clear whether it's worthwhile ???; -- in the case of the JVM, object tags are handled implicitly) - if Is_Tagged_Type (Component_Type (Typ)) and then VM_Target = No_VM then + if Is_Tagged_Type (Component_Type (Typ)) + and then Tagged_Type_Expansion + then return False; end if; @@ -1188,12 +1189,12 @@ package body Exp_Aggr is Append_To (L, A); -- Adjust the tag if tagged (because of possible view - -- conversions), unless compiling for the Java VM where + -- conversions), unless compiling for a VM where -- tags are implicit. if Present (Comp_Type) and then Is_Tagged_Type (Comp_Type) - and then VM_Target = No_VM + and then Tagged_Type_Expansion then A := Make_OK_Assignment_Statement (Loc, @@ -2519,22 +2520,14 @@ package body Exp_Aggr is Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); Set_Assignment_OK (Ref); - if Has_Default_Init_Comps (N) - or else Has_Task (Base_Type (Init_Typ)) - then - Append_List_To (L, - Build_Initialization_Call (Loc, - Id_Ref => Ref, - Typ => Init_Typ, - In_Init_Proc => Within_Init_Proc, - With_Default_Init => True)); - else - Append_List_To (L, - Build_Initialization_Call (Loc, - Id_Ref => Ref, - Typ => Init_Typ, - In_Init_Proc => Within_Init_Proc)); - end if; + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => Init_Typ, + In_Init_Proc => Within_Init_Proc, + With_Default_Init => Has_Default_Init_Comps (N) + or else + Has_Task (Base_Type (Init_Typ)))); if Is_Constrained (Entity (A)) and then Has_Discriminants (Entity (A)) @@ -2542,6 +2535,21 @@ package body Exp_Aggr is Check_Ancestor_Discriminants (Entity (A)); end if; + -- Handle calls to C++ constructors + + elsif Is_CPP_Constructor_Call (A) then + Init_Typ := Etype (Etype (A)); + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => Init_Typ, + In_Init_Proc => Within_Init_Proc, + With_Default_Init => Has_Default_Init_Comps (N), + Constructor_Ref => A)); + -- Ada 2005 (AI-287): If the ancestor part is an aggregate of -- limited type, a recursive call expands the ancestor. Note that -- in the limited case, the ancestor part must be either a @@ -2612,7 +2620,7 @@ package body Exp_Aggr is -- the subsequent deep_adjust works properly (unless VM_Target, -- where tags are implicit). - if VM_Target = No_VM then + if Tagged_Type_Expansion then Instr := Make_OK_Assignment_Statement (Loc, Name => @@ -2765,6 +2773,18 @@ package body Exp_Aggr is end if; end if; + -- For CPP types we generate an implicit call to the C++ default + -- constructor to ensure the proper initialization of the _Tag + -- component. + + if Is_CPP_Class (Typ) then + pragma Assert (Present (Base_Init_Proc (Typ))); + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Lhs, + Typ => Typ)); + end if; + -- Generate the assignments, component by component -- tmp.comp1 := Expr1_From_Aggr; @@ -3013,7 +3033,9 @@ package body Exp_Aggr is -- tmp.comp._tag := comp_typ'tag; - if Is_Tagged_Type (Comp_Type) and then VM_Target = No_VM then + if Is_Tagged_Type (Comp_Type) + and then Tagged_Type_Expansion + then Instr := Make_OK_Assignment_Statement (Loc, Name => @@ -3129,7 +3151,14 @@ package body Exp_Aggr is if Ancestor_Is_Expression then null; - elsif Is_Tagged_Type (Typ) and then VM_Target = No_VM then + -- For CPP types we generated a call to the C++ default constructor + -- before the components have been initialized to ensure the proper + -- initialization of the _Tag component (see above). + + elsif Is_CPP_Class (Typ) then + null; + + elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Instr := Make_OK_Assignment_Statement (Loc, Name => @@ -5272,7 +5301,7 @@ package body Exp_Aggr is else Set_Etype (N, Typ); - if VM_Target = No_VM then + if Tagged_Type_Expansion then Expand_Record_Aggregate (N, Orig_Tag => New_Occurrence_Of @@ -5363,7 +5392,7 @@ package body Exp_Aggr is or else (Is_Entity_Name (Expr_Q) and then Ekind (Entity (Expr_Q)) in Formal_Kind)) - and then VM_Target = No_VM + and then Tagged_Type_Expansion then Static_Components := False; return True; @@ -5709,7 +5738,7 @@ package body Exp_Aggr is if Present (Orig_Tag) then Tag_Value := Orig_Tag; - elsif VM_Target /= No_VM then + elsif not Tagged_Type_Expansion then Tag_Value := Empty; else Tag_Value := @@ -5773,7 +5802,7 @@ package body Exp_Aggr is -- For a root type, the tag component is added (unless compiling -- for the VMs, where tags are implicit). - elsif VM_Target = No_VM then + elsif Tagged_Type_Expansion then declare Tag_Name : constant Node_Id := New_Occurrence_Of @@ -5875,7 +5904,7 @@ package body Exp_Aggr is begin return Static_Dispatch_Tables - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then RTU_Loaded (Ada_Tags) -- Avoid circularity when rebuilding the compiler diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 5772d58487e..bdc3c53502e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1031,7 +1031,7 @@ package body Exp_Attr is elsif Is_Class_Wide_Type (Ptyp) and then Is_Interface (Ptyp) - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then not (Nkind (Pref) in N_Has_Entity and then Is_Subprogram (Entity (Pref))) then @@ -1218,7 +1218,7 @@ package body Exp_Attr is -- A reference to P'Body_Version or P'Version is expanded to -- Vnn : Unsigned; - -- pragma Import (C, Vnn, "uuuuT"; + -- pragma Import (C, Vnn, "uuuuT"); -- ... -- Get_Version_String (Vnn) @@ -3118,7 +3118,7 @@ package body Exp_Attr is -- accessibility check on virtual machines, so we omit it. if Ada_Version >= Ada_05 - and then VM_Target = No_VM + and then Tagged_Type_Expansion then Insert_Action (N, Make_Implicit_If_Statement (N, @@ -4355,7 +4355,7 @@ package body Exp_Attr is -- For VMs we leave the type attribute unexpanded because -- there's not a dispatching table to reference. - if VM_Target = No_VM then + if Tagged_Type_Expansion then Rewrite (N, Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To @@ -4380,7 +4380,7 @@ package body Exp_Attr is -- Not needed for VM targets, since all handled by the VM - if VM_Target = No_VM then + if Tagged_Type_Expansion then Rewrite (N, Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), @@ -5238,6 +5238,7 @@ package body Exp_Attr is Attribute_Address_Size | Attribute_Base | Attribute_Class | + Attribute_Compiler_Version | Attribute_Default_Bit_Order | Attribute_Delta | Attribute_Denorm | diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5ba57dea134..4138dd01858 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1865,7 +1865,7 @@ package body Exp_Ch3 is -- Suppress the tag adjustment when VM_Target because VM tags are -- represented implicitly in objects. - if Is_Tagged_Type (Typ) and then VM_Target = No_VM then + if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Append_To (Res, Make_Assignment_Statement (Loc, Name => @@ -1888,8 +1888,8 @@ package body Exp_Ch3 is end if; if Needs_Finalization (Typ) - and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) - and then not Is_Inherently_Limited_Type (Typ) + and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) + and then not Is_Inherently_Limited_Type (Typ) then Append_List_To (Res, Make_Adjust_Call ( @@ -2159,7 +2159,7 @@ package body Exp_Ch3 is if not Is_Tagged_Type (Rec_Type) or else Etype (Rec_Type) = Rec_Type or else not Has_Discriminants (Etype (Rec_Type)) - or else VM_Target /= No_VM + or else not Tagged_Type_Expansion then return; end if; @@ -2292,7 +2292,7 @@ package body Exp_Ch3 is if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then not No_Run_Time_Mode then -- Initialize the primary tag @@ -4185,9 +4185,28 @@ package body Exp_Ch3 is -- which case the init proc call must be inserted only after the bodies -- of the shared variable procedures have been seen. + function Rewrite_As_Renaming return Boolean; + -- Indicate whether to rewrite a declaration with initialization into an + -- object renaming declaration (see below). + + ------------------------- + -- Rewrite_As_Renaming -- + ------------------------- + + function Rewrite_As_Renaming return Boolean is + begin + return not Aliased_Present (N) + and then Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) = E_Variable + and then OK_To_Rename (Entity (Expr_Q)) + and then Is_Entity_Name (Object_Definition (N)); + end Rewrite_As_Renaming; + + -- Start of processing for Expand_N_Object_Declaration + begin - -- Don't do anything for deferred constants. All proper actions will - -- be expanded during the full declaration. + -- Don't do anything for deferred constants. All proper actions will be + -- expanded during the full declaration. if No (Expr) and Constant_Present (N) then return; @@ -4195,7 +4214,7 @@ package body Exp_Ch3 is -- Force construction of dispatch tables of library level tagged types - if VM_Target = No_VM + if Tagged_Type_Expansion and then Static_Dispatch_Tables and then Is_Library_Level_Entity (Def_Id) and then Is_Library_Level_Tagged_Type (Base_Typ) @@ -4504,7 +4523,7 @@ package body Exp_Ch3 is or else not Is_Ancestor (Root_Type (Typ), Etype (Expr))) and then Comes_From_Source (Def_Id) - and then VM_Target = No_VM + and then Tagged_Type_Expansion then declare Decl_1 : Node_Id; @@ -4603,10 +4622,13 @@ package body Exp_Ch3 is -- where the object was initialized by a call to a function whose -- result is built in place, since no copy occurred. (Eventually -- we plan to support in-place function results for some cases - -- of nonlimited types. ???) + -- of nonlimited types. ???) Similarly, no adjustment is required + -- if we are going to rewrite the object declaration into a + -- renaming declaration. if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) + and then not Rewrite_As_Renaming then Insert_Actions_After (Init_After, Make_Adjust_Call ( @@ -4628,7 +4650,7 @@ package body Exp_Ch3 is if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) and then not Is_CPP_Class (Typ) - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then Nkind (Expr) /= N_Aggregate then -- The re-assignment of the tag has to be done even if the @@ -4750,14 +4772,9 @@ package body Exp_Ch3 is -- X : typ renames expr -- provided that X is not aliased. The aliased case has to be - -- excluded in general because expr will not be aliased in general. + -- excluded in general because Expr will not be aliased in general. - if not Aliased_Present (N) - and then Is_Entity_Name (Expr_Q) - and then Ekind (Entity (Expr_Q)) = E_Variable - and then OK_To_Rename (Entity (Expr_Q)) - and then Is_Entity_Name (Object_Definition (N)) - then + if Rewrite_As_Renaming then Rewrite (N, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Defining_Identifier (N), @@ -5059,7 +5076,7 @@ package body Exp_Ch3 is if Has_Task (Typ) and then not Restriction_Active (No_Implicit_Heap_Allocations) and then not Global_Discard_Names - and then VM_Target = No_VM + and then Tagged_Type_Expansion then Set_Uses_Sec_Stack (Proc_Id); end if; @@ -5684,7 +5701,7 @@ package body Exp_Ch3 is -- Create the tag entities with a minimum decoration - if VM_Target = No_VM then + if Tagged_Type_Expansion then Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); end if; @@ -5805,16 +5822,14 @@ package body Exp_Ch3 is -- VM_Target because the dispatching mechanism is handled -- internally by the VMs. - if VM_Target = No_VM then + if Tagged_Type_Expansion then Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); -- Generate dispatch table of locally defined tagged type. -- Dispatch tables of library level tagged types are built -- later (see Analyze_Declarations). - if VM_Target = No_VM - and then not Has_Static_DT - then + if not Has_Static_DT then Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); end if; end if; @@ -5933,7 +5948,7 @@ package body Exp_Ch3 is Adjust_Discriminants (Def_Id); - if VM_Target = No_VM or else not Is_Interface (Def_Id) then + if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then -- Do not need init for interfaces on e.g. CIL since they're -- abstract. Helps operation of peverify (the PE Verify tool). @@ -7917,7 +7932,7 @@ package body Exp_Ch3 is -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active. if Ada_Version >= Ada_05 - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Select_Statements) and then RTE_Available (RE_Select_Specific_Data) @@ -8412,7 +8427,7 @@ package body Exp_Ch3 is -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active. if Ada_Version >= Ada_05 - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then not Is_Interface (Tag_Typ) and then ((Is_Interface (Etype (Tag_Typ)) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 42f6199f2af..6da8ff90e44 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -378,7 +378,7 @@ package body Exp_Ch4 is -- Do nothing in case of VM targets: the virtual machine will handle -- interfaces directly. - if VM_Target /= No_VM then + if not Tagged_Type_Expansion then return; end if; @@ -511,7 +511,7 @@ package body Exp_Ch4 is -- there does not seem to be any practical way of implementing it. if Ada_Version >= Ada_05 - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then Is_Class_Wide_Type (DesigT) and then not Scope_Suppress (Accessibility_Check) and then @@ -626,7 +626,7 @@ package body Exp_Ch4 is if Is_Class_Wide_Type (Etype (Exp)) and then Is_Interface (Etype (Exp)) - and then VM_Target = No_VM + and then Tagged_Type_Expansion then Set_Expression (Expression (N), @@ -795,7 +795,7 @@ package body Exp_Ch4 is -- Suppress the tag assignment when VM_Target because VM tags are -- represented implicitly in objects. - if VM_Target /= No_VM then + if not Tagged_Type_Expansion then null; -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide @@ -4302,7 +4302,7 @@ package body Exp_Ch4 is -- are not explicitly represented in Java objects, so the -- normal tagged membership expansion is not what we want). - if VM_Target = No_VM then + if Tagged_Type_Expansion then Rewrite (N, Tagged_Membership (N)); Analyze_And_Resolve (N, Rtyp); end if; @@ -7392,7 +7392,7 @@ package body Exp_Ch4 is -- on such run-time unit. and then - (VM_Target /= No_VM + (not Tagged_Type_Expansion or else not (RTU_Loaded (Ada_Tags) and then Nkind (Prefix (N)) = N_Selected_Component diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index c77ff0595bf..4cc66304ec9 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -4075,7 +4075,7 @@ package body Exp_Ch5 is -- does not seem to be any practical way to implement this check. elsif Ada_Version >= Ada_05 - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then Is_Class_Wide_Type (R_Type) and then not Scope_Suppress (Accessibility_Check) and then @@ -4285,7 +4285,7 @@ package body Exp_Ch5 is Save_Tag : constant Boolean := Is_Tagged_Type (T) and then not No_Ctrl_Actions (N) - and then VM_Target = No_VM; + and then Tagged_Type_Expansion; -- Tags are not saved and restored when VM_Target because VM tags are -- represented implicitly in objects. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2ea49a3c4af..1da82bafd03 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -68,7 +68,6 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -2574,7 +2573,7 @@ package body Exp_Ch6 is if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) then - if VM_Target = No_VM then + if Tagged_Type_Expansion then Expand_Dispatching_Call (N); -- The following return is worrisome. Is it really OK to @@ -4820,7 +4819,7 @@ package body Exp_Ch6 is and then not Is_Abstract_Subprogram (Subp) and then Present (DTC_Entity (Subp)) and then Present (Scope (DTC_Entity (Subp))) - and then VM_Target = No_VM + and then Tagged_Type_Expansion and then not Restriction_Active (No_Dispatching_Calls) and then RTE_Available (RE_Tag) then diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 23dc728f988..977a90fc4a7 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -59,7 +59,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -249,7 +248,7 @@ package body Exp_Disp is begin if not Expander_Active - or else VM_Target /= No_VM + or else not Tagged_Type_Expansion then return; end if; @@ -806,7 +805,7 @@ package body Exp_Disp is or else (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ))); - if VM_Target /= No_VM then + if not Tagged_Type_Expansion then -- For VM, just do a conversion ??? diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 04a2187c8ce..75b400d2644 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -6630,13 +6630,13 @@ package body Exp_Dist is Make_Function_Call (Loc, Name => New_Occurrence_Of - (RTE (RE_TA_String), Loc), + (RTE (RE_TA_Std_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Name_String))), Make_Function_Call (Loc, Name => New_Occurrence_Of - (RTE (RE_TA_String), Loc), + (RTE (RE_TA_Std_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Strval => Repo_Id_String)))))))))))); @@ -8465,7 +8465,7 @@ package body Exp_Dist is elsif U_Type = RTE (RE_Long_Long_Unsigned) then Lib_RE := RE_FA_LLU; - elsif U_Type = Standard_String then + elsif Is_RTE (U_Type, RE_Unbounded_String) then Lib_RE := RE_FA_String; -- Special DSA types @@ -8970,7 +8970,11 @@ package body Exp_Dist is for J in 1 .. Ndim loop Lnam := New_External_Name ('L', J); Hnam := New_External_Name ('H', J); - Indt := Etype (Indx); + + -- Note, for empty arrays bounds may be out of + -- the range of Etype (Indx). + + Indt := Base_Type (Etype (Indx)); Append_To (Decls, Make_Object_Declaration (Loc, @@ -9288,6 +9292,7 @@ package body Exp_Dist is Typ : Entity_Id := Etype (N); U_Type : Entity_Id; + C_Type : Entity_Id; Fnam : Entity_Id := Empty; Lib_RE : RE_Id := RE_Null; @@ -9383,7 +9388,7 @@ package body Exp_Dist is elsif U_Type = RTE (RE_Long_Long_Unsigned) then Lib_RE := RE_TA_LLU; - elsif U_Type = Standard_String then + elsif Is_RTE (U_Type, RE_Unbounded_String) then Lib_RE := RE_TA_String; -- Special DSA types @@ -9416,11 +9421,23 @@ package body Exp_Dist is Fnam := RTE (Lib_RE); end if; + -- If Fnam is already analyzed, find the proper expected type, + -- else we have a newly constructed To_Any function and we know + -- that the expected type of its parameter is U_Type. + + if Ekind (Fnam) = E_Function + and then Present (First_Formal (Fnam)) + then + C_Type := Etype (First_Formal (Fnam)); + else + C_Type := U_Type; + end if; + return Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc), Parameter_Associations => - New_List (Unchecked_Convert_To (U_Type, N))); + New_List (OK_Convert_To (C_Type, N))); end Build_To_Any_Call; --------------------------- @@ -10153,7 +10170,7 @@ package body Exp_Dist is elsif U_Type = RTE (RE_Long_Long_Unsigned) then Lib_RE := RE_TC_LLU; - elsif U_Type = Standard_String then + elsif Is_RTE (U_Type, RE_Unbounded_String) then Lib_RE := RE_TC_String; -- Special DSA types @@ -10253,7 +10270,7 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_TA_String), Loc), + Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, S)))); end Add_String_Parameter; diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index 26995a8b9f9..d6fc1bb8ead 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ package Exp_Dist is PCS_Version_Number : constant array (PCS_Names) of Int := (Name_No_DSA => 1, Name_GARLIC_DSA => 1, - Name_PolyORB_DSA => 2); + Name_PolyORB_DSA => 3); -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index d3f9334a607..b35c35ea9df 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,7 @@ with Freeze; use Freeze; with Namet; use Namet; with Nmake; use Nmake; with Nlists; use Nlists; +with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -52,7 +53,6 @@ with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -219,7 +219,7 @@ package body Exp_Intr is -- checks are suppressed for the result type or VM_Target /= No_VM if Tag_Checks_Suppressed (Etype (Result_Typ)) - or else VM_Target /= No_VM + or else not Tagged_Type_Expansion then null; @@ -1034,7 +1034,7 @@ package body Exp_Intr is -- free (Base_Address (Obj_Ptr)) if Is_Interface (Directly_Designated_Type (Typ)) - and then VM_Target = No_VM + and then Tagged_Type_Expansion then Set_Expression (Free_Node, Unchecked_Convert_To (Typ, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8e5479738c8..1fe6526c77d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -3880,7 +3880,7 @@ package body Exp_Util is -- initialization itself (and doesn't need or want the -- additional intermediate type to handle the assignment). - if Expander_Active and then VM_Target = No_VM then + if Expander_Active and then Tagged_Type_Expansion then EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index fdacb091afc..1f91db98388 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ +------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- @@ -1545,7 +1545,16 @@ package body Freeze is Placed_Component : Boolean := False; -- Set True if we find at least one component with a component - -- clause (used to warn about useless Bit_Order pragmas). + -- clause (used to warn about useless Bit_Order pragmas, and also + -- to detect cases where Implicit_Packing may have an effect). + + All_Scalar_Components : Boolean := True; + -- Set False if we encounter a component of a non-scalar type + + Scalar_Component_Total_RM_Size : Uint := Uint_0; + Scalar_Component_Total_Esize : Uint := Uint_0; + -- Accumulates total RM_Size values and total Esize values of all + -- scalar components. Used for processing of Implicit_Packing. function Check_Allocator (N : Node_Id) return Node_Id; -- If N is an allocator, possibly wrapped in one or more level of @@ -1855,6 +1864,17 @@ package body Freeze is end; end if; + -- Gather data for possible Implicit_Packing later + + if not Is_Scalar_Type (Etype (Comp)) then + All_Scalar_Components := False; + else + Scalar_Component_Total_RM_Size := + Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp)); + Scalar_Component_Total_Esize := + Scalar_Component_Total_Esize + Esize (Etype (Comp)); + end if; + -- If the component is an Itype with Delayed_Freeze and is either -- a record or array subtype and its base type has not yet been -- frozen, we must remove this from the entity list of this @@ -2061,7 +2081,7 @@ package body Freeze is -- Finally, enforce the restriction that access attributes with a -- current instance prefix can only apply to limited types. - if Ekind (Rec) = E_Record_Type then + if Ekind (Rec) = E_Record_Type then if Present (Corresponding_Remote_Type (Rec)) then Freeze_And_Append (Corresponding_Remote_Type (Rec), Loc, Result); @@ -2163,6 +2183,36 @@ package body Freeze is end if; end; end if; + + -- See if Implicit_Packing would work + + if not Is_Packed (Rec) + and then not Placed_Component + and then Has_Size_Clause (Rec) + and then All_Scalar_Components + and then not Has_Discriminants (Rec) + and then Esize (Rec) < Scalar_Component_Total_Esize + and then Esize (Rec) >= Scalar_Component_Total_RM_Size + then + -- If implicit packing enabled, do it + + if Implicit_Packing then + Set_Is_Packed (Rec); + + -- Otherwise flag the size clause + + else + declare + Sz : constant Node_Id := Size_Clause (Rec); + begin + Error_Msg_NE + ("size given for& too small", Sz, Rec); + Error_Msg_N + ("\use explicit pragma Pack " + & "or use pragma Implicit_Packing", Sz); + end; + end if; + end if; end Freeze_Record_Type; -- Start of processing for Freeze_Entity @@ -2849,7 +2899,7 @@ package body Freeze is and then Rsiz mod System_Storage_Unit /= 0 then -- For implicit packing mode, just set the - -- component size silently + -- component size silently. if Implicit_Packing then Set_Component_Size (Btyp, Rsiz); @@ -3245,7 +3295,7 @@ package body Freeze is -- later when the full type is frozen). elsif Ekind (E) = E_Record_Type - or else Ekind (E) = E_Record_Subtype + or else Ekind (E) = E_Record_Subtype then Freeze_Record_Type (E); @@ -3263,7 +3313,6 @@ package body Freeze is end if; Comp := First_Entity (E); - while Present (Comp) loop if Is_Type (Comp) then Freeze_And_Append (Comp, Loc, Result); diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 1f393afd042..57a68c2ab2f 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2008, AdaCore -- +-- Copyright (C) 1999-2009, 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- -- @@ -96,13 +96,13 @@ -- Goto_Section ("bargs"); -- loop -- -- Same loop as above to get switches and arguments --- -- The supported switches in Get_Opt might be different +-- -- The supported switches in Getopt might be different -- end loop; -- Goto_Section ("cargs"); -- loop -- -- Same loop as above to get switches and arguments --- -- The supported switches in Get_Opt might be different +-- -- The supported switches in Getopt might be different -- end loop; -- end; @@ -112,6 +112,7 @@ -- contexts, either because your system does not support Ada.Command_Line, or -- because you are manipulating other tools and creating their command line by -- hand, or for any other reason. + -- To create the list of strings, it is recommended to use -- GNAT.OS_Lib.Argument_String_To_List. @@ -125,7 +126,7 @@ -- GNAT.OS_Lib.Argument_String_To_List ("-g -O1 -Ipath"); -- begin -- Initialize_Option_Scan (Parser, Args); --- while Get_Opt ("* g O! I=", Parser) /= ASCII.NUL loop +-- while Getopt ("* g O! I=", Parser) /= ASCII.NUL loop -- Put_Line ("Switch " & Full_Switch (Parser) -- & " param=" & Parameter (Parser)); -- end loop; diff --git a/gcc/ada/g-debuti.adb b/gcc/ada/g-debuti.adb index 560f79f96d8..20731fb0c2d 100644 --- a/gcc/ada/g-debuti.adb +++ b/gcc/ada/g-debuti.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2005, AdaCore -- +-- Copyright (C) 1997-2009, 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- -- @@ -36,8 +36,8 @@ with System.Storage_Elements; use System.Storage_Elements; package body GNAT.Debug_Utilities is - H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; - -- Table of hex digits + H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + -- Table of hex digits ----------- -- Image -- diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 216ff5b5f1e..1ebebe4d95d 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2008, AdaCore -- +-- Copyright (C) 2000-2009, 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- -- @@ -85,6 +85,17 @@ package body GNAT.Dynamic_Tables is Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val); end Append; + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (T : in out Instance; New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (T, New_Vals (J)); + end loop; + end Append_All; + -------------------- -- Decrement_Last -- -------------------- diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads index 7768c88cd38..897d7008f82 100644 --- a/gcc/ada/g-dyntab.ads +++ b/gcc/ada/g-dyntab.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2008, AdaCore -- +-- Copyright (C) 2000-2009, 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- -- @@ -169,6 +169,9 @@ package GNAT.Dynamic_Tables is -- i.e. the table size is increased by one, and the given new item -- stored in the newly created table element. + procedure Append_All (T : in out Instance; New_Vals : Table_Type); + -- Appends all components of New_Vals + procedure Set_Item (T : in out Instance; Index : Table_Index_Type; diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index bc74a5d261e..1162f50aa69 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 2002-2009, 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- -- @@ -249,7 +249,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : String; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is begin @@ -265,7 +265,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexp : String; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is begin @@ -284,7 +284,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); @@ -298,7 +298,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; @@ -370,7 +370,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Patterns : Compiled_Regexp_Array (Regexps'Range); @@ -392,7 +392,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); @@ -404,7 +404,7 @@ package body GNAT.Expect is procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); @@ -418,7 +418,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexps : Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Patterns : Compiled_Regexp_Array (Regexps'Range); @@ -442,7 +442,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexps : Compiled_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; @@ -489,7 +489,7 @@ package body GNAT.Expect is (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; @@ -646,7 +646,7 @@ package body GNAT.Expect is else -- Add what we read to the buffer - if Descriptors (J).Buffer_Index + N - 1 > + if Descriptors (J).Buffer_Index + N > Descriptors (J).Buffer_Size then -- If the user wants to know when we have diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index 256f2564d8f..7ce2c89d771 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -261,7 +261,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : String; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is begin @@ -277,7 +277,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexp : String; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is begin @@ -296,7 +296,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); @@ -310,7 +310,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; @@ -382,7 +382,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Patterns : Compiled_Regexp_Array (Regexps'Range); @@ -406,7 +406,7 @@ package body GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); @@ -418,7 +418,7 @@ package body GNAT.Expect is procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); @@ -432,7 +432,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexps : Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Patterns : Compiled_Regexp_Array (Regexps'Range); @@ -456,7 +456,7 @@ package body GNAT.Expect is Result : out Expect_Match; Regexps : Compiled_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; @@ -503,7 +503,7 @@ package body GNAT.Expect is (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads index 31dda4134b1..1e50852522a 100644 --- a/gcc/ada/g-expect.ads +++ b/gcc/ada/g-expect.ads @@ -51,7 +51,7 @@ -- Non_Blocking_Spawn -- (Fd, "ftp", -- (1 => new String' ("machine@domain"))); --- Timeout := 10000; -- 10 seconds +-- Timeout := 10_000; -- 10 seconds -- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), -- Timeout); -- case Result is @@ -328,7 +328,7 @@ package GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : String; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Wait till a string matching Fd can be read from Fd, and return 1 -- if a match was found. @@ -359,7 +359,7 @@ package GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as the previous one, but with a precompiled regular expression. -- This is more efficient however, especially if you are using this @@ -371,7 +371,7 @@ package GNAT.Expect is Result : out Expect_Match; Regexp : String; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as above, but it is now possible to get the indexes of the -- substrings for the parentheses in the regexp (see the example at the @@ -391,7 +391,7 @@ package GNAT.Expect is Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as above, but with a precompiled regular expression @@ -416,7 +416,7 @@ package GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Wait till a string matching one of the regular expressions in Regexps -- is found. This function returns the index of the regexp that matched. @@ -427,7 +427,7 @@ package GNAT.Expect is (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as the previous one, but with precompiled regular expressions. -- This can be much faster if you are using them multiple times. @@ -437,7 +437,7 @@ package GNAT.Expect is Result : out Expect_Match; Regexps : Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as above, except that you can also access the parenthesis -- groups inside the matching regular expression. @@ -451,7 +451,7 @@ package GNAT.Expect is Result : out Expect_Match; Regexps : Compiled_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as above, but with precompiled regular expressions. -- The first index in Matched must be 0, or Constraint_Error will be @@ -472,14 +472,14 @@ package GNAT.Expect is (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as above, but for multi processes procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10000; + Timeout : Integer := 10_000; Full_Buffer : Boolean := False); -- Same as the previous one, but for multiple processes. -- This procedure finds the first regexp that match the associated process. diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 4caa5f47244..9cd471afd54 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1644,7 +1644,7 @@ package body GNAT.Sockets is Item'Address, Item'Length, To_Int (Flags), - Sin'Unchecked_Access, + Sin'Address, Len'Access); if Res = Failure then @@ -1861,7 +1861,7 @@ package body GNAT.Sockets is Res : C.int; Sin : aliased Sockaddr_In; - C_To : Sockaddr_In_Access; + C_To : System.Address; Len : C.int; begin @@ -1871,11 +1871,11 @@ package body GNAT.Sockets is Set_Port (Sin'Unchecked_Access, Short_To_Network (C.unsigned_short (To.Port))); - C_To := Sin'Unchecked_Access; + C_To := Sin'Address; Len := Sin'Size / 8; else - C_To := null; + C_To := System.Null_Address; Len := 0; end if; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index c77048671bc..093731ce40d 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -263,24 +263,20 @@ package body GNAT.Sockets.Thin is for MH'Address use Msg; Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov'Address; + for Iovec'Address use MH.Msg_Iov; pragma Import (Ada, Iovec); - pragma Unreferenced (Flags); - begin - -- Windows does not provide an implementation of recvmsg(). The - -- spec for WSARecvMsg() is incompatible with the data types we - -- define, and is not available in all versions of Windows. So, - -- we'll use C_Recv instead. Note that this means the Flags - -- argument is ignored. + -- Windows does not provide an implementation of recvmsg(). The spec for + -- WSARecvMsg() is incompatible with the data types we define, and is + -- not available in all versions of Windows. So, we use C_Recv instead. for J in Iovec'Range loop Res := C_Recv (S, Iovec (J).Base.all'Address, C.int (Iovec (J).Length), - 0); + Flags); if Res < 0 then return ssize_t (Res); @@ -359,7 +355,10 @@ package body GNAT.Sockets.Thin is -- Check out-of-band data Length := C_Recvfrom - (S, Buffer'Address, 1, Flag, null, Fromlen'Unchecked_Access); + (S, Buffer'Address, 1, Flag, + From => System.Null_Address, + Fromlen => Fromlen'Unchecked_Access); + -- Is Fromlen necessary if From is Null_Address??? -- If the signal is not an out-of-band data, then it -- is a connection failure notification. @@ -399,26 +398,23 @@ package body GNAT.Sockets.Thin is for MH'Address use Msg; Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov'Address; + for Iovec'Address use MH.Msg_Iov; pragma Import (Ada, Iovec); - pragma Unreferenced (Flags); - begin - -- Windows does not provide an implementation of sendmsg(). The - -- spec for WSASendMsg() is incompatible with the data types we - -- define, and is not available in all versions of Windows. So, - -- we'll use C_Sendto instead. Note that this means the Flags - -- argument is ignored. + -- Windows does not provide an implementation of sendmsg(). The spec for + -- WSASendMsg() is incompatible with the data types we define, and is + -- not available in all versions of Windows. So, we'll use C_Sendto + -- instead. for J in Iovec'Range loop Res := C_Sendto (S, Iovec (J).Base.all'Address, C.int (Iovec (J).Length), - Flags => 0, - To => null, - Tolen => 0); + Flags => Flags, + To => MH.Msg_Name, + Tolen => C.int (MH.Msg_Namelen)); if Res < 0 then return ssize_t (Res); diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 7b24eeec4e1..922e64aa22f 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -140,7 +140,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; function C_Recvmsg @@ -165,7 +165,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; function C_Setsockopt diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 14576805602..6384598f07a 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -40,13 +40,18 @@ with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is + type VMS_Msghdr is new Msghdr; + pragma Pack (VMS_Msghdr); + -- On VMS (unlike other platforms), struct msghdr is packed, so a specific + -- derived type is required. + Non_Blocking_Sockets : aliased Fd_Set; -- When this package is initialized with Process_Blocking_IO set to True, -- sockets are set in non-blocking mode to avoid blocking the whole process -- when a thread wants to perform a blocking IO operation. But the user can -- also set a socket in non-blocking mode by purpose. In order to make a -- difference between these two situations, we track the origin of - -- non-blocking mode in Non_Blocking_Sockets. If S is in + -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in -- Non_Blocking_Sockets, it has been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; @@ -87,7 +92,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; pragma Import (C, Syscall_Recvfrom, "recvfrom"); @@ -108,7 +113,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; pragma Import (C, Syscall_Sendto, "sendto"); @@ -210,7 +215,6 @@ package body GNAT.Sockets.Thin is if Res = Failure and then Errno = SOSC.EISCONN then return Thin_Common.Success; - else return Res; end if; @@ -271,7 +275,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int is Res : C.int; @@ -300,9 +304,15 @@ package body GNAT.Sockets.Thin is is Res : C.int; + GNAT_Msg : Msghdr; + for GNAT_Msg'Address use Msg; + pragma Import (Ada, GNAT_Msg); + + VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + begin loop - Res := Syscall_Recvmsg (S, Msg, Flags); + Res := Syscall_Recvmsg (S, VMS_Msg'Address, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) @@ -310,6 +320,8 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; + GNAT_Msg := Msghdr (VMS_Msg); + return ssize_t (Res); end C_Recvmsg; @@ -324,9 +336,15 @@ package body GNAT.Sockets.Thin is is Res : C.int; + GNAT_Msg : Msghdr; + for GNAT_Msg'Address use Msg; + pragma Import (Ada, GNAT_Msg); + + VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + begin loop - Res := Syscall_Sendmsg (S, Msg, Flags); + Res := Syscall_Sendmsg (S, VMS_Msg'Address, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) @@ -334,6 +352,8 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; + GNAT_Msg := Msghdr (VMS_Msg); + return ssize_t (Res); end C_Sendmsg; @@ -346,7 +366,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int is Res : C.int; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index 2fd5009db15..3799da802d2 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -143,7 +143,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; function C_Recvmsg @@ -168,7 +168,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; function C_Setsockopt diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index 0f682f4c04e..a35e429fbb2 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -98,7 +98,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; pragma Import (C, Syscall_Recvfrom, "recvfrom"); @@ -119,7 +119,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; pragma Import (C, Syscall_Sendto, "sendto"); @@ -285,7 +285,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int is Res : C.int; @@ -360,7 +360,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int is Res : C.int; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 4b6bd34d080..14b8ad92428 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -141,7 +141,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; function C_Recvmsg @@ -166,7 +166,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; function C_Setsockopt diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index daf69140ed1..0ffee86af49 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -94,7 +94,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; pragma Import (C, Syscall_Recvfrom, "recvfrom"); @@ -115,7 +115,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; pragma Import (C, Syscall_Sendto, "sendto"); @@ -290,7 +290,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int is Res : C.int; @@ -365,7 +365,7 @@ package body GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int is Res : C.int; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index b5186d062c6..cb19050250b 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -142,7 +142,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - From : Sockaddr_In_Access; + From : System.Address; Fromlen : not null access C.int) return C.int; function C_Recvmsg @@ -167,7 +167,7 @@ package GNAT.Sockets.Thin is Msg : System.Address; Len : C.int; Flags : C.int; - To : Sockaddr_In_Access; + To : System.Address; Tolen : C.int) return C.int; function C_Setsockopt diff --git a/gcc/ada/g-stsifd-sockets.adb b/gcc/ada/g-stsifd-sockets.adb index 23fdb59af76..3e3f4518820 100644 --- a/gcc/ada/g-stsifd-sockets.adb +++ b/gcc/ada/g-stsifd-sockets.adb @@ -229,8 +229,8 @@ package body Signalling_Fds is return C_Sendto (Wsig, Buf'Address, 1, Flags => SOSC.MSG_Forced_Flags, - To => null, - Tolen => 0); + To => System.Null_Address, + Tolen => 0); end Write; end Signalling_Fds; diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb index 60f373a4257..bcc025f42a7 100644 --- a/gcc/ada/g-table.adb +++ b/gcc/ada/g-table.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-2009, 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- -- @@ -96,6 +96,17 @@ package body GNAT.Table is Set_Item (Table_Index_Type (Last_Val + 1), New_Val); end Append; + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (New_Vals (J)); + end loop; + end Append_All; + -------------------- -- Decrement_Last -- -------------------- diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads index b0aad3d44aa..3a344a532f3 100644 --- a/gcc/ada/g-table.ads +++ b/gcc/ada/g-table.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-2009, 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- -- @@ -184,6 +184,9 @@ package GNAT.Table is -- i.e. the table size is increased by one, and the given new item -- stored in the newly created table element. + procedure Append_All (New_Vals : Table_Type); + -- Appends all components of New_Vals + procedure Set_Item (Index : Table_Index_Type; Item : Table_Component_Type); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index a5b29b97f54..564919d793e 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1243,22 +1243,22 @@ ada/ada.o : ada/ada.ads ada/system.ads ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ - ada/alloc.ads ada/binderr.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-c.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-utf_32.adb ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/alloc.ads ada/atree.ads ada/binderr.ads ada/casing.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/gnat.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/rident.ads ada/scans.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ + ada/sinput.ads ada/sinput.adb ada/sinput-c.ads ada/snames.ads \ + ada/stringt.ads ada/stringt.adb ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/ali.ads ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads \ @@ -1415,22 +1415,18 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/comperr.ads ada/comperr.adb ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ - ada/output.adb ada/rident.ads ada/sdefault.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/treepr.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads ada/output.adb \ + ada/rident.ads ada/sdefault.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/system.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/treepr.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ ada/csets.adb ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ @@ -1527,17 +1523,18 @@ ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/urealp.ads ada/widechar.ads ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/err_vars.ads ada/erroutc.ads ada/erroutc.adb ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/output.adb ada/rident.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/erroutc.ads \ + ada/erroutc.adb ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/opt.ads ada/output.ads ada/output.adb ada/rident.ads \ + ada/sinfo.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/eval_fat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2475,17 +2472,18 @@ ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/instpar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/instpar.ads ada/instpar.adb \ - ada/interfac.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/sdefault.ads ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/debug.ads ada/einfo.ads ada/gnatvsn.ads ada/hostparm.ads \ + ada/instpar.ads ada/instpar.adb ada/interfac.ads ada/namet.ads \ + ada/opt.ads ada/output.ads ada/sdefault.ads ada/sinfo.ads \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/interfac.o : ada/interfac.ads ada/system.ads @@ -2779,22 +2777,22 @@ ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchdeal.ads ada/urealp.ads ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib-writ.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ - ada/prepcomp.ads ada/prepcomp.adb ada/scans.ads ada/scn.ads \ - ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-l.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-dyntab.ads \ + ada/g-dyntab.adb ada/g-hesorg.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib-writ.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/output.ads ada/prep.ads ada/prepcomp.ads ada/prepcomp.adb \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3104,29 +3102,29 @@ ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sdefault.ads \ - ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_attr.adb \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/snames.adb ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/widechar.ads + ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ + ada/sem_attr.adb ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypef.ads ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/validsw.ads ada/widechar.ads ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3955,14 +3953,17 @@ ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/urealp.ads ada/widechar.ads ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/opt.ads ada/output.ads ada/sinput.ads ada/sinput.adb ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/snames.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index c19c0995941..04553d4b2ce 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -497,6 +497,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel.adb \ system.ads<system-vxworks-ppc-kernel.ads + + EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o else LIBGNAT_TARGET_PAIRS += \ system.ads<system-vxworks-ppc.ads @@ -727,6 +729,8 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),) s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel.adb \ system.ads<system-vxworks-x86-kernel.ads + + EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o else LIBGNAT_TARGET_PAIRS += \ system.ads<system-vxworks-x86.ads @@ -937,7 +941,6 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) g-bytswa.adb<g-bytswa-x86.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ - s-taspri.ads<s-taspri-posix.ads \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ g-sercom.adb<g-sercom-linux.adb @@ -953,6 +956,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-osinte.ads<s-osinte-linux-marte.ads \ s-osprim.adb<s-osprim-posix.adb \ s-taprop.adb<s-taprop-linux-marte.adb \ + s-taspri.ads<s-taspri-posix.ads \ system.ads<system-linux-x86.ads EXTRA_GNATRTL_TASKING_OBJS=a-exetim.o a-extiti.o @@ -969,6 +973,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-osinte.ads<s-osinte-linux-xenomai.ads \ s-osprim.adb<s-osprim-linux-xenomai.adb \ s-taprop.adb<s-taprop-linux-xenomai.adb \ + s-taspri.ads<s-taspri-linux-xenomai.ads \ system.ads<system-linux-x86-xenomai.ads EH_MECHANISM=-gcc @@ -977,6 +982,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-osinte.ads<s-osinte-linux.ads \ s-osprim.adb<s-osprim-posix.adb \ s-taprop.adb<s-taprop-linux.adb \ + s-taspri.ads<s-taspri-posix.ads \ s-tasinf.ads<s-tasinf-linux.ads \ s-tasinf.adb<s-tasinf-linux.adb \ system.ads<system-linux-x86.ads @@ -1549,11 +1555,11 @@ ifeq ($(strip $(filter-out mips linux%,$(arch) $(osys))),) endif ifeq ($(strip $(filter-out mipsel linux%,$(arch) $(osys))),) - LIBGNAT_TARGET_PAIRS = \ + LIBGNAT_TARGET_PAIRS_COMMON = \ a-intnam.ads<a-intnam-linux.ads \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ - s-linux.ads<s-linux.ads \ + s-linux.ads<s-linux-mipsel.ads \ s-osinte.adb<s-osinte-posix.adb \ s-osinte.ads<s-osinte-linux.ads \ s-osprim.adb<s-osprim-posix.adb \ @@ -1562,9 +1568,65 @@ ifeq ($(strip $(filter-out mipsel linux%,$(arch) $(osys))),) s-tasinf.adb<s-tasinf-linux.adb \ s-taspri.ads<s-taspri-posix-noaltstack.ads \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ - g-sercom.adb<g-sercom-linux.adb \ + g-sercom.adb<g-sercom-linux.adb + + LIBGNAT_TARGET_PAIRS_32 = \ system.ads<system-linux-mipsel.ads + LIBGNAT_TARGET_PAIRS_64 = \ + system.ads<system-linux-mips64el.ads + + ifeq ($(strip $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multi-os-directory)),../lib64) + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64) + else + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32) + endif + + TOOLS_TARGET_PAIRS = \ + mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ + indepsw.adb<indepsw-gnu.adb + + EXTRA_GNATRTL_TASKING_OBJS=s-linux.o + EH_MECHANISM=-gcc + THREADSLIB = -lpthread + GNATLIB_SHARED = gnatlib-shared-dual + GMEM_LIB = gmemlib + PREFIX_OBJS = $(PREFIX_REAL_OBJS) + LIBRARY_VERSION := $(LIB_VERSION) +endif + +ifeq ($(strip $(filter-out mips64el linux%,$(arch) $(osys))),) + LIBGNAT_TARGET_PAIRS_COMMON = \ + a-intnam.ads<a-intnam-linux.ads \ + s-inmaop.adb<s-inmaop-posix.adb \ + s-intman.adb<s-intman-posix.adb \ + s-linux.ads<s-linux-mipsel.ads \ + s-osinte.adb<s-osinte-posix.adb \ + s-osinte.ads<s-osinte-linux.ads \ + s-osprim.adb<s-osprim-posix.adb \ + s-taprop.adb<s-taprop-linux.adb \ + s-tasinf.ads<s-tasinf-linux.ads \ + s-tasinf.adb<s-tasinf-linux.adb \ + s-taspri.ads<s-taspri-posix-noaltstack.ads \ + s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + g-sercom.adb<g-sercom-linux.adb + + LIBGNAT_TARGET_PAIRS_32 = \ + system.ads<system-linux-mipsel.ads + + LIBGNAT_TARGET_PAIRS_64 = \ + system.ads<system-linux-mips64el.ads + + ifeq ($(strip $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multi-os-directory)),../lib64) + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64) + else + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32) + endif + TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ indepsw.adb<indepsw-gnu.adb diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 509717f681d..2ff9c117680 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -222,6 +222,7 @@ Implementation Defined Attributes * AST_Entry:: * Bit:: * Bit_Position:: +* Compiler_Version:: * Code_Address:: * Default_Bit_Order:: * Elaborated:: @@ -1502,7 +1503,7 @@ equality operators defined (such operations can be imported or declared as subprograms as required). Initialization is allowed only by constructor functions (see pragma @code{CPP_Constructor}). Such types are implicitly limited if not explicitly declared as limited or derived from a limited -type, and a warning is issued in that case. +type, and an error is issued in that case. Pragma @code{CPP_Class} is intended primarily for automatic generation using an automatic binding generator tool. @@ -1547,50 +1548,8 @@ where @var{T} is a tagged limited type imported from C++ with pragma The first form is the default constructor, used when an object of type @var{T} is created on the Ada side with no explicit constructor. The -second form covers all the non-default constructors of the type. -Constructors (including the copy constructor, which is simply a special -case of the second form in which the one and only argument is of type -@var{T}), can only appear in the following contexts: - -@itemize @bullet -@item -On the right side of an initialization of an object of type @var{T}. -@item -On the right side of an initialization of a record component of type @var{T}. -@item -In an extension aggregate for an object of a type derived from @var{T}. -@item -In an Ada 2005 limited aggregate. -@item -In an Ada 2005 nested limited aggregate. -@item -In an Ada 2005 limited aggregate that initializes an object built in -place by an extended return statement. -@end itemize - -@noindent -Although the constructor is described as a function that returns a value -on the Ada side, it is typically a procedure with an extra implicit -argument (the object being initialized) at the implementation -level. GNAT issues the appropriate call, whatever it is, to get the -object properly initialized. - -In the case of objects of derived types, in addition to the use of Ada -2005 limited aggregates and extended return statements, you may also -use one of the following two possible forms for declaring and creating -an object: - -@itemize @bullet -@item @code{New_Object : Derived_T} -@item @code{New_Object : Derived_T := (@var{constructor-call with} @dots{})} -@end itemize - -@noindent -In the first case the default constructor is called and extension fields -if any are initialized according to the default initialization -expressions in the Ada declaration. In the second case, the given -constructor is called and the extension aggregate indicates the explicit -values of the extension fields. +second form covers all the non-default constructors of the type. See +the GNAT users guide for details. If no constructors are imported, it is impossible to create any objects on the Ada side and the type is implicitly declared abstract. @@ -2451,7 +2410,8 @@ pragma Implicit_Packing; @noindent This is a configuration pragma that requests implicit packing for packed arrays for which a size clause is given but no explicit pragma Pack or -specification of Component_Size is present. Consider this example: +specification of Component_Size is present. It also applies to records +where no record representation clause is present. Consider this example: @smallexample @c ada type R is array (0 .. 7) of Boolean; @@ -2473,6 +2433,21 @@ specify the exact size that corresponds to the length of the array multiplied by the size in bits of the component type. @cindex Array packing +Similarly, the following example shows the use in the record case + +@smallexample @c ada +type r is record + a, b, c, d, e, f, g, h : boolean; + chr : character; +end record; +for r'size use 16; +@end smallexample + +@noindent +Without a pragma Pack, each Boolean field requires 8 bits, so the +minimum size is 72 bits, but with a pragma Pack, 16 bits would be +sufficient. The use of pragma Implciit_Packing allows this record +declaration to compile without an explicit pragma Pack. @node Pragma Import_Exception @unnumberedsec Pragma Import_Exception @cindex OpenVMS @@ -5173,6 +5148,8 @@ A turn off all optional warnings .A turn off warnings for failing assertions b turn on warnings for bad fixed value (not multiple of small) B* turn off warnings for bad fixed value (not multiple of small) +.b* turn on warnings for biased representation +.B turn off warnings for biased representation c turn on warnings for constant conditional C* turn off warnings for constant conditional .c turn on warnings for unrepped components @@ -5180,6 +5157,7 @@ C* turn off warnings for constant conditional d turn on warnings for implicit dereference D* turn off warnings for implicit dereference e treat all warnings as errors +.e turn on every optional warning f turn on warnings for unreferenced formal F* turn off warnings for unreferenced formal g* turn on warnings for unrecognized pragma @@ -5203,6 +5181,8 @@ O turn off warnings for address clause overlay .O* turn off warnings for out parameters assigned but not read p turn on warnings for ineffective pragma Inline in frontend P* turn off warnings for ineffective pragma Inline in frontend +.p turn on warnings for parameter ordering +.P* turn off warnings for parameter ordering q* turn on warnings for questionable missing parentheses Q turn off warnings for questionable missing parentheses r turn on warnings for redundant construct @@ -5218,6 +5198,8 @@ v* turn on warnings for unassigned variable V turn off warnings for unassigned variable w* turn on warnings for wrong low bound assumption W turn off warnings for wrong low bound assumption +.w turn on warnings for unnecessary Warnings Off pragmas +.W* turn off warnings for unnecessary Warnings Off pragmas x* turn on warnings for export/import X turn off warnings for export/import .x turn on warnings for non-local exceptions @@ -5371,6 +5353,7 @@ consideration, you should minimize the use of these attributes. * AST_Entry:: * Bit:: * Bit_Position:: +* Compiler_Version:: * Code_Address:: * Default_Bit_Order:: * Elaborated:: @@ -5523,6 +5506,15 @@ type @code{Universal_Integer}. The value depends only on the field @var{C} and is independent of the alignment of the containing record @var{R}. +@node Compiler_Version +@unnumberedsec Compiler_Version +@findex Compiler_Version +@noindent +@code{Standard'Compiler_Version} (@code{Standard} is the only allowed +prefix) yields a static string identifying the version of the compiler +being used to compile the unit containing the attribute reference. A +typical result would be something like "GNAT Pro 6.3.0w (20090221)". + @node Code_Address @unnumberedsec Code_Address @findex Code_Address diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 4ab16ee75a9..4e5e2141fda 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -14,7 +14,7 @@ @setfilename gnat_ugn.info @copying -Copyright @copyright{} 1995-2005, 2006, 2007, 2008 Free Software Foundation, +Copyright @copyright{} 1995-2009 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document @@ -3291,8 +3291,29 @@ end Pkg_Root; On the Ada side the constructor is represented by a function (whose name is arbitrary) that returns the classwide type corresponding to -the imported C++ class. +the imported C++ class. Although the constructor is described as a +function, it is typically a procedure with an extra implicit argument +(the object being initialized) at the implementation level. GNAT +issues the appropriate call, whatever it is, to get the object +properly initialized. +Constructors can only appear in the following contexts: + +@itemize @bullet +@item +On the right side of an initialization of an object of type @var{T}. +@item +On the right side of an initialization of a record component of type @var{T}. +@item +In an Ada 2005 limited aggregate. +@item +In an Ada 2005 nested limited aggregate. +@item +In an Ada 2005 limited aggregate that initializes an object built in +place by an extended return statement. +@end itemize + +@noindent In a declaration of an object whose type is a class imported from C++, either the default C++ constructor is implicitly called by GNAT, or else the required C++ constructor must be explicitly called in the @@ -3324,12 +3345,12 @@ In this case the components DT inherited from the C++ side must be initialized by a C++ constructor, and the additional Ada components of type DT are initialized by GNAT. The initialization of such an object is done either by default, or by means of a function returning -an aggregate of type DT, or by means of an extended aggregate. +an aggregate of type DT, or by means of an extension aggregate. @smallexample @c ada Obj5 : DT; Obj6 : DT := Function_Returning_DT (50); - Obj7 : DT := (Constructor (30,40) with (C_Value => 50)); + Obj7 : DT := (Constructor (30,40) with C_Value => 50); @end smallexample The declaration of @code{Obj5} invokes the default constructors: the @@ -5469,6 +5490,20 @@ The default is that warnings for redundant constructs are not given. @cindex @option{-gnatwR} (@command{gcc}) This switch suppresses warnings for redundant constructs. +@item -gnatw.r +@emph{Activate warnings for object renaming function.} +@cindex @option{-gnatw.r} (@command{gcc}) +This switch activates warnings for an object renaming that renames a +function call, which is equivalent to a constant declaration (as +opposed to renaming the function itself). The default is that these +warnings are given. This warning can also be turned on using +@option{-gnatwa}. + +@item -gnatw.R +@emph{Suppress warnings for object renaming function.} +@cindex @option{-gnatwT} (@command{gcc}) +This switch suppresses warnings for object renaming function. + @item -gnatws @emph{Suppress all warnings.} @cindex @option{-gnatws} (@command{gcc}) @@ -17601,6 +17636,15 @@ bodies, task bodies, entry bodies and statement sequences in package bodies Do not consider @code{exit} statements as @code{goto}s when computing Essential Complexity +@item ^--extra-exit-points^/EXTRA_EXIT_POINTS_ON^ +Report the extra exit points for subprogram bodies. As an exit point, this +metric counts @code{return} statements and raise statements in case when the +raised exception is not handled in the same body. In case of a function this +metric subtracts 1 from the number of exit points, because a function body +must contain at least one @code{return} statement. + +@item ^--no-extra-exit-points^/EXTRA_EXIT_POINTS_OFF^ +Do not report the extra exit points for subprogram bodies @end table @@ -20849,6 +20893,7 @@ used as a parameter of the @option{+R} or @option{-R} options. * Discriminated_Records:: * Enumeration_Ranges_In_CASE_Statements:: * Exceptions_As_Control_Flow:: +* Exits_From_Conditional_Loops:: * EXIT_Statements_With_No_Loop_Name:: * Expanded_Loop_Exit_Names:: * Explicit_Full_Discrete_Ranges:: @@ -20899,6 +20944,7 @@ used as a parameter of the @option{+R} or @option{-R} options. * Slices:: * Unassigned_OUT_Parameters:: * Uncommented_BEGIN_In_Package_Bodies:: +* Unconditional_Exits:: * Unconstrained_Array_Returns:: * Universal_Ranges:: * Unnamed_Blocks_And_Loops:: @@ -21115,6 +21161,20 @@ package body, task body or entry body is not flagged. The rule has no parameters. +@node Exits_From_Conditional_Loops +@subsection @code{Exits_From_Conditional_Loops} +@cindex @code{Exits_From_Conditional_Loops} (for @command{gnatcheck}) + +@noindent +Flag any exit statement if it transfers the control out of a @code{for} loop +or a @code{while} loop. This includes cases when the @code{exit} statement +applies to a @code{FOR} or @code{while} loop, and cases when it is enclosed +in some @code{for} or @code{while} loop, but transfers the control from some +outer (inconditional) @code{loop} statement. + +The rule has no parameters. + + @node EXIT_Statements_With_No_Loop_Name @subsection @code{EXIT_Statements_With_No_Loop_Name} @cindex @code{EXIT_Statements_With_No_Loop_Name} (for @command{gnatcheck}) @@ -21496,6 +21556,11 @@ Specifies the suffix for a type name. Specifies the suffix for an access type name. If this parameter is set, it overrides for access types the suffix set by the @code{Type_Suffix} parameter. +For access types, @emph{string} may have the following format: +@emph{suffix1(suffix2)}. That means that an access type name +should have the @emph{suffix1} suffix except for the case when +the designated type is also an access type, in this case the +type name should have the @emph{suffix1 & suffix2} suffix. @item Constant_Suffix=@emph{string} Specifies the suffix for a constant name. @@ -22213,6 +22278,14 @@ diagnostic message is attached to the line containing the first statement. This rule has no parameters. +@node Unconditional_Exits +@subsection @code{Unconditional_Exits} +@cindex @code{Unconditional_Exits} rule (for @command{gnatcheck}) + +@noindent +Flag unconditional @code{exit} statements. + +This rule has no parameters. @node Unconstrained_Array_Returns @subsection @code{Unconstrained_Array_Returns} diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8310cd2b697..8194a42ed8d 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -987,7 +987,7 @@ procedure GNATCmd is Last_Switches.Table (Index).all); end loop; - -- One switch for the standard GNAT library dir. + -- One switch for the standard GNAT library dir Last_Switches.Increment_Last; Last_Switches.Table @@ -1660,15 +1660,17 @@ begin -- --subdirs=... Specify Subdirs - if Argv'Length > Subdirs_Option'Length and then + if Argv'Length > Makeutl.Subdirs_Option'Length and then Argv - (Argv'First .. Argv'First + Subdirs_Option'Length - 1) = - Subdirs_Option + (Argv'First .. + Argv'First + Makeutl.Subdirs_Option'Length - 1) = + Makeutl.Subdirs_Option then Subdirs := new String' (Argv - (Argv'First + Subdirs_Option'Length .. Argv'Last)); + (Argv'First + Makeutl.Subdirs_Option'Length .. + Argv'Last)); Remove_Switch (Arg_Num); diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 16a9662b8e1..1a24b673a24 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2102,7 +2102,7 @@ __gnat_install_handler(void) #include <mach/vm_statistics.h> /* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ -char __gnat_alternate_stack[64 * 1024]; /* 2 * MINSIGSTKSZ */ +char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */ static void __gnat_error_handler (int sig, siginfo_t * si, void * uc); diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 705cbf20e3c..ccad170c108 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -78,9 +78,38 @@ extern void __gnat_plist_init (void); #define EXPAND_ARGV_RATE 128 static void -append_arg (int *index, LPWSTR value, char ***argv, int *last) +append_arg (int *index, LPWSTR dir, LPWSTR value, + char ***argv, int *last, int quoted) { int size; + LPWSTR fullvalue; + int vallen = _tcslen (value); + int dirlen; + + if (dir == NULL) + { + /* no dir prefix */ + dirlen = 0; + fullvalue = xmalloc ((vallen + 1) * sizeof(TCHAR)); + } + else + { + /* Add dir first */ + dirlen = _tcslen (dir); + + fullvalue = xmalloc ((dirlen + vallen + 1) * sizeof(TCHAR)); + _tcscpy (fullvalue, dir); + } + + /* Append value */ + + if (quoted) + { + _tcsncpy (fullvalue + dirlen, value + 1, vallen - 1); + fullvalue [dirlen + vallen - sizeof(TCHAR)] = _T('\0'); + } + else + _tcscpy (fullvalue + dirlen, value); if (*last <= *index) { @@ -88,9 +117,11 @@ append_arg (int *index, LPWSTR value, char ***argv, int *last) *argv = (char **) xrealloc (*argv, (*last) * sizeof (char *)); } - size = WS2SC (NULL, value, 0); - (*argv)[*index] = (char *) xmalloc (size + 1); - WS2SC ((*argv)[*index], value, size); + size = WS2SC (NULL, fullvalue, 0); + (*argv)[*index] = (char *) xmalloc (size + sizeof(TCHAR)); + WS2SC ((*argv)[*index], fullvalue, size); + + free (fullvalue); (*index)++; } @@ -143,7 +174,7 @@ __gnat_initialize (void *eh ATTRIBUTE_UNUSED) /* argv[0] is the executable full path-name. */ SearchPath (NULL, wargv[0], _T(".exe"), MAX_PATH, result, NULL); - append_arg (&argc_expanded, result, &gnat_argv, &last); + append_arg (&argc_expanded, NULL, result, &gnat_argv, &last, 0); for (k=1; k<wargc; k++) { @@ -157,39 +188,51 @@ __gnat_initialize (void *eh ATTRIBUTE_UNUSED) /* Wilcards are present, append all corresponding matches. */ WIN32_FIND_DATA FileData; HANDLE hDir = FindFirstFile (wargv[k], &FileData); + LPWSTR dir = NULL; + LPWSTR ldir = _tcsrchr (wargv[k], _T('\\')); + + if (ldir == NULL) + ldir = _tcsrchr (wargv[k], _T('/')); if (hDir == INVALID_HANDLE_VALUE) { /* No match, append arg as-is. */ - append_arg (&argc_expanded, wargv[k], &gnat_argv, &last); + append_arg (&argc_expanded, NULL, wargv[k], + &gnat_argv, &last, quoted); } else { + if (ldir != NULL) + { + int n = ldir - wargv[k] + 1; + dir = xmalloc ((n + 1) * sizeof (TCHAR)); + _tcsncpy (dir, wargv[k], n); + dir[n] = _T('\0'); + } + /* Append first match and all remaining ones. */ do { - append_arg (&argc_expanded, - FileData.cFileName, &gnat_argv, &last); + /* Do not add . and .. special entries */ + + if (_tcscmp (FileData.cFileName, _T(".")) != 0 + && _tcscmp (FileData.cFileName, _T("..")) != 0) + append_arg (&argc_expanded, dir, FileData.cFileName, + &gnat_argv, &last, 0); } while (FindNextFile (hDir, &FileData)); FindClose (hDir); + + if (dir != NULL) + free (dir); } } else { /* No wildcard. Store parameter as-is. Remove quote if needed. */ - if (quoted) - { - int len = _tcslen (wargv[k]); - - /* Remove ending quote */ - wargv[k][len-1] = _T('\0'); - append_arg - (&argc_expanded, &wargv[k][1], &gnat_argv, &last); - } - else - append_arg (&argc_expanded, wargv[k], &gnat_argv, &last); + append_arg (&argc_expanded, NULL, wargv[k], + &gnat_argv, &last, quoted); } } diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 1d0c2d4e79d..ee956dc3f77 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -724,7 +724,7 @@ package body Lib.Load is Check_Restricted_Unit (Load_Name, Error_Node); Error_Msg_Unit_1 := Uname_Actual; - Error_Msg + Error_Msg -- CODEFIX ("$$ is not a predefined library unit", Load_Msg_Sloc); else diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 3206bc1b009..955e6185cad 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -7778,6 +7778,12 @@ package body Make is end; end if; + elsif Argv'Length >= 8 and then + Argv (1 .. 8) = "--param=" + then + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); + else Scan_Make_Switches (Argv, Success); end if; @@ -7792,6 +7798,7 @@ package body Make is elsif (Argv'Length > 5 and then Argv (1 .. 5) = "-RTS=") or else (Argv'Length > 5 and then Argv (1 .. 5) = "-GCC=") + or else (Argv'Length > 8 and then Argv (1 .. 7) = "-param=") or else (Argv'Length > 10 and then Argv (1 .. 10) = "-GNATLINK=") or else (Argv'Length > 10 and then Argv (1 .. 10) = "-GNATBIND=") then diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 3c9b4d97242..c0dc9f16292 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -40,6 +40,10 @@ package Makeutl is Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; -- The project tree + Subdirs_Option : constant String := "--subdirs="; + -- Switch used to indicate that the real directories (object, exec, + -- library, ...) are subdirectories of those in the project file. + procedure Add (Option : String_Access; To : in out String_List_Access; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 229babfff00..e999c646b77 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1110,6 +1110,13 @@ package Opt is -- multiplied by the factor given here. The default value is used if no -- -gnatT switch appears. + Tagged_Type_Expansion : Boolean := True; + -- GNAT + -- Set True if tagged types and interfaces should be expanded by the + -- front-end. If False, the original tree is left unexpanded for + -- tagged types and dispatching calls, assuming the underlying target + -- supports it (e.g. case of JVM). + Task_Dispatching_Policy : Character := ' '; -- GNAT, GNATBIND -- Set to ' ' for the default case (no task dispatching policy specified). diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 04e2919cc24..770c499312b 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,8 @@ with System.Case_Util; use System.Case_Util; with GNAT.HTable; +with Alloc; +with Debug; with Fmap; use Fmap; with Gnatvsn; use Gnatvsn; with Hostparm; @@ -111,6 +113,9 @@ package body Osint is -- Converts a C String to an Ada String. Are we doing this to avoid withing -- Interfaces.C.Strings ??? + function Include_Dir_Default_Prefix return String_Access; + -- Same as exported version, except returns a String_Access + ------------------------------ -- Other Local Declarations -- ------------------------------ @@ -137,6 +142,20 @@ package body Osint is -- latest source, library and object files opened by Read_Source_File and -- Read_Library_Info. + package File_Name_Chars is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => Alloc.File_Name_Chars_Initial, + Table_Increment => Alloc.File_Name_Chars_Increment, + Table_Name => "File_Name_Chars"); + -- Table to store text to be printed by Dump_Source_File_Names + + The_Include_Dir_Default_Prefix : String_Access := null; + -- Value returned by Include_Dir_Default_Prefix. We don't initialize it + -- here, because that causes an elaboration cycle with Sdefault; we + -- initialize it lazily instead. + ------------------ -- Search Paths -- ------------------ @@ -717,6 +736,16 @@ package body Osint is end if; end Dir_In_Src_Search_Path; + ---------------------------- + -- Dump_Source_File_Names -- + ---------------------------- + + procedure Dump_Source_File_Names is + subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last; + begin + Write_Str (String (File_Name_Chars.Table (Rng))); + end Dump_Source_File_Names; + --------------------- -- Executable_Name -- --------------------- @@ -1392,22 +1421,19 @@ package body Osint is -- Include_Dir_Default_Prefix -- -------------------------------- - function Include_Dir_Default_Prefix return String is - Include_Dir : String_Access := - String_Access (Update_Path (Include_Dir_Default_Name)); - + function Include_Dir_Default_Prefix return String_Access is begin - if Include_Dir = null then - return ""; - - else - declare - Result : constant String := Include_Dir.all; - begin - Free (Include_Dir); - return Result; - end; + if The_Include_Dir_Default_Prefix = null then + The_Include_Dir_Default_Prefix := + String_Access (Update_Path (Include_Dir_Default_Name)); end if; + + return The_Include_Dir_Default_Prefix; + end Include_Dir_Default_Prefix; + + function Include_Dir_Default_Prefix return String is + begin + return Include_Dir_Default_Prefix.all; end Include_Dir_Default_Prefix; ---------------- @@ -2268,6 +2294,32 @@ package body Osint is return; end if; + -- Print out the file name, if requested, and if it's not part of the + -- runtimes, store it in File_Name_Chars. + + declare + Name : String renames Name_Buffer (1 .. Name_Len); + Inc : String renames Include_Dir_Default_Prefix.all; + + begin + if Debug.Debug_Flag_Dot_N then + Write_Line (Name); + end if; + + if Inc /= "" + and then Inc'Length < Name_Len + and then Name_Buffer (1 .. Inc'Length) = Inc + then + -- Part of runtimes, so ignore it + + null; + + else + File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); + File_Name_Chars.Append (ASCII.LF); + end if; + end; + -- Prepare to read data from the file Len := Integer (File_Length (Source_File_FD)); @@ -2292,9 +2344,9 @@ package body Osint is begin -- Allocate source buffer, allowing extra character at end for EOF - -- Some systems (e.g. VMS) have file types that require one - -- read per line, so read until we get the Len bytes or until - -- there are no more characters. + -- Some systems (e.g. VMS) have file types that require one read per + -- line, so read until we get the Len bytes or until there are no + -- more characters. Hi := Lo; loop @@ -2306,8 +2358,8 @@ package body Osint is Actual_Ptr (Hi) := EOF; -- Now we need to work out the proper virtual origin pointer to - -- return. This is exactly Actual_Ptr (0)'Address, but we have - -- to be careful to suppress checks to compute this address. + -- return. This is exactly Actual_Ptr (0)'Address, but we have to + -- be careful to suppress checks to compute this address. declare pragma Suppress (All_Checks); diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 4d82c86a5a2..5de8eced2ac 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -410,6 +410,12 @@ package Osint is -- Cache => True access to source file data does not incur a penalty if -- this data was previously retrieved. + procedure Dump_Source_File_Names; + -- Prints out the names of all source files that have been read by + -- Read_Source_File, except those that come from the run-time library + -- (i.e. Include_Dir_Default_Prefix). The text is sent to whatever Output + -- is currently using (e.g. standard output or standard error). + ------------------------------------------- -- Representation of Library Information -- ------------------------------------------- diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 951d3087540..046ac43e775 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -100,7 +100,8 @@ package body Ch12 is Scan; -- past GENERIC if Token = Tok_Private then - Error_Msg_SC ("PRIVATE goes before GENERIC, not after"); + Error_Msg_SC -- CODEFIX + ("PRIVATE goes before GENERIC, not after"); Scan; -- past junk PRIVATE token end if; @@ -179,7 +180,7 @@ package body Ch12 is Append (P_Formal_Subprogram_Declaration, Decls); else - Error_Msg_BC + Error_Msg_BC -- CODEFIX ("FUNCTION, PROCEDURE or PACKAGE expected here"); Resync_Past_Semicolon; end if; @@ -657,7 +658,8 @@ package body Ch12 is else if Token = Tok_Abstract then - Error_Msg_SC ("ABSTRACT must come before LIMITED"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before LIMITED"); Scan; -- past improper ABSTRACT if Token = Tok_New then @@ -805,15 +807,18 @@ package body Ch12 is if Token = Tok_Abstract then if Prev_Token = Tok_Tagged then - Error_Msg_SC ("ABSTRACT must come before TAGGED"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before TAGGED"); elsif Prev_Token = Tok_Limited then - Error_Msg_SC ("ABSTRACT must come before LIMITED"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before LIMITED"); end if; Resync_Past_Semicolon; elsif Token = Tok_Tagged then - Error_Msg_SC ("TAGGED must come before LIMITED"); + Error_Msg_SC -- CODEFIX + ("TAGGED must come before LIMITED"); Resync_Past_Semicolon; end if; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index b90e0840652..973f64360df 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -541,7 +541,8 @@ package body Ch3 is end if; if Token = Tok_Abstract then - Error_Msg_SC ("ABSTRACT must come before TAGGED"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before TAGGED"); Abstract_Present := True; Abstract_Loc := Token_Ptr; Scan; -- past ABSTRACT @@ -606,11 +607,13 @@ package body Ch3 is loop if Token = Tok_Tagged then - Error_Msg_SC ("TAGGED must come before LIMITED"); + Error_Msg_SC -- CODEFIX + ("TAGGED must come before LIMITED"); Scan; -- past TAGGED elsif Token = Tok_Abstract then - Error_Msg_SC ("ABSTRACT must come before LIMITED"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before LIMITED"); Scan; -- past ABSTRACT else @@ -1526,7 +1529,8 @@ package body Ch3 is end if; if Token = Tok_Aliased then - Error_Msg_SC ("ALIASED should be before CONSTANT"); + Error_Msg_SC -- CODEFIX + ("ALIASED should be before CONSTANT"); Scan; -- past ALIASED Set_Aliased_Present (Decl_Node, True); end if; @@ -1888,7 +1892,8 @@ package body Ch3 is end if; if Token = Tok_Abstract then - Error_Msg_SC ("ABSTRACT must come before NEW, not after"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before NEW, not after"); Scan; end if; @@ -2306,7 +2311,8 @@ package body Ch3 is -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order if Token = Tok_Delta then - Error_Msg_SC ("|DELTA must come before DIGITS"); + Error_Msg_SC -- CODEFIX + ("|DELTA must come before DIGITS"); Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); Scan; -- past DELTA Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); @@ -3791,7 +3797,8 @@ package body Ch3 is Scan; -- past PROTECTED if Token /= Tok_Procedure and then Token /= Tok_Function then - Error_Msg_SC ("FUNCTION or PROCEDURE expected"); + Error_Msg_SC -- CODEFIX + ("FUNCTION or PROCEDURE expected"); end if; end if; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 80a566beb5c..af91f1668d7 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -607,7 +607,8 @@ package body Ch4 is elsif Token = Tok_Range then if Expr_Form /= EF_Simple_Name then - Error_Msg_SC ("subtype mark must precede RANGE"); + Error_Msg_SC -- CODEFIX??? + ("subtype mark must precede RANGE"); raise Error_Resync; end if; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index e0a7e0af6f8..f782f51e024 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -178,7 +178,8 @@ package body Ch5 is procedure Junk_Declaration is begin if (not Declaration_Found) or All_Errors_Mode then - Error_Msg_SC ("declarations must come before BEGIN"); + Error_Msg_SC -- CODEFIX + ("declarations must come before BEGIN"); Declaration_Found := True; end if; @@ -450,7 +451,8 @@ package body Ch5 is and then Block_Label = Name_Go and then Token_Name = Name_To then - Error_Msg_SP ("goto is one word"); + Error_Msg_SP -- CODEFIX + ("goto is one word"); Append_To (Statement_List, P_Goto_Statement); Statement_Required := False; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index d91b2d9f15d..ea5df6dfb3b 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -227,7 +227,8 @@ package body Ch6 is Error_Msg_SC ("overriding indicator not allowed here!"); elsif Token /= Tok_Function and then Token /= Tok_Procedure then - Error_Msg_SC ("FUNCTION or PROCEDURE expected!"); + Error_Msg_SC -- CODEFIX + ("FUNCTION or PROCEDURE expected!"); end if; end if; @@ -1301,7 +1302,8 @@ package body Ch6 is end if; if Token = Tok_In then - Error_Msg_SC ("IN must precede OUT in parameter mode"); + Error_Msg_SC -- CODEFIX ??? + ("IN must precede OUT in parameter mode"); Scan; -- past IN Set_In_Present (Node, True); end if; @@ -1430,7 +1432,8 @@ package body Ch6 is Set_Constant_Present (Decl_Node); if Token = Tok_Aliased then - Error_Msg_SC ("ALIASED should be before CONSTANT"); + Error_Msg_SC -- CODEFIX + ("ALIASED should be before CONSTANT"); Scan; -- past ALIASED Set_Aliased_Present (Decl_Node); end if; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index d5c3549f23d..1271d478a73 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -651,7 +651,8 @@ package body Ch9 is Set_Must_Not_Override (Specification (Decl), Not_Overriding); else - Error_Msg_SC ("ENTRY, FUNCTION or PROCEDURE expected!"); + Error_Msg_SC -- CODEFIX + ("ENTRY, FUNCTION or PROCEDURE expected!"); end if; end if; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index e04b154e506..94e753976aa 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -717,7 +717,8 @@ package body Endh is if Error_Msg_Name_1 > Error_Name then if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then Error_Msg_Name_1 := Chars (Nam); - Error_Msg_N ("misspelling of %", End_Labl); + Error_Msg_N -- CODEFIX + ("misspelling of %", End_Labl); Syntax_OK := True; return; end if; @@ -839,29 +840,32 @@ package body Endh is end if; if End_Type = E_Case then - Error_Msg_SC ("`END CASE;` expected@ for CASE#!"); + Error_Msg_SC -- CODEFIX + ("`END CASE;` expected@ for CASE#!"); elsif End_Type = E_If then - Error_Msg_SC ("`END IF;` expected@ for IF#!"); + Error_Msg_SC -- CODEFIX + ("`END IF;` expected@ for IF#!"); elsif End_Type = E_Loop then if Error_Msg_Node_1 = Empty then - Error_Msg_SC + Error_Msg_SC -- CODEFIX ("`END LOOP;` expected@ for LOOP#!"); else - Error_Msg_SC ("`END LOOP &;` expected@!"); + Error_Msg_SC -- CODEFIX + ("`END LOOP &;` expected@!"); end if; elsif End_Type = E_Record then - Error_Msg_SC + Error_Msg_SC -- CODEFIX ("`END RECORD;` expected@ for RECORD#!"); elsif End_Type = E_Return then - Error_Msg_SC + Error_Msg_SC -- CODEFIX ("`END RETURN;` expected@ for RETURN#!"); elsif End_Type = E_Select then - Error_Msg_SC + Error_Msg_SC -- CODEFIX ("`END SELECT;` expected@ for SELECT#!"); -- All remaining cases are cases with a name (we do not treat @@ -870,9 +874,11 @@ package body Endh is elsif End_Type = E_Name or else (not Ins) then if Error_Msg_Node_1 = Empty then - Error_Msg_SC ("`END;` expected@ for BEGIN#!"); + Error_Msg_SC -- CODEFIX + ("`END;` expected@ for BEGIN#!"); else - Error_Msg_SC ("`END &;` expected@!"); + Error_Msg_SC -- CODEFIX + ("`END &;` expected@!"); end if; -- The other possibility is a missing END for a subprogram with a diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index 544998b623e..e21fb0434c6 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -205,7 +205,8 @@ begin begin Error_Msg_Unit_1 := Expect_Name; - Error_Msg ("$$ is not a predefined library unit!", Loc); + Error_Msg -- CODEFIX + ("$$ is not a predefined library unit!", Loc); -- In the predefined file case, we know the user did not -- construct their own package, but we got the wrong one. @@ -229,7 +230,8 @@ begin (Name_Id (Expect_Name), Name_Id (Actual_Name)) then Error_Msg_Unit_1 := Actual_Name; - Error_Msg ("possible misspelling of $$!", Loc); + Error_Msg -- CODEFIX + ("possible misspelling of $$!", Loc); end if; end; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 7ca24703507..eb77f860b4f 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -818,7 +818,7 @@ begin and then Num_SRef_Pragmas (Current_Source_File) = 0 and then Operating_Mode /= Check_Syntax then - Error_Msg + Error_Msg -- CODEFIX ("first % pragma must be first line of file", Pragma_Sloc); raise Error_Resync; end if; diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index a4c3b2d4999..9329b41cd14 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -443,7 +443,8 @@ package body Tchk is -- the possibility of a "C" confusion. elsif Token = Tok_Vertical_Bar then - Error_Msg_SC ("unexpected occurrence of ""'|"", did you mean OR'?"); + Error_Msg_SC -- CODEFIX + ("unexpected occurrence of ""'|"", did you mean OR'?"); Resync_Past_Semicolon; return; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index bf5680e2515..3672ca8145e 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -86,7 +86,8 @@ package body Util is M2 (P2 + J - 1) := Fold_Upper (S (J)); end loop; - Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); + Error_Msg_SC -- CODEFIX??? + (M2 (1 .. P2 - 1 + S'Last)); Token := T; return True; end if; @@ -119,7 +120,8 @@ package body Util is M1 (P1 + J - 1) := Fold_Upper (S (J)); end loop; - Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last)); + Error_Msg_SC -- CODFIX + (M1 (1 .. P1 - 1 + S'Last)); Token := T; return True; @@ -161,7 +163,8 @@ package body Util is if RM_Column_Check and then Token_Is_At_Start_Of_Line and then Start_Column <= Scope.Table (Scope.Last).Ecol then - Error_Msg_BC ("(style) incorrect layout"); + Error_Msg_BC -- CODEFIX + ("(style) incorrect layout"); end if; end Check_Bad_Layout; @@ -678,7 +681,8 @@ package body Util is Error_Msg_Name_1 := First_Attribute_Name; while Error_Msg_Name_1 <= Last_Attribute_Name loop if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then - Error_Msg_N ("\possible misspelling of %", Token_Node); + Error_Msg_N -- CODEFIX + ("\possible misspelling of %", Token_Node); exit; end if; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 49bd50e0e4c..001b2596d48 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1052,9 +1052,9 @@ package body Prj.Dect is end if; if Index /= 0 then - Error_Msg ("\?possible misspelling of """ & - List (Index).all & """", - Token_Ptr); + Error_Msg -- CODEFIX + ("\?possible misspelling of """ & + List (Index).all & """", Token_Ptr); end if; end; end if; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 5a76d397a29..f1f5550dc8c 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -298,8 +298,7 @@ package body Prj.Nmsc is procedure Check_Library_Attributes (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Current_Dir : String); + In_Tree : Project_Tree_Ref); -- Check the library attributes of project Project in project tree In_Tree -- and modify its data Data accordingly. -- Current_Dir should represent the current directory, and is passed for @@ -410,7 +409,6 @@ package body Prj.Nmsc is File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; - Language_Name : out Name_Id; Display_Language_Name : out Name_Id; Unit : out Name_Id; Lang_Kind : out Language_Kind; @@ -497,23 +495,25 @@ package body Prj.Nmsc is (Project : Project_Id; In_Tree : Project_Tree_Ref; Name : File_Name_Type; - Parent : Path_Name_Type; - Dir : out Path_Name_Type; - Display : out Path_Name_Type; + Path : out Path_Information; + Dir_Exists : out Boolean; Create : String := ""; - Current_Dir : String; Location : Source_Ptr := No_Location; + Must_Exist : Boolean := True; Externally_Built : Boolean := False); - -- Locate a directory. Name is the directory name. Parent is the root - -- directory, if Name a relative path name. Dir is set to the canonical - -- case path name of the directory, and Display is the directory path name - -- for display purposes. If the directory does not exist and Setup_Projects + -- Locate a directory. Name is the directory name. + -- Relative paths are resolved relative to the project's directory. + -- If the directory does not exist and Setup_Projects -- is True and Create is a non null string, an attempt is made to create - -- the directory. If the directory does not exist and Setup_Projects is - -- false, then Dir and Display are set to No_Name. + -- the directory. + -- If the directory does not exist, it is either created if Setup_Projects + -- is False (and then returned), or simply returned without checking for + -- its existence (if Must_Exist is False) or No_Path_Information is + -- returned. In all cases, Dir_Exists indicates whether the directory now + -- exists. -- - -- Current_Dir should represent the current directory, and is passed for - -- efficiency to avoid system calls to recompute it. + -- Create is also used for debugging traces to show which path we are + -- computing procedure Look_For_Sources (Project : Project_Id; @@ -829,7 +829,7 @@ package body Prj.Nmsc is -- Library attributes - Check_Library_Attributes (Project, In_Tree, Current_Dir); + Check_Library_Attributes (Project, In_Tree); if Current_Verbosity = High then Show_Source_Dirs (Project, In_Tree); @@ -1424,10 +1424,8 @@ package body Prj.Nmsc is -- Attribute Driver (<language>) - Get_Name_String (Element.Value.Value); - Lang_Index.Config.Compiler_Driver := - File_Name_Type (Element.Value.Value); + File_Name_Type (Element.Value.Value); when Name_Required_Switches => Put (Into_List => @@ -3342,8 +3340,7 @@ package body Prj.Nmsc is procedure Check_Library_Attributes (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Current_Dir : String) + In_Tree : Project_Tree_Ref) is Attributes : constant Prj.Variable_Id := Project.Decl.Attributes; @@ -3464,6 +3461,8 @@ package body Prj.Nmsc is end if; end Check_Library; + Dir_Exists : Boolean; + -- Start of processing for Check_Library_Attributes begin @@ -3545,51 +3544,30 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Lib_Dir.Value), - Project.Directory.Display_Name, - Project.Library_Dir.Name, - Project.Library_Dir.Display_Name, + Path => Project.Library_Dir, + Dir_Exists => Dir_Exists, Create => "library", - Current_Dir => Current_Dir, + Must_Exist => False, Location => Lib_Dir.Location, Externally_Built => Project.Externally_Built); - end if; - if Project.Library_Dir = No_Path_Information then + else + Dir_Exists := + Is_Directory + (Get_Name_String + (Project.Library_Dir.Display_Name)); + end if; + if not Dir_Exists then -- Get the absolute name of the library directory that -- does not exist, to report an error. - declare - Dir_Name : constant String := - Get_Name_String (Lib_Dir.Value); - - begin - if Is_Absolute_Path (Dir_Name) then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Lib_Dir.Value); - - else - Get_Name_String (Project.Directory.Display_Name); - - if Name_Buffer (Name_Len) /= Directory_Separator then - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Directory_Separator; - end if; - - Name_Buffer - (Name_Len + 1 .. Name_Len + Dir_Name'Length) := - Dir_Name; - Name_Len := Name_Len + Dir_Name'Length; - Err_Vars.Error_Msg_File_1 := Name_Find; - end if; - - -- Report the error - - Error_Msg - (Project, In_Tree, - "library directory { does not exist", - Lib_Dir.Location); - end; + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_Dir.Display_Name); + Error_Msg + (Project, In_Tree, + "library directory { does not exist", + Lib_Dir.Location); -- The library directory cannot be the same as the Object -- directory. @@ -3756,50 +3734,23 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Lib_ALI_Dir.Value), - Project.Directory.Display_Name, - Project.Library_ALI_Dir.Name, - Project.Library_ALI_Dir.Display_Name, + Path => Project.Library_ALI_Dir, Create => "library ALI", - Current_Dir => Current_Dir, + Dir_Exists => Dir_Exists, + Must_Exist => False, Location => Lib_ALI_Dir.Location, Externally_Built => Project.Externally_Built); - if Project.Library_ALI_Dir = No_Path_Information then - + if not Dir_Exists then -- Get the absolute name of the library ALI directory that -- does not exist, to report an error. - declare - Dir_Name : constant String := - Get_Name_String (Lib_ALI_Dir.Value); - - begin - if Is_Absolute_Path (Dir_Name) then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Lib_Dir.Value); - - else - Get_Name_String (Project.Directory.Display_Name); - - if Name_Buffer (Name_Len) /= Directory_Separator then - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Directory_Separator; - end if; - - Name_Buffer - (Name_Len + 1 .. Name_Len + Dir_Name'Length) := - Dir_Name; - Name_Len := Name_Len + Dir_Name'Length; - Err_Vars.Error_Msg_File_1 := Name_Find; - end if; - - -- Report the error - - Error_Msg - (Project, In_Tree, - "library 'A'L'I directory { does not exist", - Lib_ALI_Dir.Location); - end; + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_ALI_Dir.Display_Name); + Error_Msg + (Project, In_Tree, + "library 'A'L'I directory { does not exist", + Lib_ALI_Dir.Location); end if; if Project.Library_ALI_Dir /= Project.Library_Dir then @@ -4822,62 +4773,32 @@ package body Prj.Nmsc is declare Dir_Id : constant File_Name_Type := File_Name_Type (Lib_Src_Dir.Value); + Dir_Exists : Boolean; begin Locate_Directory (Project, In_Tree, Dir_Id, - Project.Directory.Display_Name, - Project.Library_Src_Dir.Name, - Project.Library_Src_Dir.Display_Name, + Path => Project.Library_Src_Dir, + Dir_Exists => Dir_Exists, + Must_Exist => False, Create => "library source copy", - Current_Dir => Current_Dir, Location => Lib_Src_Dir.Location, Externally_Built => Project.Externally_Built); -- If directory does not exist, report an error - if Project.Library_Src_Dir = No_Path_Information then - + if not Dir_Exists then -- Get the absolute name of the library directory that does -- not exist, to report an error. - declare - Dir_Name : constant String := - Get_Name_String (Dir_Id); - - begin - if Is_Absolute_Path (Dir_Name) then - Err_Vars.Error_Msg_File_1 := Dir_Id; - - else - Get_Name_String (Project.Directory.Name); - - if Name_Buffer (Name_Len) /= - Directory_Separator - then - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := - Directory_Separator; - end if; - - Name_Buffer - (Name_Len + 1 .. - Name_Len + Dir_Name'Length) := - Dir_Name; - Name_Len := Name_Len + Dir_Name'Length; - Err_Vars.Error_Msg_Name_1 := Name_Find; - end if; - - -- Report the error - - Error_Msg_File_1 := Dir_Id; - Error_Msg - (Project, In_Tree, - "Directory { does not exist", - Lib_Src_Dir.Location); - end; + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_Src_Dir.Display_Name); + Error_Msg + (Project, In_Tree, + "Directory { does not exist", + Lib_Src_Dir.Location); -- Report error if it is the same as the object directory @@ -5670,22 +5591,21 @@ package body Prj.Nmsc is else declare - Path_Name : Path_Name_Type; - Display_Path_Name : Path_Name_Type; + Path_Name : Path_Information; List : String_List_Id; Prev : String_List_Id; + Dir_Exists : Boolean; begin Locate_Directory (Project => Project, In_Tree => In_Tree, Name => From, - Parent => Project.Directory.Display_Name, - Dir => Path_Name, - Display => Display_Path_Name, - Current_Dir => Current_Dir); + Path => Path_Name, + Dir_Exists => Dir_Exists, + Must_Exist => False); - if Path_Name = No_Path then + if not Dir_Exists then Err_Vars.Error_Msg_File_1 := From; if Location = No_Location then @@ -5703,14 +5623,14 @@ package body Prj.Nmsc is else declare Path : constant String := - Get_Name_String (Path_Name) & + Get_Name_String (Path_Name.Name) & Directory_Separator; Last_Path : constant Natural := Compute_Directory_Last (Path); Path_Id : Name_Id; Display_Path : constant String := Get_Name_String - (Display_Path_Name) & + (Path_Name.Display_Name) & Directory_Separator; Last_Display_Path : constant Natural := Compute_Directory_Last @@ -5802,6 +5722,8 @@ package body Prj.Nmsc is -- Start of processing for Get_Directories + Dir_Exists : Boolean; + begin if Current_Verbosity = High then Write_Line ("Starting to look for directories"); @@ -5835,48 +5757,41 @@ package body Prj.Nmsc is Object_Dir.Location); else - -- We check that the specified object directory does exist + -- We check that the specified object directory does exist. + -- However, even when it doesn't exist, we set it to a default + -- value. This is for the benefit of tools that recover from + -- errors; for example, these tools could create the non existent + -- directory. + -- We always return an absolute directory name though Locate_Directory (Project, In_Tree, File_Name_Type (Object_Dir.Value), - Project.Directory.Display_Name, - Project.Object_Directory.Name, - Project.Object_Directory.Display_Name, + Path => Project.Object_Directory, Create => "object", + Dir_Exists => Dir_Exists, Location => Object_Dir.Location, - Current_Dir => Current_Dir, + Must_Exist => False, Externally_Built => Project.Externally_Built); - if Project.Object_Directory = No_Path_Information then - - -- The object directory does not exist, report an error if the - -- project is not externally built. - - if not Project.Externally_Built then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Object_Dir.Value); - Error_Msg - (Project, In_Tree, - "object directory { not found", - Project.Location); - end if; - - -- Do not keep a nil Object_Directory. Set it to the specified - -- (relative or absolute) path. This is for the benefit of - -- tools that recover from errors; for example, these tools - -- could create the non existent directory. + if not Dir_Exists + and then not Project.Externally_Built + then + -- The object directory does not exist, report an error if + -- the project is not externally built. - Project.Object_Directory.Display_Name := - Path_Name_Type (Object_Dir.Value); - Project.Object_Directory.Name := - Path_Name_Type (Canonical_Case_File_Name (Object_Dir.Value)); + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Object_Dir.Value); + Error_Msg + (Project, In_Tree, + "object directory { not found", + Project.Location); end if; end if; - elsif Project.Object_Directory /= No_Path_Information and then - Subdirs /= null + elsif Project.Object_Directory /= No_Path_Information + and then Subdirs /= null then Name_Len := 1; Name_Buffer (1) := '.'; @@ -5884,12 +5799,10 @@ package body Prj.Nmsc is (Project, In_Tree, Name_Find, - Project.Directory.Display_Name, - Project.Object_Directory.Name, - Project.Object_Directory.Display_Name, + Path => Project.Object_Directory, Create => "object", + Dir_Exists => Dir_Exists, Location => Object_Dir.Location, - Current_Dir => Current_Dir, Externally_Built => Project.Externally_Built); end if; @@ -5925,15 +5838,13 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Exec_Dir.Value), - Project.Directory.Display_Name, - Project.Exec_Directory.Name, - Project.Exec_Directory.Display_Name, + Path => Project.Exec_Directory, + Dir_Exists => Dir_Exists, Create => "exec", Location => Exec_Dir.Location, - Current_Dir => Current_Dir, Externally_Built => Project.Externally_Built); - if Project.Exec_Directory = No_Path_Information then + if not Dir_Exists then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg (Project, In_Tree, @@ -6544,14 +6455,15 @@ package body Prj.Nmsc is (Project : Project_Id; In_Tree : Project_Tree_Ref; Name : File_Name_Type; - Parent : Path_Name_Type; - Dir : out Path_Name_Type; - Display : out Path_Name_Type; + Path : out Path_Information; + Dir_Exists : out Boolean; Create : String := ""; - Current_Dir : String; Location : Source_Ptr := No_Location; + Must_Exist : Boolean := True; Externally_Built : Boolean := False) is + Parent : constant Path_Name_Type := + Project.Directory.Display_Name; The_Parent : constant String := Get_Name_String (Parent) & Directory_Separator; The_Parent_Last : constant Natural := @@ -6591,8 +6503,8 @@ package body Prj.Nmsc is Write_Line (""")"); end if; - Dir := No_Path; - Display := No_Path; + Path := No_Path_Information; + Dir_Exists := False; if Is_Absolute_Path (Get_Name_String (The_Name)) then Full_Name := The_Name; @@ -6654,19 +6566,24 @@ package body Prj.Nmsc is end if; end if; - if Is_Directory (Full_Path_Name.all) then + Dir_Exists := Is_Directory (Full_Path_Name.all); + + if not Must_Exist or else Dir_Exists then declare Normed : constant String := Normalize_Pathname (Full_Path_Name.all, - Directory => Current_Dir, + Directory => + The_Parent (The_Parent'First .. The_Parent_Last), Resolve_Links => False, Case_Sensitive => True); Canonical_Path : constant String := Normalize_Pathname (Normed, - Directory => Current_Dir, + Directory => + The_Parent + (The_Parent'First .. The_Parent_Last), Resolve_Links => Opt.Follow_Links_For_Dirs, Case_Sensitive => False); @@ -6674,11 +6591,11 @@ package body Prj.Nmsc is begin Name_Len := Normed'Length; Name_Buffer (1 .. Name_Len) := Normed; - Display := Name_Find; + Path.Display_Name := Name_Find; Name_Len := Canonical_Path'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path; - Dir := Name_Find; + Path.Name := Name_Find; end; end if; @@ -7270,7 +7187,6 @@ package body Prj.Nmsc is File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; - Language_Name : out Name_Id; Display_Language_Name : out Name_Id; Unit : out Name_Id; Lang_Kind : out Language_Kind; @@ -7346,12 +7262,10 @@ package body Prj.Nmsc is Tmp_Lang := Project.Languages; while Tmp_Lang /= No_Language_Index loop - Language_Name := Tmp_Lang.Name; - if Current_Verbosity = High then Write_Line (" Testing language " - & Get_Name_String (Language_Name) + & Get_Name_String (Tmp_Lang.Name) & " Header_File=" & Header_File'Img); end if; @@ -7424,7 +7338,6 @@ package body Prj.Nmsc is Src_Ind : Source_File_Index; Unit : Name_Id; Source_To_Replace : Source_Id := No_Source; - Language_Name : Name_Id; Display_Language_Name : Name_Id; Lang_Kind : Language_Kind; Kind : Source_Kind := Spec; @@ -7489,7 +7402,6 @@ package body Prj.Nmsc is File_Name => File_Name, Alternate_Languages => Alternate_Languages, Language => Language, - Language_Name => Language_Name, Display_Language_Name => Display_Language_Name, Unit => Unit, Lang_Kind => Lang_Kind, diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb index 86f47ec67d2..92010bf7cfa 100644 --- a/gcc/ada/prj-pars.adb +++ b/gcc/ada/prj-pars.adb @@ -45,17 +45,18 @@ package body Prj.Pars is Project_File_Name : String; Packages_To_Check : String_List_Access := All_Packages; When_No_Sources : Error_Warning := Error; + Report_Error : Put_Line_Access := null; Reset_Tree : Boolean := True; - Is_Config_File : Boolean) + Is_Config_File : Boolean := False) is - Project_Node_Tree : constant Project_Node_Tree_Ref := - new Project_Node_Tree_Data; Project_Node : Project_Node_Id := Empty_Node; The_Project : Project_Id := No_Project; Success : Boolean := True; Current_Dir : constant String := Get_Current_Dir; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; begin + Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); -- Parse the main project file into a tree @@ -72,18 +73,19 @@ package body Prj.Pars is -- If there were no error, process the tree - if Present (Project_Node) then + if Project_Node /= Empty_Node then Prj.Proc.Process (In_Tree => In_Tree, Project => The_Project, Success => Success, From_Project_Node => Project_Node, From_Project_Node_Tree => Project_Node_Tree, - Report_Error => null, - When_No_Sources => When_No_Sources, + Report_Error => Report_Error, Reset_Tree => Reset_Tree, + When_No_Sources => When_No_Sources, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File); + Prj.Err.Finalize; if not Success then @@ -93,6 +95,8 @@ package body Prj.Pars is Project := The_Project; + -- ??? Should free the project_node_tree, no longer useful + exception when X : others => diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads index 02f149131a9..2c439ad115f 100644 --- a/gcc/ada/prj-pars.ads +++ b/gcc/ada/prj-pars.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ --- Implements the parsing of project files +-- General wrapper for the parsing of project files package Prj.Pars is @@ -36,21 +36,29 @@ package Prj.Pars is Project_File_Name : String; Packages_To_Check : String_List_Access := All_Packages; When_No_Sources : Error_Warning := Error; + Report_Error : Prj.Put_Line_Access := null; Reset_Tree : Boolean := True; - Is_Config_File : Boolean); - -- Parse a project files and all its imported project files, in the - -- project tree In_Tree. + Is_Config_File : Boolean := False); + -- Parse and process a project files and all its imported project files, in + -- the project tree In_Tree. + -- All the project files are parsed (through Prj.Tree) to create a tree in + -- memory. That tree is then processed (through Prj.Proc) to create a + -- expanded representation of the tree based on the current scenario + -- variables. This function is only a convenient wrapper over other + -- services provided in the Prj.* package hierarchy. -- - -- If parsing is successful, Project_Id is the project ID - -- of the main project file; otherwise, Project_Id is set - -- to No_Project. + -- If parsing is successful, Project is the project ID of the root project + -- file; otherwise, Project_Id is set to No_Project. Project_Node_Tree is + -- set to the tree (unprocessed) representation of the project file. This + -- tree is permanently correct, whereas Project will need to be recomputed + -- if the scenario variables change. -- -- Packages_To_Check indicates the packages where any unknown attribute - -- produces an error. For other packages, an unknown attribute produces - -- a warning. + -- produces an error. For other packages, an unknown attribute produces a + -- warning. -- - -- When_No_Sources indicates what should be done when no sources - -- are found in a project for a specified or implied language. + -- When_No_Sources indicates what should be done when no sources are found + -- in a project for a specified or implied language. -- -- When Reset_Tree is True, all the project data are removed from the -- project table before processing. diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads index f95f210a50e..e15c8efd283 100644 --- a/gcc/ada/prj-proc.ads +++ b/gcc/ada/prj-proc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,57 +31,64 @@ with Prj.Tree; use Prj.Tree; package Prj.Proc is - procedure Process + procedure Process_Project_Tree_Phase_1 (In_Tree : Project_Tree_Ref; Project : out Project_Id; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning := Error; - Reset_Tree : Boolean := True; - Current_Dir : String := ""; - Is_Config_File : Boolean); - -- Process a project file tree into project file data structures. If - -- Report_Error is null, use the error reporting mechanism. Otherwise, - -- report errors using Report_Error. + Reset_Tree : Boolean := True); + -- Process a project tree (ie the direct resulting of parsing a .gpr file) + -- based on the current scenario variables. -- - -- Current_Dir is for optimization purposes, avoiding extra system calls. + -- The result of this phase_1 is a partial project tree (Project) where + -- only a few fields have been initialized (in particular the list of + -- languages). These are the fields that are necessary to run gprconfig if + -- needed to automatically generate a configuration file. This first phase + -- of the processing does not require a configuration file. + -- + -- If Report_Error is null, use the error reporting mechanism. Otherwise, + -- report errors using Report_Error. -- -- When_No_Sources indicates what should be done when no sources are found -- in a project for a specified or implied language. -- -- When Reset_Tree is True, all the project data are removed from the -- project table before processing. - -- - -- Process is a bit of a junk name, how about Process_Project_Tree??? - -- - -- The two procedures that follow are implementing procedure Process in - -- two successive phases. They are used by gprbuild/gprclean to add the - -- configuration attributes between the two phases. - -- - -- Is_Config_File should be true if Project is a config file (.cgpr) - procedure Process_Project_Tree_Phase_1 + procedure Process_Project_Tree_Phase_2 (In_Tree : Project_Tree_Ref; - Project : out Project_Id; + Project : Project_Id; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Report_Error : Put_Line_Access; - Reset_Tree : Boolean := True); - -- See documentation of parameters in procedure Process above + When_No_Sources : Error_Warning := Error; + Current_Dir : String; + Is_Config_File : Boolean); + -- Perform the second phase of the processing, filling the rest of the + -- project with the information extracted from the project tree. This phase + -- requires that the configuration file has already been parsed (in fact + -- we currently assume that the contents of the configuration file has + -- been included in Project through Confgpr.Apply_Config_File). The + -- parameters are the same as for phase_1, with the addition of: + -- + -- Current_Dir is for optimization purposes, avoiding extra system calls. + -- + -- Is_Config_File should be true if Project is a config file (.cgpr) - procedure Process_Project_Tree_Phase_2 + procedure Process (In_Tree : Project_Tree_Ref; - Project : Project_Id; + Project : out Project_Id; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Report_Error : Put_Line_Access; When_No_Sources : Error_Warning := Error; - Current_Dir : String; + Reset_Tree : Boolean := True; + Current_Dir : String := ""; Is_Config_File : Boolean); - -- See documentation of parameters in procedure Process above + -- Performs the two phases of the processing end Prj.Proc; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 83f49442617..09b65f84376 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -44,10 +44,6 @@ package Prj is -- Name used to replace others as an index of an associative array -- attribute in situations where this is allowed. - Subdirs_Option : constant String := "--subdirs="; - -- Switch used to indicate that the real directories (object, exec, - -- library, ...) are subdirectories of those in the project file. - Subdirs : String_Ptr := null; -- The value after the equal sign in switch --subdirs=... -- Contains the relative subdirectory. diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index d05aef01162..41dae0f59c9 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -305,6 +305,9 @@ package body Rtsfind is elsif U_Id in Ada_Streams_Child then Name_Buffer (12) := '.'; + elsif U_Id in Ada_Strings_Child then + Name_Buffer (12) := '.'; + elsif U_Id in Ada_Text_IO_Child then Name_Buffer (12) := '.'; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 5439f4e0e17..59c9835088c 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -61,6 +61,9 @@ package Rtsfind is -- Names of the form Ada_Streams_xxx are second level children -- of Ada.Streams. + -- Names of the form Ada_Strings_xxx are second level children + -- of Ada.Strings. + -- Names of the form Ada_Text_IO_xxx are second level children of -- Ada.Text_IO. @@ -120,6 +123,7 @@ package Rtsfind is Ada_Interrupts, Ada_Real_Time, Ada_Streams, + Ada_Strings, Ada_Tags, Ada_Task_Identification, Ada_Task_Termination, @@ -149,6 +153,10 @@ package Rtsfind is Ada_Streams_Stream_IO, + -- Children of Ada.Strings + + Ada_Strings_Unbounded, + -- Children of Ada.Text_IO (for Text_IO_Kludge) Ada_Text_IO_Decimal_IO, @@ -404,6 +412,11 @@ package Rtsfind is subtype Ada_Streams_Child is Ada_Child range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO; + -- Range of values for children of Ada.Streams + + subtype Ada_Strings_Child is Ada_Child + range Ada_Strings_Unbounded .. Ada_Strings_Unbounded; + -- Range of values for children of Ada.Strings subtype Ada_Text_IO_Child is Ada_Child range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO; @@ -530,6 +543,8 @@ package Rtsfind is RE_Stream_Access, -- Ada.Streams.Stream_IO + RE_Unbounded_String, -- Ada.Strings.Unbounded + RE_Access_Level, -- Ada.Tags RE_Address_Array, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags @@ -1226,6 +1241,7 @@ package Rtsfind is RE_TA_WWC, -- System.Partition_Interface RE_TA_String, -- System.Partition_Interface RE_TA_ObjRef, -- System.Partition_Interface + RE_TA_Std_String, -- System.Partition_Interface RE_TA_TC, -- System.Partition_Interface RE_TC_Alias, -- System.Partition_Interface @@ -1693,6 +1709,8 @@ package Rtsfind is RE_Stream_Access => Ada_Streams_Stream_IO, + RE_Unbounded_String => Ada_Strings_Unbounded, + RE_Access_Level => Ada_Tags, RE_Address_Array => Ada_Tags, RE_Addr_Ptr => Ada_Tags, @@ -2380,6 +2398,7 @@ package Rtsfind is RE_TA_WWC => System_Partition_Interface, RE_TA_String => System_Partition_Interface, RE_TA_ObjRef => System_Partition_Interface, + RE_TA_Std_String => System_Partition_Interface, RE_TA_TC => System_Partition_Interface, RE_TC_Alias => System_Partition_Interface, diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index b3084775ff1..c6abba09bbf 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -73,12 +73,13 @@ package body System.File_IO is -- Points to list of names of temporary files. Note that this global -- variable must be properly protected to provide thread safety. - type File_IO_Clean_Up_Type is new Controlled with null record; + type File_IO_Clean_Up_Type is new Limited_Controlled with null record; -- The closing of all open files and deletion of temporary files is an - -- action which takes place at the end of execution of the main program. - -- This action can be implemented using a library level object which - -- gets finalized at the end of the main program execution. The above is - -- a controlled type introduced for this purpose. + -- action that takes place at the end of execution of the main program. + -- This action is implemented using a library level object which gets + -- finalized at the end of program execution. Note that the type is + -- limited, in order to stop the compiler optimizing away the declaration + -- which would be allowed in the non-limited case. procedure Finalize (V : in out File_IO_Clean_Up_Type); -- This is the finalize operation that is used to do the cleanup diff --git a/gcc/ada/s-linux-alpha.ads b/gcc/ada/s-linux-alpha.ads index 2f1112f7b2d..cdc716c727d 100644 --- a/gcc/ada/s-linux-alpha.ads +++ b/gcc/ada/s-linux-alpha.ads @@ -104,8 +104,9 @@ package System.Linux is -- struct_sigaction offsets - sa_mask_pos : constant := Standard'Address_Size / 8; - sa_flags_pos : constant := 128 + sa_mask_pos; + sa_handler_pos : constant := 0; + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; SA_SIGINFO : constant := 16#40#; SA_ONSTACK : constant := 16#01#; diff --git a/gcc/ada/s-linux-hppa.ads b/gcc/ada/s-linux-hppa.ads index 2ee2ad9011d..16393c539f6 100644 --- a/gcc/ada/s-linux-hppa.ads +++ b/gcc/ada/s-linux-hppa.ads @@ -96,8 +96,9 @@ package System.Linux is -- struct_sigaction offsets - sa_flags_pos : constant := Standard'Address_Size / 8; - sa_mask_pos : constant := sa_flags_pos * 2; + sa_handler_pos : constant := 0; + sa_flags_pos : constant := Standard'Address_Size / 8; + sa_mask_pos : constant := sa_flags_pos * 2; SA_SIGINFO : constant := 16#10#; SA_ONSTACK : constant := 16#01#; diff --git a/gcc/ada/s-linux-mipsel.ads b/gcc/ada/s-linux-mipsel.ads new file mode 100644 index 00000000000..c0911d8d16a --- /dev/null +++ b/gcc/ada/s-linux-mipsel.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the mipsel version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + -- struct_sigaction offsets + + sa_handler_pos : constant := Standard'Address_Size / 8; + sa_mask_pos : constant := 2 * Standard'Address_Size / 8; + sa_flags_pos : constant := 0; + + SA_SIGINFO : constant := 16#04#; + SA_ONSTACK : constant := 16#08000000#; + + type struct_pthread_fast_lock is record + status : Long_Integer; + spinlock : Integer; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : Integer; + m_count : Integer; + m_owner : System.Address; + m_kind : Integer; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + +end System.Linux; diff --git a/gcc/ada/s-linux.ads b/gcc/ada/s-linux.ads index b0612bd2d42..83b07c018e6 100644 --- a/gcc/ada/s-linux.ads +++ b/gcc/ada/s-linux.ads @@ -94,8 +94,9 @@ package System.Linux is -- struct_sigaction offsets - sa_mask_pos : constant := Standard'Address_Size / 8; - sa_flags_pos : constant := 128 + sa_mask_pos; + sa_handler_pos : constant := 0; + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; SA_SIGINFO : constant := 16#04#; SA_ONSTACK : constant := 16#08000000#; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 24555f1278a..694fcf1b622 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1184,7 +1184,7 @@ TXT(" subtype H_Length_T is Interfaces.C." h_length_t ";") -- Fields of struct msghdr */ -#if defined (__VMS) || defined (__sun__) || defined (__hpux__) +#if defined (__sun__) || defined (__hpux__) # define msg_iovlen_t "int" #else # define msg_iovlen_t "size_t" diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index 66c2ac0b92e..71cbe1517ab 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -285,7 +285,7 @@ package System.OS_Interface is pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); -- The alternate signal stack for stack overflows - Alternate_Stack_Size : constant := 64 * 1024; + Alternate_Stack_Size : constant := 32 * 1024; -- This must be in keeping with init.c:__gnat_alternate_stack Stack_Base_Available : constant Boolean := False; diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index a663aa8de9b..5d2fdccb69f 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -513,9 +513,9 @@ private pragma Warnings (Off); for struct_sigaction use record - sa_handler at 0 range 0 .. Standard'Address_Size - 1; - sa_mask at Linux.sa_mask_pos range 0 .. 1023; - sa_flags at Linux.sa_flags_pos range 0 .. Standard'Address_Size - 1; + sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1; + sa_mask at Linux.sa_mask_pos range 0 .. 1023; + sa_flags at Linux.sa_flags_pos range 0 .. Standard'Address_Size - 1; end record; -- We intentionally leave sa_restorer unspecified and let the compiler -- append it after the last field, so disable corresponding warning. diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 914c101afdc..56b1e4cc404 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -377,19 +377,19 @@ package body Scng is if Source (Scan_Ptr) = '_' then if Source (Scan_Ptr - 1) = '_' then - Error_Msg_S + Error_Msg_S -- CODEFIX ("two consecutive underlines not permitted"); else - Error_Msg_S + Error_Msg_S -- CODEFIX??? ("underline cannot follow punctuation character"); end if; else if Source (Scan_Ptr - 1) = '_' then - Error_Msg_S + Error_Msg_S -- CODEFIX??? ("punctuation character cannot follow underline"); else - Error_Msg_S + Error_Msg_S -- CODEFIX??? ("two consecutive punctuation characters not permitted"); end if; end if; diff --git a/gcc/ada/sdefault.ads b/gcc/ada/sdefault.ads index 3b3c8899875..21745fbb674 100644 --- a/gcc/ada/sdefault.ads +++ b/gcc/ada/sdefault.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -25,7 +25,8 @@ -- This package contains functions that return the default values for the -- include and object file directories, target name, default library --- subdirectory (libsubdir) prefix, and the target OS. +-- subdirectory (libsubdir) prefix, and the target OS. The body is generated +-- automatically by the build process. with Types; use Types; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 084a7200a06..047460442fb 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1760,7 +1760,7 @@ package body Sem is -- If it's a body, then ignore it, unless it's an instance (in -- which case we do the spec), or it's the main unit (in which -- case we do it). Note that it could be both, in which case we - -- do the spec first. + -- do the with_clauses of spec and body first, when N_Package_Body | N_Subprogram_Body => declare @@ -1783,7 +1783,15 @@ package body Sem is if Is_Generic_Instance (Entity) then declare Spec_Unit : constant Node_Id := Library_Unit (CU); + begin + -- Move context of body to that of spec, so it + -- appears before the spec itself, in case it + -- contains nested instances that generate late + -- with_clauses that got attached to the body. + + Append_List + (Context_Items (CU), Context_Items (Spec_Unit)); Do_Unit_And_Dependents (Spec_Unit, Unit (Spec_Unit)); end; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9b5efbccd42..66653f643e9 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -756,12 +756,12 @@ package body Sem_Aggr is -- Report at most two suggestions if Nr_Of_Suggestions = 1 then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("\possible misspelling of&", Component, Suggestion_1); elsif Nr_Of_Suggestions = 2 then Error_Msg_Node_2 := Suggestion_2; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("\possible misspelling of& or&", Component, Suggestion_1); end if; end Check_Misspelled_Component; @@ -2175,6 +2175,11 @@ package body Sem_Aggr is if Etype (Imm_Type) = Base_Type (A_Type) then return True; + elsif Is_CPP_Constructor_Call (A) + and then Etype (Imm_Type) = Base_Type (Etype (A_Type)) + then + return True; + -- The base type of the parent type may appear as a private -- extension if it is declared as such in a parent unit of -- the current one. For consistency of the subsequent analysis @@ -2290,6 +2295,7 @@ package body Sem_Aggr is if Is_Class_Wide_Type (Etype (A)) and then Nkind (Original_Node (A)) = N_Function_Call + and then not Is_CPP_Constructor_Call (Original_Node (A)) then -- If the ancestor part is a dispatching call, it appears -- statically to be a legal ancestor, but it yields any @@ -2779,6 +2785,14 @@ package body Sem_Aggr is Check_Non_Static_Context (Expr); Check_Unset_Reference (Expr); + -- Check wrong use of class-wide types + + if Is_Class_Wide_Type (Etype (Expr)) + and then not Is_CPP_Constructor_Call (Expr) + then + Error_Msg_N ("dynamically tagged expression not allowed", Expr); + end if; + if not Has_Expansion_Delayed (Expr) then Aggregate_Constraint_Checks (Expr, Expr_Type); end if; @@ -3065,12 +3079,27 @@ package body Sem_Aggr is Parent_Typ_List := New_Elmt_List; -- If this is an extension aggregate, the component list must - -- include all components that are not in the given ancestor - -- type. Otherwise, the component list must include components - -- of all ancestors, starting with the root. + -- include all components that are not in the given ancestor type. + -- Otherwise, the component list must include components of all + -- ancestors, starting with the root. if Nkind (N) = N_Extension_Aggregate then - Root_Typ := Base_Type (Etype (Ancestor_Part (N))); + + -- Handle case where ancestor part is a C++ constructor. In + -- this case it must be a function returning a class-wide type. + -- If the ancestor part is a C++ constructor, then it must be a + -- function returning a class-wide type, so handle that here. + + if Is_CPP_Constructor_Call (Ancestor_Part (N)) then + pragma Assert + (Is_Class_Wide_Type (Etype (Ancestor_Part (N)))); + Root_Typ := Root_Type (Etype (Ancestor_Part (N))); + + -- Normal case, not a C++ constructor + else + Root_Typ := Base_Type (Etype (Ancestor_Part (N))); + end if; + else Root_Typ := Root_Type (Typ); @@ -3313,6 +3342,7 @@ package body Sem_Aggr is then if Is_Record_Type (Ctyp) and then Has_Discriminants (Ctyp) + and then not Is_Private_Type (Ctyp) then -- We build a partially initialized aggregate with the -- values of the discriminants and box initialization @@ -3321,6 +3351,9 @@ package body Sem_Aggr is -- the component. The capture of discriminants must -- be recursive because subcomponents may be contrained -- (transitively) by discriminants of enclosing types. + -- For a private type with discriminants, a call to the + -- initialization procedure will be generated, and no + -- subaggregate is needed. Capture_Discriminants : declare Loc : constant Source_Ptr := Sloc (N); @@ -3445,7 +3478,7 @@ package body Sem_Aggr is (Inner_Comp, New_Aggr, Component_Associations (Aggr)); - -- Collect disciminant values, and recurse. + -- Collect discriminant values and recurse Add_Discriminant_Values (New_Aggr, Assoc_List); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 449b0556c85..028d8b54ac3 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -35,6 +35,7 @@ with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; +with Gnatvsn; use Gnatvsn; with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; @@ -1068,7 +1069,13 @@ package body Sem_Attr is -- the designated type of the access type, since the type of -- the referenced array is this type (see AI95-00106). - Freeze_Before (N, Designated_Type (P_Type)); + -- As done elsewhere, freezing must not happen when pre-analyzing + -- a pre- or postcondition or a default value for an object or + -- for a formal parameter. + + if not In_Spec_Expression then + Freeze_Before (N, Designated_Type (P_Type)); + end if; Rewrite (P, Make_Explicit_Dereference (Sloc (P), @@ -2538,6 +2545,16 @@ package body Sem_Attr is Set_Etype (N, RTE (RE_Address)); + ---------------------- + -- Compiler_Version -- + ---------------------- + + when Attribute_Compiler_Version => + Check_E0; + Check_Standard_Prefix; + Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String)); + Analyze_And_Resolve (N, Standard_String); + -------------------- -- Component_Size -- -------------------- @@ -7476,6 +7493,7 @@ package body Sem_Attr is Attribute_Caller | Attribute_Class | Attribute_Code_Address | + Attribute_Compiler_Version | Attribute_Count | Attribute_Default_Bit_Order | Attribute_Elaborated | diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 9a4f1e34b41..b84cf1ea8d1 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4361,18 +4361,15 @@ package body Sem_Ch12 is begin -- A new compilation unit node is built for the instance declaration. - -- Place the context of the compilation this declaration, so that it - -- it is processed before the instance in CodePeer. Decl_Cunit := Make_Compilation_Unit (Sloc (N), - Context_Items => Context_Items (Parent (N)), + Context_Items => Empty_List, Unit => Act_Decl, Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); Set_Parent_Spec (Act_Decl, Parent_Spec (N)); - Set_Context_Items (Parent (N), Empty_List); -- The new compilation unit is linked to its body, but both share the -- same file, so we do not set Body_Required on the new unit so as not @@ -8790,12 +8787,12 @@ package body Sem_Ch12 is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Inst_Node : constant Node_Id := Body_Info.Inst_Node; Loc : constant Source_Ptr := Sloc (Inst_Node); - Gen_Id : constant Node_Id := Name (Inst_Node); - Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); - Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); - Anon_Id : constant Entity_Id := + Gen_Id : constant Node_Id := Name (Inst_Node); + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); + Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); + Anon_Id : constant Entity_Id := Defining_Unit_Name (Specification (Act_Decl)); - Pack_Id : constant Entity_Id := + Pack_Id : constant Entity_Id := Defining_Unit_Name (Parent (Act_Decl)); Decls : List_Id; Gen_Body : Node_Id; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 61ca642e27b..89cfbb66cb6 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -691,10 +691,16 @@ package body Sem_Ch13 is -- Start of processing for Analyze_Attribute_Definition_Clause begin + -- Process Ignore_Rep_Clauses option + if Ignore_Rep_Clauses then case Id is - -- The following should be ignored + -- The following should be ignored. They do not affect legality + -- and may be target dependent. The basic idea of -gnatI is to + -- ignore any rep clauses that may be target dependent but do not + -- affect legality (except possibly to be rejected because they + -- are incompatible with the compilation target). when Attribute_Address | Attribute_Alignment | @@ -710,7 +716,11 @@ package body Sem_Ch13 is Rewrite (N, Make_Null_Statement (Sloc (N))); return; - -- The following should not be ignored + -- The following should not be ignored, because in the first place + -- they are reasonably portable, and should not cause problems in + -- compiling code from another target, and also they do affect + -- legality, e.g. failing to provide a stream attribute for a + -- type may make a program illegal. when Attribute_External_Tag | Attribute_Input | @@ -2976,11 +2986,10 @@ package body Sem_Ch13 is Error_Msg_NE ("invalid address clause for initialized object &!", Nod, U_Ent); - Error_Msg_Name_1 := Chars (Entity (Nod)); - Error_Msg_Name_2 := Chars (U_Ent); - Error_Msg_N - ("\% must be defined before % (RM 13.1(22))!", - Nod); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Entity (Nod)); end if; elsif Nkind (Nod) = N_Selected_Component then @@ -3110,11 +3119,10 @@ package body Sem_Ch13 is Error_Msg_NE ("invalid address clause for initialized object &!", Nod, U_Ent); - Error_Msg_Name_1 := Chars (Ent); - Error_Msg_Name_2 := Chars (U_Ent); - Error_Msg_N - ("\% must be defined before % (RM 13.1(22))!", - Nod); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Ent); end if; elsif Nkind (Original_Node (Nod)) = N_Function_Call then @@ -3126,10 +3134,9 @@ package body Sem_Ch13 is Nod, U_Ent); if Comes_From_Source (Ent) then - Error_Msg_Name_1 := Chars (Ent); - Error_Msg_N - ("\reference to variable% not allowed" - & " (RM 13.1(22))!", Nod); + Error_Msg_NE + ("\reference to variable& not allowed" + & " (RM 13.1(22))!", Nod, Ent); else Error_Msg_N ("non-static expression not allowed" diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9bd9a001260..cb66334fc45 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1276,10 +1276,6 @@ package body Sem_Ch3 is procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is S : constant Node_Id := Subtype_Indication (Def); P : constant Node_Id := Parent (Def); - - Desig : Entity_Id; - -- Designated type - begin -- Check for permissible use of incomplete type @@ -1331,22 +1327,6 @@ package body Sem_Ch3 is Init_Size_Align (T); end if; - Desig := Designated_Type (T); - - -- If designated type is an imported tagged type, indicate that the - -- access type is also imported, and therefore restricted in its use. - -- The access type may already be imported, so keep setting otherwise. - - -- Ada 2005 (AI-50217): If the non-limited view of the designated type - -- is available, use it as the designated type of the access type, so - -- that the back-end gets a usable entity. - - if From_With_Type (Desig) - and then Ekind (Desig) /= E_Access_Type - then - Set_From_With_Type (T); - end if; - -- Note that Has_Task is always false, since the access type itself -- is not a task type. See Einfo for more description on this point. -- Exactly the same consideration applies to Has_Controlled_Component. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5ea961b1ae1..b8e8b42d211 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -446,7 +446,7 @@ package body Sem_Ch4 is if Nkind (Constraint (E)) = N_Index_Or_Discriminant_Constraint then - Error_Msg_N + Error_Msg_N -- CODEFIX ("\if qualified expression was meant, " & "use apostrophe", Constraint (E)); end if; @@ -483,7 +483,7 @@ package body Sem_Ch4 is and then Nkind (Constraint (E)) = N_Index_Or_Discriminant_Constraint then - Error_Msg_N + Error_Msg_N -- CODEFIX ("if qualified expression was meant, " & "use apostrophe!", Constraint (E)); end if; @@ -2466,7 +2466,7 @@ package body Sem_Ch4 is Formal := First_Formal (Nam); while Present (Formal) loop if Chars (Left_Opnd (Actual)) = Chars (Formal) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("possible misspelling of `='>`!", Actual); exit; end if; @@ -4245,12 +4245,12 @@ package body Sem_Ch4 is -- Report at most two suggestions if Nr_Of_Suggestions = 1 then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("\possible misspelling of&", Sel, Suggestion_1); elsif Nr_Of_Suggestions = 2 then Error_Msg_Node_2 := Suggestion_2; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("\possible misspelling of& or&", Sel, Suggestion_1); end if; end Check_Misspelled_Selector; @@ -4359,8 +4359,8 @@ package body Sem_Ch4 is if Nkind (Parent (N)) = N_Selected_Component and then N = Prefix (Parent (N)) then - Error_Msg_N ( - "\period should probably be semicolon", Parent (N)); + Error_Msg_N -- CODEFIX + ("\period should probably be semicolon", Parent (N)); end if; elsif Nkind (N) = N_Procedure_Call_Statement @@ -5238,7 +5238,8 @@ package body Sem_Ch4 is and then Valid_Boolean_Arg (Etype (R)) then Error_Msg_N ("invalid operands for concatenation", N); - Error_Msg_N ("\maybe AND was meant", N); + Error_Msg_N -- CODEFIX + ("\maybe AND was meant", N); return; -- A special case for comparison of access parameter with null @@ -6073,7 +6074,8 @@ package body Sem_Ch4 is if Nkind (Parent (Op)) = N_Full_Type_Declaration then Error_Msg_N ("\possible interpretation (inherited)#", N); else - Error_Msg_N ("\possible interpretation#", N); + Error_Msg_N -- CODEFIX + ("\possible interpretation#", N); end if; end if; end Report_Ambiguity; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 37975bc73a7..4c047b49c53 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1208,6 +1208,13 @@ package body Sem_Ch5 is Analyze_And_Resolve (Cond, Any_Boolean); Check_Unset_Reference (Cond); end if; + + -- Since the exit may take us out of a loop, any previous assignment + -- statement is not useless, so clear last assignment indications. It + -- is OK to keep other current values, since if the exit statement + -- does not exit, then the current values are still valid. + + Kill_Current_Values (Last_Assignment_Only => True); end Analyze_Exit_Statement; ---------------------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1e7bf886d6a..b51128705ae 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3480,36 +3480,36 @@ package body Sem_Ch6 is case Ctype is when Type_Conformant => - Error_Msg_N + Error_Msg_N -- CODEFIX ("not type conformant with declaration#!", Enode); when Mode_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N + Error_Msg_N -- CODEFIX??? ("not mode conformant with operation inherited#!", Enode); else - Error_Msg_N + Error_Msg_N -- CODEFIX??? ("not mode conformant with declaration#!", Enode); end if; when Subtype_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N + Error_Msg_N -- CODEFIX??? ("not subtype conformant with operation inherited#!", Enode); else - Error_Msg_N + Error_Msg_N -- CODEFIX??? ("not subtype conformant with declaration#!", Enode); end if; when Fully_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N + Error_Msg_N -- CODEFIX ("not fully conformant with operation inherited#!", Enode); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("not fully conformant with declaration#!", Enode); end if; end case; @@ -4157,7 +4157,8 @@ package body Sem_Ch6 is procedure Conformance_Error (Msg : String; N : Node_Id) is begin Error_Msg_Sloc := Sloc (Prev_Loc); - Error_Msg_N ("not fully conformant with declaration#!", N); + Error_Msg_N -- CODEFIX + ("not fully conformant with declaration#!", N); Error_Msg_NE (Msg, N, N); end Conformance_Error; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 7b41282288a..8ddefb58af0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -866,37 +866,65 @@ package body Sem_Ch8 is end if; end if; - -- Special processing for renaming function return object + -- Special processing for renaming function return object. Some errors + -- and warnings are produced only for calls that come from source. - if Nkind (Nam) = N_Function_Call - and then Comes_From_Source (Nam) - then + if Nkind (Nam) = N_Function_Call then case Ada_Version is -- Usage is illegal in Ada 83 when Ada_83 => - Error_Msg_N - ("(Ada 83) cannot rename function return object", Nam); + if Comes_From_Source (Nam) then + Error_Msg_N + ("(Ada 83) cannot rename function return object", Nam); + end if; -- In Ada 95, warn for odd case of renaming parameterless function - -- call if this is not a limited type (where this is useful) + -- call if this is not a limited type (where this is useful). when others => if Warn_On_Object_Renames_Function and then No (Parameter_Associations (Nam)) and then not Is_Limited_Type (Etype (Nam)) + and then Comes_From_Source (Nam) then Error_Msg_N - ("?renaming function result object is suspicious", - Nam); + ("?renaming function result object is suspicious", Nam); Error_Msg_NE - ("\?function & will be called only once", - Nam, Entity (Name (Nam))); + ("\?function & will be called only once", Nam, + Entity (Name (Nam))); Error_Msg_N ("\?suggest using an initialized constant object instead", Nam); end if; + + -- If the function call returns an unconstrained type, we must + -- build a constrained subtype for the new entity, in a way + -- similar to what is done for an object declaration with an + -- unconstrained nominal type. + + if Is_Composite_Type (Etype (Nam)) + and then not Is_Constrained (Etype (Nam)) + and then not Has_Unknown_Discriminants (Etype (Nam)) + and then Expander_Active + then + declare + Loc : constant Source_Ptr := Sloc (N); + Subt : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + begin + Remove_Side_Effects (Nam); + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_From_Expr (Nam, Etype (Nam)))); + Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); + Set_Etype (Nam, Subt); + end; + end if; end case; end if; @@ -918,6 +946,7 @@ package body Sem_Ch8 is then Error_Msg_NE ("invalid use of incomplete type&", Id, T2); return; + elsif Ekind (Etype (T)) = E_Incomplete_Type then Error_Msg_NE ("invalid use of incomplete type&", Id, T); return; @@ -935,8 +964,8 @@ package body Sem_Ch8 is and then Nkind (Nam) in N_Has_Entity then declare - Nam_Decl : Node_Id; - Nam_Ent : Entity_Id; + Nam_Decl : Node_Id; + Nam_Ent : Entity_Id; begin if Nkind (Nam) = N_Attribute_Reference then @@ -945,7 +974,7 @@ package body Sem_Ch8 is Nam_Ent := Entity (Nam); end if; - Nam_Decl := Parent (Nam_Ent); + Nam_Decl := Parent (Nam_Ent); if Has_Null_Exclusion (N) and then not Has_Null_Exclusion (Nam_Decl) @@ -958,7 +987,7 @@ package body Sem_Ch8 is -- have a null exclusion or a null-excluding subtype. if Is_Formal_Object (Nam_Ent) - and then In_Generic_Scope (Id) + and then In_Generic_Scope (Id) then if not Can_Never_Be_Null (Etype (Nam_Ent)) then Error_Msg_N @@ -985,11 +1014,11 @@ package body Sem_Ch8 is -- of the renamed actual in the instance will raise -- constraint_error. - elsif Nkind (Parent (Nam_Ent)) = N_Object_Declaration + elsif Nkind (Nam_Decl) = N_Object_Declaration and then In_Instance and then Present - (Corresponding_Generic_Association (Parent (Nam_Ent))) - and then Nkind (Expression (Parent (Nam_Ent))) + (Corresponding_Generic_Association (Nam_Decl)) + and then Nkind (Expression (Nam_Decl)) = N_Raise_Constraint_Error then Error_Msg_N @@ -1000,7 +1029,7 @@ package body Sem_Ch8 is -- must not be null-excluding. elsif No (Access_Definition (N)) - and then Can_Never_Be_Null (T) + and then Can_Never_Be_Null (T) then Error_Msg_NE ("`NOT NULL` not allowed (& already excludes null)", @@ -1040,8 +1069,6 @@ package body Sem_Ch8 is then Error_Msg_N ("illegal renaming of discriminant-dependent component", Nam); - else - null; end if; -- A static function call may have been folded into a literal @@ -1116,8 +1143,7 @@ package body Sem_Ch8 is return; end if; - -- Apply Text_IO kludge here, since we may be renaming one of the - -- children of Text_IO. + -- Apply Text_IO kludge here since we may be renaming a child of Text_IO Text_IO_Kludge (Name (N)); @@ -1135,8 +1161,7 @@ package body Sem_Ch8 is end if; if Etype (Old_P) = Any_Type then - Error_Msg_N - ("expect package name in renaming", Name (N)); + Error_Msg_N ("expect package name in renaming", Name (N)); elsif Ekind (Old_P) /= E_Package and then not (Ekind (Old_P) = E_Generic_Package @@ -1373,8 +1398,8 @@ package body Sem_Ch8 is Inherit_Renamed_Profile (New_S, Old_S); - -- The prefix can be an arbitrary expression that yields a task - -- type, so it must be resolved. + -- The prefix can be an arbitrary expression that yields a task type, + -- so it must be resolved. Resolve (Prefix (Nam), Scope (Old_S)); end if; @@ -2556,11 +2581,12 @@ package body Sem_Ch8 is and then Etype (Pack) /= Any_Type then if Ekind (Pack) = E_Generic_Package then - Error_Msg_N + Error_Msg_N -- CODEFIX ("a generic package is not allowed in a use clause", Pack_Name); else - Error_Msg_N ("& is not a usable package", Pack_Name); + Error_Msg_N -- CODEFIX??? + ("& is not a usable package", Pack_Name); end if; else @@ -3716,12 +3742,14 @@ package body Sem_Ch8 is while Present (Ent) loop if Is_Potentially_Use_Visible (Ent) then if not Hidden then - Error_Msg_N ("multiple use clauses cause hiding!", N); + Error_Msg_N -- CODEFIX + ("multiple use clauses cause hiding!", N); Hidden := True; end if; Error_Msg_Sloc := Sloc (Ent); - Error_Msg_N ("hidden declaration#!", N); + Error_Msg_N -- CODEFIX + ("hidden declaration#!", N); end if; Ent := Homonym (Ent); @@ -3754,7 +3782,8 @@ package body Sem_Ch8 is if Is_Hidden (Ent) then Error_Msg_N ("non-visible (private) declaration#!", N); else - Error_Msg_N ("non-visible declaration#!", N); + Error_Msg_N -- CODEFIX + ("non-visible declaration#!", N); if Is_Compilation_Unit (Ent) and then @@ -3936,7 +3965,8 @@ package body Sem_Ch8 is end loop; if Present (Ematch) then - Error_Msg_NE ("\possible misspelling of&", N, Ematch); + Error_Msg_NE -- CODEFIX + ("\possible misspelling of&", N, Ematch); end if; end; end if; @@ -4722,7 +4752,7 @@ package body Sem_Ch8 is if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector)) and then not Is_Internal_Name (Chars (Id)) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("possible misspelling of&", Selector, Id); exit; end if; @@ -5697,14 +5727,25 @@ package body Sem_Ch8 is if Ekind (Base_Type (T_Name)) = E_Task_Type then -- In Ada 2005, a task name can be used in an access - -- definition within its own body. + -- definition within its own body. It cannot be used + -- in the discriminant part of the task declaration, + -- nor anywhere else in the declaration because entries + -- cannot have access parameters. if Ada_Version >= Ada_05 and then Nkind (Parent (N)) = N_Access_Definition then Set_Entity (N, T_Name); Set_Etype (N, T_Name); - return; + + if Has_Completion (T_Name) then + return; + + else + Error_Msg_N + ("task type cannot be used as type mark " & + "within its own declaration", N); + end if; else Error_Msg_N diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index c44c8e8d0fc..7c69da1ade1 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -50,7 +50,6 @@ with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -1742,7 +1741,7 @@ package body Sem_Disp is -- the VM back-ends directly handle the generation of dispatching -- calls and would have to undo any expansion to an indirect call. - if VM_Target = No_VM then + if Tagged_Type_Expansion then Expand_Dispatching_Call (Call_Node); -- Expansion of a dispatching call results in an indirect call, which in diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 926f750405d..505fbea96fe 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1967,7 +1967,8 @@ package body Sem_Prag is (Chars (Arg), Names (Index1)) then Error_Msg_Name_1 := Names (Index1); - Error_Msg_N ("\possible misspelling of%", Arg); + Error_Msg_N -- CODEFIX + ("\possible misspelling of%", Arg); exit; end if; end loop; @@ -3105,7 +3106,7 @@ package body Sem_Prag is Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then - Error_Pragma + Error_Pragma -- CODEFIX??? ("pragma Import or Interface must precede pragma%"); end if; @@ -3573,6 +3574,49 @@ package body Sem_Prag is Set_Is_CPP_Class (Def_Id); Set_Is_Limited_Record (Def_Id); + + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). + + if Has_Discriminants (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Def_Id)))); + end if; + + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is in the + -- C++ side. + + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Def_Id)); + Clist : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; + + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + end; end if; else @@ -4183,7 +4227,7 @@ package body Sem_Prag is Error_Msg_String (1 .. Rnm'Length) := Name_Buffer (1 .. Name_Len); Error_Msg_Strlen := Rnm'Length; - Error_Msg_N + Error_Msg_N -- CODEFIX ("\possible misspelling of ""~""", Get_Pragma_Arg (Arg)); exit; @@ -4937,7 +4981,7 @@ package body Sem_Prag is for PN in First_Pragma_Name .. Last_Pragma_Name loop if Is_Bad_Spelling_Of (Pname, PN) then Error_Msg_Name_1 := PN; - Error_Msg_N + Error_Msg_N -- CODEFIX ("\?possible misspelling of %!", Pragma_Identifier (N)); exit; end if; @@ -6159,6 +6203,62 @@ package body Sem_Prag is Set_Is_CPP_Class (Typ); Set_Is_Limited_Record (Typ); Set_Convention (Typ, Convention_CPP); + + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). + + if Has_Discriminants (Typ) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Typ)))); + end if; + + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is in the + -- C++ side. + + if Is_Incomplete_Or_Private_Type (Typ) + and then No (Underlying_Type (Typ)) + then + -- It should be an error to apply pragma CPP to a private + -- type if the underlying type is not visible (as it is + -- for any representation item). For now, for backward + -- compatibility we do nothing but we cannot check components + -- because they are not available at this stage. All this code + -- will be removed when we cleanup this obsolete GNAT pragma??? + + null; + + else + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Clist : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; + + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + end; + end if; end CPP_Class; --------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c6f79de4915..d6113d88a7e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -72,7 +72,6 @@ with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Style; use Style; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -1996,7 +1995,7 @@ package body Sem_Res is ("ambiguous expression " & "(cannot resolve indirect call)!", N); else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("ambiguous expression (cannot resolve&)!", N, It.Nam); end if; @@ -2007,7 +2006,8 @@ package body Sem_Res is Error_Msg_N ("\\possible interpretation (inherited)#!", N); else - Error_Msg_N ("\\possible interpretation#!", N); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", N); end if; end if; @@ -2089,7 +2089,8 @@ package body Sem_Res is Error_Msg_N ("\\possible interpretation (inherited)#!", N); else - Error_Msg_N ("\\possible interpretation#!", N); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", N); end if; end if; @@ -6936,7 +6937,8 @@ package body Sem_Res is or else Base_Type (It.Typ) = Base_Type (Component_Type (Typ)) then - Error_Msg_N ("\\possible interpretation#", Arg); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#", Arg); end if; Get_Next_Interp (I, It); @@ -7841,13 +7843,13 @@ package body Sem_Res is -- undesired dependence on such run-time unit. and then - (VM_Target /= No_VM - or else not - (RTU_Loaded (Ada_Tags) - and then Nkind (Prefix (N)) = N_Selected_Component - and then Present (Entity (Selector_Name (Prefix (N)))) - and then Entity (Selector_Name (Prefix (N))) = - RTE_Record_Component (RE_Prims_Ptr))) + (not Tagged_Type_Expansion + or else not + (RTU_Loaded (Ada_Tags) + and then Nkind (Prefix (N)) = N_Selected_Component + and then Present (Entity (Selector_Name (Prefix (N)))) + and then Entity (Selector_Name (Prefix (N))) = + RTE_Record_Component (RE_Prims_Ptr))) then Apply_Range_Check (Drange, Etype (Index)); end if; @@ -8285,7 +8287,7 @@ package body Sem_Res is and then Covers (Orig_T, Etype (Entity (Orig_N))))) then Error_Msg_Node_2 := Orig_T; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?redundant conversion, & is of type &!", N, Entity (Orig_N)); end if; end if; @@ -9314,10 +9316,12 @@ package body Sem_Res is Error_Msg_N ("ambiguous operand in conversion", Operand); Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("\\possible interpretation#!", Operand); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", Operand); Error_Msg_Sloc := Sloc (N1); - Error_Msg_N ("\\possible interpretation#!", Operand); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", Operand); return False; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d7e85261dfe..31f3ccd1a4d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5920,7 +5920,7 @@ package body Sem_Util is -- uninitialized case. Note that this applies both to the -- uTag entry and the main vtable pointer (CPP_Class case). - and then (VM_Target = No_VM or else not Is_Tag (Ent)) + and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) then return False; end if; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index ec1d1d767e0..8132531cc0c 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -954,8 +954,8 @@ package body Sem_Warn is -- here (note that the dereference may not be explicit in -- the source, for example in the case of a dispatching call -- with an anonymous access controlling formal, or of an - -- assignment of a pointer involving discriminant check - -- on the designated object). + -- assignment of a pointer involving discriminant check on + -- the designated object). if not Warnings_Off_E1 then Error_Msg_NE ("?& may be null!", UR, E1); @@ -1005,7 +1005,7 @@ package body Sem_Warn is and then not Has_Pragma_Unmodified_Check_Spec (E1) then if not Warnings_Off_E1 then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?& is not modified, " & "could be declared constant!", E1); @@ -1155,7 +1155,7 @@ package body Sem_Warn is elsif not Has_Unreferenced (E1) and then not Warnings_Off_E1 then - Output_Reference_Error + Output_Reference_Error -- CODEFIX ("?variable& is never read and never assigned!"); end if; @@ -2342,7 +2342,7 @@ package body Sem_Warn is end if; if not Is_Visible_Renaming then - Error_Msg_N + Error_Msg_N -- CODEFIX ("\?with clause might be moved to body!", Name (Item)); end if; @@ -2370,7 +2370,7 @@ package body Sem_Warn is if Unit = Spec_Unit then Set_Unreferenced_In_Spec (Item); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("?unit& is never instantiated!", Name (Item)); end if; @@ -2381,7 +2381,7 @@ package body Sem_Warn is elsif Unreferenced_In_Spec (Item) then Error_Msg_N ("?unit& is not instantiated in spec!", Name (Item)); - Error_Msg_N + Error_Msg_N -- CODEFIX ("\?with clause can be moved to body!", Name (Item)); end if; end if; @@ -3782,7 +3782,7 @@ package body Sem_Warn is and then No (Renamed_Object (E)) then if not Has_Pragma_Unmodified_Check_Spec (E) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?variable & is assigned but never read!", E); end if; @@ -3871,11 +3871,11 @@ package body Sem_Warn is Error_Msg_N ("?procedure & is not referenced!", E); when E_Generic_Procedure => - Error_Msg_N + Error_Msg_N -- CODEFIX ("?generic procedure & is never instantiated!", E); when E_Generic_Function => - Error_Msg_N + Error_Msg_N -- CODEFIX ("?generic function & is never instantiated!", E); when Type_Kind => @@ -3903,8 +3903,8 @@ package body Sem_Warn is X : Node_Id; function Check_Ref (N : Node_Id) return Traverse_Result; - -- Used to instantiate Traverse_Func. Returns Abandon if - -- a reference to the entity in question is found. + -- Used to instantiate Traverse_Func. Returns Abandon if a reference to + -- the entity in question is found. function Test_No_Refs is new Traverse_Func (Check_Ref); @@ -3935,7 +3935,7 @@ package body Sem_Warn is -- variable with the last assignment field set, with warnings enabled, -- and which is not imported or exported. We also check that it is OK -- to capture the value. We are not going to capture any value, but - -- the warning messages depends on the same kind of conditions. + -- the warning message depends on the same kind of conditions. if Is_Assignable (Ent) and then not Is_Return_Object (Ent) @@ -4027,18 +4027,27 @@ package body Sem_Warn is -- Otherwise we are at the outer level. An exception -- handler is significant only if it references the - -- variable in question. + -- variable in question, or if the entity in question + -- is an OUT or IN OUT parameter, which which case + -- the caller can reference it after the exception + -- hanlder completes else - X := First (Exception_Handlers (P)); - while Present (X) loop - if Test_No_Refs (X) = Abandon then - Set_Last_Assignment (Ent, Empty); - return; - end if; + if Is_Formal (Ent) then + Set_Last_Assignment (Ent, Empty); + return; - X := Next (X); - end loop; + else + X := First (Exception_Handlers (P)); + while Present (X) loop + if Test_No_Refs (X) = Abandon then + Set_Last_Assignment (Ent, Empty); + return; + end if; + + X := Next (X); + end loop; + end if; end if; end if; end if; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index 32f8bdedd6b..fe38b751dd2 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -453,7 +453,8 @@ package body Sinput.L is -- Preprocess the source if it needs to be preprocessed if Preprocessing_Needed then - -- Set temporarily the Source_File_Index_Table entries for the + + -- Temporarily set the Source_File_Index_Table entries for the -- source, to avoid crash when reporting an error. Set_Source_File_Index_Table (X); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index d780804b70f..020e69df26d 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -32,10 +32,12 @@ pragma Style_Checks (All_Checks); -- Subprograms not all in alpha order +with Atree; use Atree; with Debug; use Debug; with Opt; use Opt; with Output; use Output; with Tree_IO; use Tree_IO; +with Sinfo; use Sinfo; with System; use System; with Widechar; use Widechar; @@ -238,6 +240,246 @@ package body Sinput is return; end Build_Location_String; + --------------------- + -- Expr_First_Char -- + --------------------- + + function Expr_First_Char (Expr : Node_Id) return Source_Ptr is + + function First_Char (Expr : Node_Id; PC : Nat) return Source_Ptr; + -- Internal recursive function used to traverse the expression tree. + -- Returns the source pointer corresponding to the first location of + -- the subexpression N, followed by backing up the given (PC) number of + -- preceding left parentheses. + + ---------------- + -- First_Char -- + ---------------- + + function First_Char (Expr : Node_Id; PC : Nat) return Source_Ptr is + N : constant Node_Id := Original_Node (Expr); + Count : constant Nat := PC + Paren_Count (N); + Kind : constant N_Subexpr := Nkind (N); + Loc : Source_Ptr; + + begin + case Kind is + when N_And_Then | + N_In | + N_Not_In | + N_Or_Else | + N_Binary_Op => + return First_Char (Left_Opnd (N), Count); + + when N_Attribute_Reference | + N_Expanded_Name | + N_Explicit_Dereference | + N_Indexed_Component | + N_Reference | + N_Selected_Component | + N_Slice => + return First_Char (Prefix (N), Count); + + when N_Function_Call => + return First_Char (Sinfo.Name (N), Count); + + when N_Qualified_Expression | + N_Type_Conversion => + return First_Char (Subtype_Mark (N), Count); + + when N_Range => + return First_Char (Low_Bound (N), Count); + + -- Nodes that should not appear in original expression trees + + when N_Procedure_Call_Statement | + N_Raise_xxx_Error | + N_Subprogram_Info | + N_Unchecked_Expression | + N_Unchecked_Type_Conversion | + N_Conditional_Expression => + raise Program_Error; + + -- Cases where the Sloc points to the start of the tokem, but we + -- still need to handle the sequence of left parentheses. + + when N_Identifier | + N_Operator_Symbol | + N_Character_Literal | + N_Integer_Literal | + N_Null | + N_Unary_Op | + N_Aggregate | + N_Allocator | + N_Extension_Aggregate | + N_Real_Literal | + N_String_Literal => + + Loc := Sloc (N); + + -- Skip past parens + + -- This is not right, it does not deal with skipping comments + -- and probably also has wide character problems ??? + + if Count > 0 then + declare + SFI : constant Source_File_Index := + Get_Source_File_Index (Loc); + Src : constant Source_Buffer_Ptr := Source_Text (SFI); + Fst : constant Source_Ptr := Source_First (SFI); + + begin + for J in 1 .. Count loop + loop + exit when Loc = Fst; + Loc := Loc - 1; + exit when Src (Loc) >= ' '; + end loop; + + exit when Src (Loc) /= '('; + end loop; + end; + end if; + + return Loc; + end case; + end First_Char; + + -- Start of processing for Expr_First_Char + + begin + pragma Assert (Nkind (Expr) in N_Subexpr); + return First_Char (Expr, 0); + end Expr_First_Char; + + -------------------- + -- Expr_Last_Char -- + -------------------- + + function Expr_Last_Char (Expr : Node_Id) return Source_Ptr is + + function Last_Char (Expr : Node_Id; PC : Nat) return Source_Ptr; + -- Internal recursive function used to traverse the expression tree. + -- Returns the source pointer corresponding to the last location of + -- the subexpression N, followed by ztepping to the last of the given + -- number of right parentheses. + + --------------- + -- Last_Char -- + --------------- + + function Last_Char (Expr : Node_Id; PC : Nat) return Source_Ptr is + N : constant Node_Id := Original_Node (Expr); + Count : constant Nat := PC + Paren_Count (N); + Kind : constant N_Subexpr := Nkind (N); + Loc : Source_Ptr; + + begin + case Kind is + when N_And_Then | + N_In | + N_Not_In | + N_Or_Else | + N_Binary_Op => + return Last_Char (Right_Opnd (N), Count); + + when N_Attribute_Reference | + N_Expanded_Name | + N_Explicit_Dereference | + N_Indexed_Component | + N_Reference | + N_Selected_Component | + N_Slice => + return Last_Char (Prefix (N), Count); + + when N_Function_Call => + return Last_Char (Sinfo.Name (N), Count); + + when N_Qualified_Expression | + N_Type_Conversion => + return Last_Char (Subtype_Mark (N), Count); + + when N_Range => + return Last_Char (Low_Bound (N), Count); + + -- Nodes that should not appear in original expression trees + + when N_Procedure_Call_Statement | + N_Raise_xxx_Error | + N_Subprogram_Info | + N_Unchecked_Expression | + N_Unchecked_Type_Conversion | + N_Conditional_Expression => + raise Program_Error; + + -- Cases where the Sloc points to the start of the token, but we + -- still need to handle the sequence of left parentheses. + + when N_Identifier | + N_Operator_Symbol | + N_Character_Literal | + N_Integer_Literal | + N_Null | + N_Unary_Op | + N_Aggregate | + N_Allocator | + N_Extension_Aggregate | + N_Real_Literal | + N_String_Literal => + + Loc := Sloc (N); + + -- Now we have two tasks, first we are pointing to the start + -- of the token below, second, we need to skip parentheses. + + -- Skipping to the end of a token is not easy, we can't just + -- skip to a space, since we may have e.g. X*YAR+Z, and if we + -- are finding the end of the subexpression X*YAR, we don't + -- want to skip past the +Z. Also we have to worry about + -- skipping comments, and about wide characters ??? + + declare + SFI : constant Source_File_Index := + Get_Source_File_Index (Loc); + Src : constant Source_Buffer_Ptr := Source_Text (SFI); + Lst : constant Source_Ptr := Source_Last (SFI); + + begin + -- Scan through first blank character, to get to the end + -- of this token. As noted above that's not really right??? + + loop + exit when Loc = Lst or else Src (Loc + 1) <= ' '; + Loc := Loc + 1; + end loop; + + -- Skip past parens, but this also ignores comments ??? + + if Count > 0 then + for J in 1 .. Count loop + loop + exit when Loc = Lst; + Loc := Loc + 1; + exit when Src (Loc) >= ' '; + end loop; + + exit when Src (Loc) /= ')'; + end loop; + end if; + end; + + return Loc; + end case; + end Last_Char; + + -- Start of processing for Expr_Last_Char + + begin + pragma Assert (Nkind (Expr) in N_Subexpr); + return Last_Char (Expr, 0); + end Expr_Last_Char; + ----------------------- -- Get_Column_Number -- ----------------------- diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index ca97716145e..c679e24d84b 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -471,6 +471,14 @@ package Sinput is -- ASCII.NUL, with Name_Length indicating the length not including the -- terminating Nul. + function Expr_First_Char (Expr : Node_Id) return Source_Ptr; + -- Given a node for a subexpression, returns the source location of the + -- first character of the expression. + + function Expr_Last_Char (Expr : Node_Id) return Source_Ptr; + -- Given a node for a subexpression, returns the source location of the + -- last character of the expression. + function Get_Column_Number (P : Source_Ptr) return Column_Number; -- The ones-origin column number of the specified Source_Ptr value is -- determined and returned. Tab characters if present are assumed to diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 60a91a39b43..263269ca0a5 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -688,6 +688,7 @@ package Snames is Name_Callable : constant Name_Id := N + $; Name_Caller : constant Name_Id := N + $; Name_Code_Address : constant Name_Id := N + $; -- GNAT + Name_Compiler_Version : constant Name_Id := N + $; -- GNAT Name_Component_Size : constant Name_Id := N + $; Name_Compose : constant Name_Id := N + $; Name_Constrained : constant Name_Id := N + $; @@ -1188,6 +1189,7 @@ package Snames is Attribute_Callable, Attribute_Caller, Attribute_Code_Address, + Attribute_Compiler_Version, Attribute_Component_Size, Attribute_Compose, Attribute_Constrained, diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index d3ce9e101d3..c92231d60b3 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -145,7 +145,8 @@ package body Styleg is begin if Style_Check_Attribute_Casing then if Determine_Token_Casing /= Mixed_Case then - Error_Msg_SC ("(style) bad capitalization, mixed case required"); + Error_Msg_SC -- CODEFIX + ("(style) bad capitalization, mixed case required"); end if; end if; end Check_Attribute_Name; @@ -379,7 +380,8 @@ package body Styleg is if Style_Check_Indentation /= 0 then if Start_Column rem Style_Check_Indentation /= 0 then if not Same_Column_As_Next_Non_Blank_Line then - Error_Msg_S ("(style) bad column"); + Error_Msg_S -- CODEFIX + ("(style) bad column"); end if; return; @@ -656,7 +658,7 @@ package body Styleg is else if Style_Check_Blank_Lines and then Blank_Lines > 1 then - Error_Msg + Error_Msg -- CODEFIX ("(style) multiple blank lines", Blank_Line_Location); end if; @@ -720,7 +722,8 @@ package body Styleg is begin if Style_Check_Pragma_Casing then if Determine_Token_Casing /= Mixed_Case then - Error_Msg_SC ("(style) bad capitalization, mixed case required"); + Error_Msg_SC -- CODEFIX + ("(style) bad capitalization, mixed case required"); end if; end if; end Check_Pragma_Name; @@ -978,7 +981,8 @@ package body Styleg is procedure Non_Lower_Case_Keyword is begin if Style_Check_Keyword_Casing then - Error_Msg_SC ("(style) reserved words must be all lower case"); + Error_Msg_SC -- CODEIX + ("(style) reserved words must be all lower case"); end if; end Non_Lower_Case_Keyword; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 7be075d9896..d7ed40da0d2 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Debug; use Debug; +with Makeutl; use Makeutl; with Osint; use Osint; with Opt; use Opt; with Prj; use Prj; diff --git a/gcc/ada/system-linux-mips64el.ads b/gcc/ada/system-linux-mips64el.ads new file mode 100644 index 00000000000..0c848717365 --- /dev/null +++ b/gcc/ada/system-linux-mips64el.ads @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/MIPS64EL Version) -- +-- -- +-- Copyright (C) 1992-2009, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- 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 := Integer'Last; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + 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. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Compiler_System_Version : constant Boolean := False; + 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; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : 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; + 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; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + +end System; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 0953fe07062..3bf4eb69c87 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -83,6 +83,17 @@ package body Table is Set_Item (Table_Index_Type (Last_Val + 1), New_Val); end Append; + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (New_Vals (J)); + end loop; + end Append_All; + -------------------- -- Decrement_Last -- -------------------- diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 79bf6705e33..2b398d762cd 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -187,6 +187,9 @@ package Table is -- i.e. the table size is increased by one, and the given new item -- stored in the newly created table element. + procedure Append_All (New_Vals : Table_Type); + -- Appends all components of New_Vals + procedure Set_Item (Index : Table_Index_Type; Item : Table_Component_Type); diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index da42ba8b7b5..d78201d3016 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -560,6 +560,7 @@ package body Targparm is when CLI => if Result then VM_Target := CLI_Target; + Tagged_Type_Expansion := False; end if; when CRT => Configurable_Run_Time_On_Target := Result; @@ -571,6 +572,7 @@ package body Targparm is when JVM => if Result then VM_Target := JVM_Target; + Tagged_Type_Expansion := False; end if; when MOV => Machine_Overflows_On_Target := Result; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 55f56652608..fd74ea5cbc9 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -220,7 +220,9 @@ package Targparm is type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target); VM_Target : Virtual_Machine_Kind := No_VM; -- Kind of virtual machine targetted - -- Needs comments, don't depend on names ??? + -- No_VM: no virtual machine, default case of a standard processor + -- JVM_Target: Java Virtual Machine + -- CLI_Target: CLI/.NET Virtual Machine ------------------------------- -- Backend Arithmetic Checks -- diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index d61a82e5a33..f4841df6df7 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -5116,7 +5116,11 @@ package VMS_Data is "AVERAGE_COMPLEXITY_ON " & "--complexity-average " & "AVERAGE_COMPLEXITY_OFF " & - "--no-complexity-average"; + "--no-complexity-average " & + "EXTRA_EXIT_POINTS_ON " & + "--extra-exit-points " & + "EXTRA_EXIT_POINTS_OFF " & + "--no-extra-exit-points"; -- /COMPLEXITY_METRICS=(option, option ...) -- Specifies the complexity metrics to be computed (if at least one @@ -5139,6 +5143,8 @@ package VMS_Data is -- executable bodies -- AVERAGE_COMPLEXITY_OFF Do not compute the average complexity for -- executable bodies + -- EXTRA_EXIT_POINTS_ON Compute extra exit points metric + -- EXTRA_EXIT_POINTS_OFF Do not compute extra exit points metric -- -- All combinations of line metrics options are allowed. diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 08aac903c33..83b726b6b9b 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -30,7 +30,7 @@ -- - the preprocessed C file: s-oscons-tmplt.i -- - the generated assembly file: s-oscons-tmplt.s --- The contents of s-oscons.ads is written on standard output. +-- The contents of s-oscons.ads is written on standard output with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; |