diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-09-01 06:35:08 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-09-01 06:35:08 +0000 |
| commit | a30fe044170c44da9e441535e2167ca8e885b3cb (patch) | |
| tree | 2ebaaed9567b6d2c562b45ef1d92bcb5cb136795 /gcc/ada | |
| parent | ddda25955ee583217ccbd7ad5c33c6bb9f304649 (diff) | |
| download | gcc-a30fe044170c44da9e441535e2167ca8e885b3cb.tar.gz | |
2008-09-01 Basile Starynkevitch <basile@starynkevitch.net>
MERGED WITH TRUNK rev139820
* gcc/melt/warmelt-first.bysl: added location argument to inform.
* gcc/warmelt-first-0.c: regenerated.
* gcc/warmelt-macro-0.c: regenerated.
* gcc/warmelt-normal-0.c: regenerated.
* gcc/warmelt-genobj-0.c: regenerated.
* gcc/warmelt-outobj-0.c: regenerated.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@139849 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
248 files changed, 3429 insertions, 2094 deletions
diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb index a867313fc94..8096ca213f8 100644 --- a/gcc/ada/9drpc.adb +++ b/gcc/ada/9drpc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bf3c7dd903d..745c8431e5d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,587 @@ +2008-08-30 Thomas Quinot <quinot@adacore.com> + + * gcc-interface/Make-lang.in: Allow s-oscons.{o,ali} to + be built even without a separate libada directory. + +2008-08-22 Arnaud Charlet <charlet@adacore.com> + + * lib-xref.ads: Fix typo in subprogram reference definition. + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * s-sopco3.adb, s-sopco4.adb, s-sopco5.adb, s-strops.adb: Minor code fix + to avoid warning. + + * g-trasym.adb: Ditto + + * s-utf_32.adb (Get_Category): Fix obvious typo + + * s-wwdcha.adb: Minor code reorganization + Remove dead code + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * checks.adb (Determine_Range): Deal with values that might be invalid + + * opt.adb, opt.ads (Assume_No_Invalid_Values[_Config]): New configuration + switches. + + * par-prag.adb: Dummy entry for pragma Assume_No_Invalid_Values + + * sem_prag.adb: Implement pragma Assume_No_Default_Values + + * snames.adb, snames.ads, snames.h: + Add entries for pragma Assume_No_Invalid_Values + + * switch-c.adb: Add processing for -gnatB switch + + * usage.adb: Add entry for flag -gnatB (no bad invalid values) + +2008-08-22 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Build_Init_Statements): Transfer to the body of the + init procedure all the expanded code associated with the spec of + task types and protected types. + +2008-08-22 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Static_Array_Aggregate): Call Analyze_And_Resolve on the + component expression copies rather than directly setting Etype and + Is_Static_Expression. + +2008-08-22 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Has_Preelaborable_Initialization): Revise checking of + private types to allow for types derived from a private type with + preelaborable initialization, but return False for a private extension + (unless it has the pragma). + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * opt.ads: Minor code reorganization (put entries in alpha order) + +2008-08-22 Pascal Obry <obry@adacore.com> + + * initialize.c, adaint.c: Use Lock_Task and Unlock_Task for non-blocking + spawn. + +2008-08-22 Geert Bosch <bosch@adacore.com> + + * gcc-interface/trans.c: Define FP_ARITH_MAY_WIDEN + (convert_with_check): Only use longest_float_type if FP_ARITH_MAY_WIDEN is 0 + +2008-08-22 Doug Rupp <rupp@adacore.com> + + * bindgen.adb [VMS] (Gen_Adainit_Ada, Gen_Adainit_C): Import and call + __gnat_set_features. + + * init.c + (__gnat_set_features): New function. + (__gnat_features_set): New tracking variable. + (__gl_no_malloc_64): New feature global variable + +2008-08-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Use_One_Type): Do not emit warning message about redundant + use_type_clause in an instance. + +2008-08-22 Bob Duff <duff@adacore.com> + + * exp_ch6.ads: Remove pragma Precondition, since it breaks some builds. + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb: Minor reformatting + + * exp_ch7.adb: Minor reformatting + + * exp_ch7.ads: Put routines in proper alpha order + + * exp_dist.adb: Minor reformatting + +2008-08-22 Vincent Celier <celier@adacore.com> + + * prj.ads: Minor comment update + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb (One_Bound): Fix latent bug involving secondary stack + +2008-08-22 Ed Schonberg <schonberg@adacore.com> + + * exp_tss.adb: + (Base_Init_Proc): For a protected subtype, use the base type of the + corresponding record to locate the propoer initialization procedure. + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * checks.adb: + (In_Subrange_Of): New calling sequence + (Determine_Range): Prepare for new processing using base type + + * exp_ch4.adb: + (Compile_Time_Compare): Use new calling sequence + + * exp_ch5.adb: + (Compile_Time_Compare): Use new calling sequence + + * sem_eval.adb: + (Compile_Time_Compare): New calling sequence allows dealing with + invalid values. + (In_Subrange_Of): Ditto + + * sem_eval.ads: + (Compile_Time_Compare): New calling sequence allows dealing with + invalid values. + (In_Subrange_Of): Ditto + +2008-08-22 Pascal Obry <obry@adacore.com> + + * adaint.c: Fix possible race condition on win32_wait(). + +2008-08-22 Bob Duff <duff@adacore.com> + + * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb, + exp_ch4.adb, exp_ch6.ads, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, + exp_intr.adb, exp_ch3.adb: Rename: + Exp_Ch7.Controlled_Type => Needs_Finalization + Exp_Ch7.CW_Or_Controlled_Type => CW_Or_Has_Controlled_Part + Exp_Ch5.Expand_N_Extended_Return_Statement.Controlled_Type => + Has_Controlled_Parts + (Has_Some_Controlled_Component): Fix bug in array case. + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * sem_ch8.adb: Minor reformatting + +2008-08-22 Kevin Pouget <pouget@adacore.com> + + * s-shasto.ads, s-shasto.adb: Move Shared_Var_ROpen, Shared_Var_WOpen and + Shared_Var_Close procedure specifications from package spec to package body. + + * rtsfind.ads: Remove RE_Shared_Var_Close, RE_Shared_Var_ROpen, + RE_Shared_Var_WOpen entries. + + * exp_dist.adb: Update RE_Any_Content_Ptr to RE_Any_Container_Ptr in + Build_To_Any_Call, Build_TypeCode_Call and Build_From_Any_Call procedures. + +2008-08-22 Eric Botcazou <ebotcazou@adacore.com> + + * init.c: adjust EH support code on Alpha/Tru64 as well. + + * raise-gcc.c: Add back a couple of comments. + +2008-08-22 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Simple_Function_Return): If secondary stack is + involved and the return type is class-wide, use the type of the expression + for the generated access type. Suppress useless discriminant checks on the + allocator. + +2008-08-22 Bob Duff <duff@adacore.com> + + * exp_ch7.adb: Minor comment fix + + * exp_ch6.ads: Minor comment fix + +2008-08-22 Thomas Quinot <quinot@adacore.com> + + * sem_ch8.adb: Minor reformatting + Minor code reorganization (introduce subprogram to factor duplicated + code). + +2008-08-22 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Change the description of gnatcheck default rule + settings. + +2008-08-22 Eric Botcazou <ebotcazou@adacore.com> + + * init.c (__gnat_adjust_context_for_raise): Delete for AIX, HP-UX, + Solaris, FreeBSD, VxWorks and PowerPC/Linux. For x86{-64}/Linux, + do not adjust the PC anymore. + (__gnat_error_handler): Do not call __gnat_adjust_context_for_raise + on AIX, HP-UX, Solaris, FreeBSD and VxWorks. + + * raise-gcc.c (get_call_site_action_for): Use _Unwind_GetIPInfo + instead of _Unwind_GetIP. + +2008-08-22 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Static_Array_Aggregate): When a static array aggregate + with a range is transformed into a positional aggregate, any copied + component literals should be marked Is_Static_Expression. + + * sem_eval.adb (Compile_Time_Known_Value): Don't treat null literals as + not being known at at compile time when Configurable_Run_Time_Mode is + true. + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb: + (Expand_N_Attribute_Reference): No validity checking on OUT parameter of + Read or Input attribute. + +2008-08-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Use_One_Type): when checking which of two use_type + clauses in related units is redundant, if one of the units is a package + instantiation, use its instance_spec to determine which unit is the + ancestor of the other. + +2008-08-22 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): In case of access + attributes add missing support to handle designated types that come + from the limited view. + + * exp_disp.adb (Expand_Interface_Conversion): Remove wrong assertion. + +2008-08-22 Sergey Rybin <rybin@adacore.com> + + * vms_data.ads: Add entry for new gnatcheck -mNNN option + + * gnat_ugn.texi: Add description for gnatcheck option '-m' + +2008-08-22 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Update the gnatcheck subsection for metric rules + acoording to the latest changes in the metric rule interface + +2008-08-22 Vincent Celier <celier@adacore.com> + + * make.adb (Check.File_Not_A_Source_Of): New Boolean function + (Check): Check if the file names registered in the ALI file for the + spec, the body and each of the subunits are the ones expected. + +2008-08-22 Robert Dewar <dewar@adacore.com> + + * g-catiio.adb: Code cleanup. + +2008-08-20 Vincent Celier <celier@adacore.com> + + * make.adb (Gnatmake): Remove extra space in version line + + * ali.adb: + (Scan_ALI): Use Name_Find, not Name_Enter to get the name of a subunit, + as the name may already have been entered in the table by the Project + Manager. + +2008-08-20 Jose Ruiz <ruiz@adacore.com> + + * errno.c (__get_errno, __set_errno for MaRTE): Transform then into + weak symbols so we use the version provided by MaRTE when available. + +2008-08-20 Emmanuel Briot <briot@adacore.com> + + * g-catiio.ads, g-catiio.adb: + (Value): Avoid an unnecessary system call to Clock in most cases. + This call is only needed when only the time is provided in the string, + and ignored in all other cases. This is more efficient. + +2008-08-20 Eric Botcazou <ebotcazou@adacore.com> + + * raise-gcc.c: Fix formatting nits. + +2008-08-20 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb: + (Adjust_Record_For_Reverse_Bit_Order): Do not access First_Bit for + non-existing component clause. + + * exp_ch5.adb: Minor reformatting + + * g-comlin.adb: Minor reformatting + + * make.adb: Minor reformatting + + * prj-proc.adb: Minor reformatting + + * stylesw.ads: Minor reformatting + +2008-08-20 Vincent Celier <celier@adacore.com> + + * make.adb (Gnatmake_Switch_Found): New Boolean global variable + (Switch_May_Be_Passed_To_The_Compiler): New Boolean global variable + (Add_Switches): New Boolean parameter Unknown_Switches_To_The_Compiler + defaulted to True. Fail when Unknown_Switches_To_The_Compiler is False + and a switch is not recognized by gnatmake. + (Gnatmake): Implement new scheme for gnatmake switches and global + compilation switches. + (Switches_Of): Try successively Switches (<file name>), + Switches ("Ada"), Switches (others) and Default_Switches ("Ada"). + +2008-08-20 Ed Schonberg <schonberg@adacore.com> + + * styleg-c.ads, styleg-c.adb (Missing_Overriding): new procedure to + implement style check that overriding operations are explicitly marked + at such. + + * style.ads (Missing_Overriding): new procedure that provides interface + to previous one. + + * stylesw.ads, stylesw.adb: New style switch -gnatyO, to enable check + that the declaration or body of overriding operations carries an + explicit overriding indicator. + + * sem_ch8.adb + (Analyze_Subprogram_Renaming): if operation is overriding, check whether + explicit indicator should be present. + + * sem_ch6.adb (Verify_Overriding_Indicator, + Check_Overriding_Indicator): If operation is overriding, check whether + declaration and/or body of subprogram should be present + +2008-08-20 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Naming_Schemes): Accept source file names for + gprbuild when casing is MixedCase, whatever the casing of the letters + in the file name. + +2008-08-20 Gary Dismukes <dismukes@adacore.com> + + * exp_ch3.adb (Build_Array_Init_Proc): Clarify comment related to + creating dummy init proc. + (Requires_Init_Proc): Return False in the case No_Default_Initialization + is in force and the type does not have associated default + initialization. Move test of Is_Public (with tests of restrictions + No_Initialize_Scalars and No_Default_Initialization) to end, past tests + for default initialization. + +2008-08-20 Jerome Lambourg <lambourg@adacore.com> + + * g-comlin.adb (For_Each_Simple_Switch): Take care of switches not part + of any alias or prefix but having attached parameters (as \"-O2\"). + +2008-08-20 Robert Dewar <dewar@adacore.com> + + * s-fileio.adb: Minor reformatting + +2008-08-20 Thomas Quinot <quinot@adacore.com> + + * exp_strm.adb (Build_Elementary_Input_Call, + Build_Elementary_Write_Call): Fix incorrect condition in circuitry that + selects the stream attribute routines for long float types. + +2008-08-20 Vincent Celier <celier@adacore.com> + + * prj-proc.adb (Process_Declarative_Items): Add Location for Array_Data + + * prj.ads (Array_Data): Add a component Location + +2008-08-20 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: + (Analyze_Pragma, case Obsolescent): Add entity information on the pragma + argument for ASIS and navigation use. + +2008-08-20 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Add comment. + +2008-08-20 Bob Duff <duff@adacore.com> + + * sem_eval.ads: Minor comment fix. + +2008-08-20 Bob Duff <duff@adacore.com> + + * exp_ch4.adb (Expand_N_And_Then, Expand_N_Or_Else): Improve constant + folding. We were folding things like "False and then ...", but not + "X and then ..." where X is a constant whose value is known at compile + time. + +2008-08-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch5.adb (Controlled_Type): New routine. + (Expand_N_Extended_Return_Statement): When generating a move of the + final list in extended return statements, check the type of the + function and in the case of double expanded return statements, the type + of the returned object. + (Expand_Simple_Function_Return): Perform an interface conversion when + the type of the returned object is an interface and the context is an + extended return statement. + +2008-08-20 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Set_Debug_Info_Needed): If the entity is a private type + and the full view is visible, set flag on full view as well. + +2008-08-20 Thomas Quinot <quinot@adacore.com> + + * g-comlin.adb: Minor reformatting + Minor code reorganization. + + * freeze.adb: Minor reformatting + +2008-08-20 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_File): An excluded Ada source file may be a + source of another project. + +2008-08-20 Pascal Obry <obry@adacore.com> + + * s-os_lib.ads: Minor reformatting. + +2008-08-20 Arnaud Charlet <charlet@adacore.com> + + * gnatvsn.ads: Minor reformatting. + +2008-08-20 Arnaud Charlet <charlet@adacore.com> + + * a-crbtgk.adb, repinfo.adb, g-traceb.ads, repinfo.ads, + system-linux-s390x.ads, s-fatflt.ads, s-parame-ae653.ads, g-spipat.adb, + g-spipat.ads, g-tasloc.adb, g-debpoo.adb, g-except.ads, g-debpoo.ads, + mdll-utl.adb, g-string.adb, g-soliop-solaris.ads, par-sync.adb, + exp_ch6.ads, a-cihama.ads, g-curexc.ads, system-linux-sh4.ads, + g-utf_32.adb, g-hesorg.adb, s-proinf-irix-athread.ads, s-parint.adb, + s-parint.ads, exp_ch7.ads, system-linux-alpha.ads, g-dirope.adb, + sinfo-cn.adb, par-labl.adb, a-ciorse.adb, g-calend.adb, + s-parame-vms-alpha.ads, nlists.h, exp_imgv.adb, exp_fixd.ads, + g-calend.ads, gnatcmd.ads, g-table.adb, s-memory-mingw.adb, + g-alveop.ads, g-memdum.ads, g-altive.ads, initialize.c, g-regpat.adb, + g-busorg.ads, g-regpat.ads, g-encstr.ads, g-regexp.adb, g-regexp.ads, + live.ads, g-dyntab.adb, prj-nmsc.ads, par-ch12.adb, 9drpc.adb, + g-alvevi.ads, s-memory.adb, math_lib.adb, s-parame.ads, s-memory.ads, + s-regexp.adb, a-exexda.adb, i-cstrea-vms.adb, a-exexpr.adb, + g-soliop-mingw.ads, s-imgrea.adb, namet.adb, system-vms.ads, + s-inmaop-dummy.adb, s-finroo.ads, a-ngcefu.adb, s-hibaen.ads, + g-soliop.ads, s-auxdec.adb, g-locfil.ads, gnatxref.adb, memroot.adb, + osint-b.ads, memroot.ads, s-parame-hpux.ads, errutil.adb, + system-linux-s390.ads, par-util.adb, osint-c.ads, exp_pakd.ads, + i-pacdec.ads, par-endh.adb, mlib-tgt.ads, prj-strt.ads, + s-osprim-vms.adb, s-proinf.ads, output.ads, g-moreex.ads, + a-finali.ads, s-fatlfl.ads, namet.h, mdll.ads, g-dynhta.ads, + s-imgenu.ads, par-tchk.adb, g-excact.ads, memtrack.adb, s-fatgen.adb, + a-exexpr-gcc.adb, g-arrspl.adb, par-ch4.adb, g-cgideb.adb, freeze.ads, + g-altcon.adb, s-fatllf.ads, gnatfind.adb, s-osinte-lynxos-3.adb, + a-exextr.adb, g-htable.ads, a-calfor.adb, s-imgcha.adb, argv.c, + a-chahan.ads, g-hesora.adb, system-vms_64.ads, par-ch5.adb, g-md5.adb, + lib-xref.ads, g-md5.ads, g-casuti.ads, s-fatsfl.ads, exp_dbug.ads, + s-htable.ads, a-ngcoar.adb, s-arit64.ads, a-ngelfu.adb, a-filico.ads, + par-ch6.adb, s-inmaop.ads, s-parame-vxworks.ads, s-casuti.ads, + a-numaux-darwin.adb, a-cohama.ads, system-linux-sparc.ads, g-os_lib.adb, + system-vms-ia64.ads, s-parame-vms-restrict.ads, a-clrefi.ads, + s-parame-vms-ia64.ads, a-strfix.adb, a-coorse.adb, a-comlin.ads, + a-chtgke.adb, s-imgint.adb, g-expect.ads, exp_ch4.ads, s-finimp.adb, + mingw32.h, g-heasor.adb, g-alleve.adb, a-ngrear.adb, s-mastop-irix.adb, + s-poosiz.adb, link.c: Fix copyright notice. + +2008-08-20 Arnaud Charlet <charlet@adacore.com> + + * g-comlin.ads: Update comments. + +2008-08-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Inherit Is_Imported flag. + +2008-08-20 Gary Dismukes <dismukes@adacore.com> + + * exp_ch11.adb: + (Expand_Exception_Handlers): Call Make_Exception_Handler instead of + Make_Implicit_Exception_Handler when rewriting an exception handler with + a choice parameter, and pass the handler's Sloc instead of that of the + handled sequence of statements. Make_Implicit_Exception_Handler sets the + Sloc to No_Location (unless debugging generated code), which we don't + want for the case of a user handler. + +2008-08-20 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Record_Type): Improve msg for non-contiguous field + + * sem_ch13.adb: + (Adjust_Record_For_Reverse_Bit_Order): Messages about layout are + now labeled as info msgs, not warnings. + + * tbuild.ads: Clarify documentation of Make_Implicit_Exception_Handler + + * usage.adb: Minor change to avoid overlong line for -gnatwz/Z + + * a-textio.adb: Remove redundant test. + + * a-witeio.adb: Minor code reorganization + Remove redundant test found working on another issue + + * a-ztexio.adb: Minor code reorganization + Remove redundant test found working on another issue + +2008-08-20 Thomas Quinot <quinot@adacore.com> + + * s-fileio.adb (Open) Use C helper function to determine whether a + given errno value corresponds to a "file not found" error. + + * sysdep.c (__gnat_is_file_not_found_error): New C helper function. + +2008-08-20 Jose Ruiz <ruiz@adacore.com> + + * errno.c (__get_errno for MaRTE): Use the MaRTE function pthread_errno + to get access to the per-task errno variable. + (__set_errno for MaRTE): Do not redefine this function here since it is + already defined in MaRTE. + +2008-08-20 Tristan Gingold <gingold@adacore.com> + + * gnat_ugn.texi: Gcov is not supported on static library on AIX. + +2008-08-20 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting + + * g-comlin.adb: Minor reformatting + + * g-socket.adb: Minor reformatting + + * g-socthi-mingw.adb: Minor reformatting + + * g-stheme.adb: Minor reformatting + +2008-08-20 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb, sem_type.adb, exp_ch9.ads, einfo.ads, + exp_ch6.adb, exp_aggr.adb (Valid_Ancestor): Resolve + confusion between partial and full views of an ancestor of the context + type when the parent is a private extension declared in a parent unit, + and full views are available for the context type. + +2008-08-18 Samuel Tardieu <sam@rfc1149.net> + Robert Dewar <dewar@adacore.com> + + PR ada/30827 + * bindgen.adb (Gen_Output_File_Ada): Zero-terminate the + version string. + Move comment in the right place. + * g-comver.adb (Version): Look for a zero-termination in + addition to a closing parenthesis. + +2008-08-18 Samuel Tardieu <sam@rfc1149.net> + + * exp_ch13.adb, exp_disp.adb, sem_cat.adb, sem_ch10.adb, + * sem_ch12.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, + * sem_prag.adb, sem_util.adb, sem_warn.adb: Use + Is_Package_Or_Generic_Package instead of hand-crafted tests. + +2008-08-18 Samuel Tardieu <sam@rfc1149.net> + + PR ada/15808 + * sem_ch6.adb (Check_Private_Overriding): Check for generic packages + as well. + +2008-08-17 Aaron W. LaFramboise <aaronavay62@aaronwl.com> + + * adaint.c (_gnat_set_close_on_exec) [_WIN32]: Implement. + +2008-08-16 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (call_to_gnu): Use the Sloc of the call + for back-copy statements in lieu of that of the actual. + +2008-08-16 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/20548 + * gcc-interface/decl.c (gnat_to_gnu_entity): Use DECL_SIZE_UNIT in the + setjmp test consistently. Adjust for new behavior of flag_stack_check. + * gcc-interface/utils2.c (build_call_alloc_dealloc): Remove redundant + test of flag_stack_check. Adjust for new behavior of flag_stack_check. + 2008-08-13 Samuel Tardieu <sam@rfc1149.net> PR ada/36777 @@ -11,8 +595,8 @@ 2008-08-12 Danny Smith <danyssmith@users.sourceforge.net> - * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) [WINDOWS]: Remove - duplicate s-win32.o. Add s-winext.o. + * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) [WINDOWS]: + Remove duplicate s-win32.o. Add s-winext.o. 2008-08-12 Danny Smith <danyssmith@users.sourceforge.net> diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb index 65645b2fba8..6d4254385be 100644 --- a/gcc/ada/a-calfor.adb +++ b/gcc/ada/a-calfor.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-chahan.ads b/gcc/ada/a-chahan.ads index 3e38c1ad465..bc7d2b92ebc 100644 --- a/gcc/ada/a-chahan.ads +++ b/gcc/ada/a-chahan.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index b7b43024652..614a9b9d2d3 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 0cf2ef03eec..11960f87c9b 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index e4427511bca..51531d9ba69 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-clrefi.ads b/gcc/ada/a-clrefi.ads index e75a2ffde56..e4062a3b9ec 100644 --- a/gcc/ada/a-clrefi.ads +++ b/gcc/ada/a-clrefi.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index dd4ebb15ca3..28efde48606 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads index 3945860d94c..4689c93c4ab 100644 --- a/gcc/ada/a-comlin.ads +++ b/gcc/ada/a-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 2016d18c035..3d9a25162a4 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index 022232c5218..f3f8e07dae4 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 94f4897f3ef..a71f48654e9 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index ae6e0f7b66f..80db0337135 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index 6ad6d4ead36..b9fe09567d5 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb index e9fa3e0ddec..f4357bf8049 100644 --- a/gcc/ada/a-exextr.adb +++ b/gcc/ada/a-exextr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-filico.ads b/gcc/ada/a-filico.ads index ee7c8ce28ad..b6aca172f9d 100644 --- a/gcc/ada/a-filico.ads +++ b/gcc/ada/a-filico.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads index 122eeb3f403..0eb3c0303cf 100644 --- a/gcc/ada/a-finali.ads +++ b/gcc/ada/a-finali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb index 98a2c769d05..2eb7bbe42dd 100644 --- a/gcc/ada/a-ngcefu.adb +++ b/gcc/ada/a-ngcefu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-ngcoar.adb b/gcc/ada/a-ngcoar.adb index 4d875283a60..4b120f5612e 100644 --- a/gcc/ada/a-ngcoar.adb +++ b/gcc/ada/a-ngcoar.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index 849d44dec8a..7ce69af492b 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb index 30eb1365b1d..3a6f2cf2b4d 100644 --- a/gcc/ada/a-ngrear.adb +++ b/gcc/ada/a-ngrear.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-numaux-darwin.adb b/gcc/ada/a-numaux-darwin.adb index a631f9abf75..ca943abe604 100644 --- a/gcc/ada/a-numaux-darwin.adb +++ b/gcc/ada/a-numaux-darwin.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Apple OS X Version) -- -- -- --- Copyright (C) 1998-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb index 7b2fbcdf31b..f39d158ed8e 100644 --- a/gcc/ada/a-strfix.adb +++ b/gcc/ada/a-strfix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index cc5a93bb076..d18da6533ce 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -1856,7 +1856,7 @@ package body Ada.Text_IO is if Start = 0 then File.WC_Method := WCEM_Brackets; - elsif Start /= 0 then + else if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index 1a4b0f5e0e7..cd25d411994 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -1552,7 +1552,7 @@ package body Ada.Wide_Text_IO is if Start = 0 then File.WC_Method := WCEM_Brackets; - elsif Start /= 0 then + else if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb index 4bf70405c67..5c97ccd59b6 100644 --- a/gcc/ada/a-ztexio.adb +++ b/gcc/ada/a-ztexio.adb @@ -1552,7 +1552,7 @@ package body Ada.Wide_Wide_Text_IO is if Start = 0 then File.WC_Method := WCEM_Brackets; - elsif Start /= 0 then + else if Stop = Start then for J in WC_Encoding_Letters'Range loop if File.Form (Start) = WC_Encoding_Letters (J) then diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index b7fdd08d252..4a87a2b95b5 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2101,25 +2101,26 @@ __gnat_dup2 (int oldfd, int newfd) /* Synchronization code, to be thread safe. */ -static CRITICAL_SECTION plist_cs; +#ifdef CERT -void -__gnat_plist_init (void) -{ - InitializeCriticalSection (&plist_cs); -} +/* For the Cert run times on native Windows we use dummy functions + for locking and unlocking tasks since we do not support multiple + threads on this configuration (Cert run time on native Windows). */ -static void -plist_enter (void) -{ - EnterCriticalSection (&plist_cs); -} +void dummy (void) {} -static void -plist_leave (void) -{ - LeaveCriticalSection (&plist_cs); -} +void (*Lock_Task) () = &dummy; +void (*Unlock_Task) () = &dummy; + +#else + +#define Lock_Task system__soft_links__lock_task +extern void (*Lock_Task) (void); + +#define Unlock_Task system__soft_links__unlock_task +extern void (*Unlock_Task) (void); + +#endif typedef struct _process_list { @@ -2138,16 +2139,16 @@ add_handle (HANDLE h) pl = (Process_List *) xmalloc (sizeof (Process_List)); - plist_enter(); - /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + pl->h = h; pl->next = PLIST; PLIST = pl; ++plist_length; - /* -------------------- critical section -------------------- */ - plist_leave(); + (*Unlock_Task) (); + /* -------------------- critical section -------------------- */ } static void @@ -2156,9 +2157,9 @@ remove_handle (HANDLE h) Process_List *pl; Process_List *prev = NULL; - plist_enter(); - /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + pl = PLIST; while (pl) { @@ -2179,9 +2180,9 @@ remove_handle (HANDLE h) } --plist_length; - /* -------------------- critical section -------------------- */ - plist_leave(); + (*Unlock_Task) (); + /* -------------------- critical section -------------------- */ } static int @@ -2266,6 +2267,7 @@ win32_wait (int *status) DWORD res; int k; Process_List *pl; + int hl_len; if (plist_length == 0) { @@ -2273,23 +2275,26 @@ win32_wait (int *status) return -1; } - hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length); - k = 0; - plist_enter(); /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + + hl_len = plist_length; + + hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len); + pl = PLIST; while (pl) { hl[k++] = pl->h; pl = pl->next; } - /* -------------------- critical section -------------------- */ - plist_leave(); + (*Unlock_Task) (); + /* -------------------- critical section -------------------- */ - res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE); + res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE); h = hl[res - WAIT_OBJECT_0]; free (hl); @@ -3248,12 +3253,17 @@ __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED, else flags &= ~FD_CLOEXEC; return fcntl (fd, F_SETFD, flags | FD_CLOEXEC); +#elif defined(_WIN32) + HANDLE h = (HANDLE) _get_osfhandle (fd); + if (h == (HANDLE) -1) + return -1; + if (close_on_exec_p) + return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0); + return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT); #else + /* TODO: Unimplemented. */ return -1; - /* For the Windows case, we should use SetHandleInformation to remove - the HANDLE_INHERIT property from fd. This is not implemented yet, - but for our purposes (support of GNAT.Expect) this does not matter, - as by default handles are *not* inherited. */ #endif } diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index e00bc4646c3..efc0ac28293 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -1999,13 +1999,17 @@ package body ALI is if Nextc not in '0' .. '9' then Name_Len := 0; - while not At_End_Of_Field loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; end loop; - Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter; + -- Set the subunit name. Note that we use Name_Find rather + -- than Name_Enter here as the subunit name may already + -- have been put in the name table by the Project Manager. + + Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; + Skip_Space; end if; diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c index 0adfa4ea948..ae5bd476578 100644 --- a/gcc/ada/argv.c +++ b/gcc/ada/argv.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2008, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 070651cbd6a..7f3f6274327 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -604,6 +604,20 @@ package body Bindgen is WBI (" pragma Import (C, Handler_Installed, " & """__gnat_handler_installed"");"); + -- Import entry point for environment feature enable/disable + -- routine, and indication that it's been called previously. + + if OpenVMS_On_Target then + WBI (""); + WBI (" procedure Set_Features;"); + WBI (" pragma Import (C, Set_Features, " & + """__gnat_set_features"");"); + WBI (""); + WBI (" Features_Set : Integer;"); + WBI (" pragma Import (C, Features_Set, " & + """__gnat_features_set"");"); + end if; + -- Initialize stack limit variable of the environment task if the -- stack check method is stack limit and stack check is enabled. @@ -765,6 +779,15 @@ package body Bindgen is WBI (" if Handler_Installed = 0 then"); WBI (" Install_Handler;"); WBI (" end if;"); + + -- Generate call to Set_Features + + if OpenVMS_On_Target then + WBI (""); + WBI (" if Features_Set = 0 then"); + WBI (" Set_Features;"); + WBI (" end if;"); + end if; end if; -- Generate call to set Initialize_Scalar values if active @@ -1048,6 +1071,15 @@ package body Bindgen is WBI (" {"); WBI (" __gnat_install_handler ();"); WBI (" }"); + + -- Call feature enable/disable routine + + if OpenVMS_On_Target then + WBI (" if (__gnat_features_set == 0)"); + WBI (" {"); + WBI (" __gnat_set_features ();"); + WBI (" }"); + end if; end if; -- Initialize stack limit for the environment task if the stack @@ -2267,17 +2299,19 @@ package body Bindgen is WBI (" gnat_exit_status : Integer;"); WBI (" pragma Import (C, gnat_exit_status);"); end if; - - -- Generate the GNAT_Version and Ada_Main_Program_Name info only - -- for the main program. Otherwise, it can lead under some - -- circumstances to a symbol duplication during the link (for - -- instance when a C program uses 2 Ada libraries) end if; + -- Generate the GNAT_Version and Ada_Main_Program_Name info only for + -- the main program. Otherwise, it can lead under some circumstances + -- to a symbol duplication during the link (for instance when a C + -- program uses two Ada libraries). Also zero terminate the string + -- so that its end can be found reliably at run time. + WBI (""); WBI (" GNAT_Version : constant String :="); WBI (" ""GNAT Version: " & - Gnat_Version_String & """;"); + Gnat_Version_String & + """ & ASCII.NUL;"); WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); WBI (""); @@ -2597,12 +2631,21 @@ package body Bindgen is Gen_Elab_Defs_C; - -- Imported variable used to track elaboration/finalization phase. - -- Used only when we have a runtime. + -- Imported variables used only when we have a runtime. if not Suppress_Standard_Library_On_Target then + + -- Track elaboration/finalization phase. + WBI ("extern int __gnat_handler_installed;"); WBI (""); + + -- Track feature enable/disable on VMS. + + if OpenVMS_On_Target then + WBI ("extern int __gnat_features_set;"); + WBI (""); + end if; end if; -- Write argv/argc exit status stuff if main program case diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 40e3057001f..12c5b64a9fc 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2042,7 +2042,9 @@ package body Checks is and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) and then - (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) + (In_Subrange_Of (S_Typ, Target_Typ, + Assume_Valid => True, + Fixed_Int => Fixed_Int) or else Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real)) then @@ -2349,7 +2351,10 @@ package body Checks is begin if not Overflow_Checks_Suppressed (Target_Base) - and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK) + and then not + In_Subrange_Of (Expr_Type, Target_Base, + Assume_Valid => True, + Fixed_Int => Conv_OK) and then not Float_To_Int then Activate_Overflow_Check (N); @@ -3021,7 +3026,8 @@ package body Checks is Lo : out Uint; Hi : out Uint) is - Typ : constant Entity_Id := Etype (N); + Typ : Entity_Id := Etype (N); + -- Type to use, may get reset to base type for possibly invalid entity Lo_Left : Uint; Hi_Left : Uint; @@ -3116,6 +3122,16 @@ package body Checks is -- overflow situation, which is a separate check, we are talking here -- only about the expression value). + -- First step, change to use base type if the expression is an entity + -- which we do not know is valid. + + if Is_Entity_Name (N) + and then not Is_Known_Valid (Entity (N)) + and then not Assume_No_Invalid_Values + then + Typ := Base_Type (Typ); + end if; + -- We use the actual bound unless it is dynamic, in which case use the -- corresponding base type bound if possible. If we can't get a bound -- then we figure we can't determine the range (a peculiar case, that @@ -4561,7 +4577,7 @@ package body Checks is -- case the literal has already been labeled as having the subtype of -- the target. - if In_Subrange_Of (Source_Type, Target_Type) + if In_Subrange_Of (Source_Type, Target_Type, Assume_Valid => True) and then not (Nkind (N) = N_Integer_Literal or else @@ -4616,7 +4632,9 @@ package body Checks is -- The conversions will always work and need no check - elsif In_Subrange_Of (Target_Type, Source_Base_Type) then + elsif In_Subrange_Of + (Target_Type, Source_Base_Type, Assume_Valid => True) + then Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => @@ -4648,7 +4666,9 @@ package body Checks is -- If that is the case, we can freely convert the source to the target, -- and then test the target result against the bounds. - elsif In_Subrange_Of (Source_Type, Target_Base_Type) then + elsif In_Subrange_Of + (Source_Type, Target_Base_Type, Assume_Valid => True) + then -- We make a temporary to hold the value of the converted value -- (converted to the base type), and then we will do the test against @@ -6811,7 +6831,7 @@ package body Checks is -- range of the target type. else - if not In_Subrange_Of (S_Typ, T_Typ) then + if not In_Subrange_Of (S_Typ, T_Typ, Assume_Valid => True) then Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); end if; end if; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c7182dbe04f..a7058747149 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -5016,6 +5016,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic function only) -- Protection_Object (Node23) (for concurrent kind) + -- Spec_PPC_List (Node24) -- Interface_Alias (Node25) -- Overridden_Operation (Node26) -- Wrapped_Entity (Node27) (non-generic case only) diff --git a/gcc/ada/errno.c b/gcc/ada/errno.c index 93981d60a8f..811cbdbbf8d 100644 --- a/gcc/ada/errno.c +++ b/gcc/ada/errno.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2005, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -41,6 +41,18 @@ #define _THREAD_SAFE #define _SGI_MP_SOURCE +#ifdef MaRTE + +/* MaRTE OS provides its own implementation of errno related functionality. We + want to ensure the use of the MaRTE version for tasking programs (the MaRTE + library will not be linked if no tasking constructs are used), so we use the + weak symbols mechanism to use the MaRTE version whenever is available. */ + +#pragma weak __get_errno +#pragma weak __set_errno + +#endif + #include <errno.h> int __get_errno(void) diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 1d66ad271da..222f73b5034 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index bc3b954fb6c..df5617a09fc 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -973,7 +973,7 @@ package body Exp_Aggr is if Present (Flist) then F := New_Copy_Tree (Flist); - elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then + elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then if Is_Entity_Name (Into) and then Present (Scope (Entity (Into))) then @@ -1137,7 +1137,7 @@ package body Exp_Aggr is Expression => Make_Null (Loc))); end if; - if Controlled_Type (Ctype) then + if Needs_Finalization (Ctype) then Append_List_To (L, Make_Init_Call ( Ref => New_Copy_Tree (Indexed_Comp), @@ -1159,7 +1159,7 @@ package body Exp_Aggr is Name => Indexed_Comp, Expression => New_Copy_Tree (Expr)); - if Present (Comp_Type) and then Controlled_Type (Comp_Type) then + if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then Set_No_Ctrl_Actions (A); -- If this is an aggregate for an array of arrays, each @@ -1223,7 +1223,7 @@ package body Exp_Aggr is -- inner finalization actions). if Present (Comp_Type) - and then Controlled_Type (Comp_Type) + and then Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) and then (not Is_Array_Type (Comp_Type) @@ -2167,7 +2167,7 @@ package body Exp_Aggr is -- proper scope is the scope of the target rather than the -- potentially transient current scope. - if Controlled_Type (Typ) then + if Needs_Finalization (Typ) then -- The current aggregate belongs to an allocator which creates -- an object through an anonymous access type or acts as the root @@ -2645,7 +2645,7 @@ package body Exp_Aggr is -- Call Adjust manually - if Controlled_Type (Etype (A)) + if Needs_Finalization (Etype (A)) and then not Is_Limited_Type (Etype (A)) then Append_List_To (Assign, @@ -2854,7 +2854,7 @@ package body Exp_Aggr is -- The controller is the one of the parent type defining the -- component (in case of inherited components). - if Controlled_Type (Comp_Type) then + if Needs_Finalization (Comp_Type) then Internal_Final_List := Make_Selected_Component (Loc, Prefix => Convert_To ( @@ -3027,7 +3027,7 @@ package body Exp_Aggr is -- Attach_To_Final_List (tmp.comp, -- comp_typ (tmp)._record_controller.f) - if Controlled_Type (Comp_Type) + if Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) then Append_List_To (L, @@ -4961,7 +4961,7 @@ package body Exp_Aggr is or else Parent_Kind = N_Extension_Aggregate or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration - and then Controlled_Type (Typ)) + and then Needs_Finalization (Typ)) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) then @@ -6441,7 +6441,13 @@ package body Exp_Aggr is loop Append_To (Expressions (Agg), New_Copy (Expression (Expr))); - Set_Etype (Last (Expressions (Agg)), Component_Type (Typ)); + + -- The copied expression must be analyzed and resolved. + -- Besides setting the type, this ensures that static + -- expressions are appropriately marked as such. + + Analyze_And_Resolve + (Last (Expressions (Agg)), Component_Type (Typ)); end loop; Set_Aggregate_Bounds (Agg, Bounds); @@ -6458,4 +6464,5 @@ package body Exp_Aggr is return False; end if; end Static_Array_Aggregate; + end Exp_Aggr; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 80cd34d5593..04e7a0bdbe2 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -607,10 +607,14 @@ package body Exp_Attr is begin -- Do required validity checking, if enabled. Do not apply check to -- output parameters of an Asm instruction, since the value of this - -- is not set till after the attribute has been elaborated. + -- is not set till after the attribute has been elaborated, and do + -- not apply the check to the arguments of a 'Read or 'Input attribute + -- reference since the scalar argument is an OUT scalar. if Validity_Checks_On and then Validity_Check_Operands and then Id /= Attribute_Asm_Output + and then Id /= Attribute_Read + and then Id /= Attribute_Input then declare Expr : Node_Id; @@ -657,8 +661,8 @@ package body Exp_Attr is Attribute_Unrestricted_Access => Access_Cases : declare - Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp); Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); + Btyp_DDT : Entity_Id; function Enclosing_Object (N : Node_Id) return Node_Id; -- If N denotes a compound name (selected component, indexed @@ -692,6 +696,27 @@ package body Exp_Attr is -- Start of processing for Access_Cases begin + Btyp_DDT := Designated_Type (Btyp); + + -- Handle designated types that come from the limited view + + if Ekind (Btyp_DDT) = E_Incomplete_Type + and then From_With_Type (Btyp_DDT) + and then Present (Non_Limited_View (Btyp_DDT)) + then + Btyp_DDT := Non_Limited_View (Btyp_DDT); + + elsif Is_Class_Wide_Type (Btyp_DDT) + and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type + and then From_With_Type (Etype (Btyp_DDT)) + and then Present (Non_Limited_View (Etype (Btyp_DDT))) + and then Present (Class_Wide_Type + (Non_Limited_View (Etype (Btyp_DDT)))) + then + Btyp_DDT := + Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT))); + end if; + -- In order to improve the text of error messages, the designated -- type of access-to-subprogram itypes is set by the semantics as -- the associated subprogram entity (see sem_attr). Now we replace @@ -882,11 +907,10 @@ package body Exp_Attr is if Btyp_DDT /= Etype (Ref_Object) then Rewrite (Prefix (N), - Convert_To (Directly_Designated_Type (Typ), + Convert_To (Btyp_DDT, New_Copy_Tree (Prefix (N)))); - Analyze_And_Resolve (Prefix (N), - Directly_Designated_Type (Typ)); + Analyze_And_Resolve (Prefix (N), Btyp_DDT); end if; -- When the object is an explicit dereference, convert the diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index a8219fe7c9f..7ad1881151a 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1011,7 +1011,8 @@ package body Exp_Ch11 is if Present (Choice_Parameter (Handler)) then declare Cparm : constant Entity_Id := Choice_Parameter (Handler); - Clc : constant Source_Ptr := Sloc (Cparm); + Cloc : constant Source_Ptr := Sloc (Cparm); + Hloc : constant Source_Ptr := Sloc (Handler); Save : Node_Id; begin @@ -1020,7 +1021,7 @@ package body Exp_Ch11 is Name => New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Cparm, Clc), + New_Occurrence_Of (Cparm, Cloc), Make_Explicit_Dereference (Loc, Make_Function_Call (Loc, Name => Make_Explicit_Dereference (Loc, @@ -1032,24 +1033,33 @@ package body Exp_Ch11 is Obj_Decl := Make_Object_Declaration - (Clc, + (Cloc, Defining_Identifier => Cparm, Object_Definition => New_Occurrence_Of - (RTE (RE_Exception_Occurrence), Clc)); + (RTE (RE_Exception_Occurrence), Cloc)); Set_No_Initialization (Obj_Decl, True); Rewrite (Handler, - Make_Implicit_Exception_Handler (Loc, + Make_Exception_Handler (Hloc, + Choice_Parameter => Empty, Exception_Choices => Exception_Choices (Handler), Statements => New_List ( - Make_Block_Statement (Loc, + Make_Block_Statement (Hloc, Declarations => New_List (Obj_Decl), Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, + Make_Handled_Sequence_Of_Statements (Hloc, Statements => Statements (Handler)))))); + -- Local raise statements can't occur, since exception + -- handlers with choice parameters are not allowed when + -- No_Exception_Propagation applies, so set attributes + -- accordingly. + + Set_Local_Raise_Statements (Handler, No_Elist); + Set_Local_Raise_Not_OK (Handler); + Analyze_List (Statements (Handler), Suppress => All_Checks); end; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 4d2967bbf0f..af94e1d8f92 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -259,9 +259,8 @@ package body Exp_Ch13 is Push_Scope (E_Scope); Install_Visible_Declarations (E_Scope); - if Ekind (E_Scope) = E_Package or else - Ekind (E_Scope) = E_Generic_Package or else - Is_Protected_Type (E_Scope) or else + if Is_Package_Or_Generic_Package (E_Scope) or else + Is_Protected_Type (E_Scope) or else Is_Task_Type (E_Scope) then Install_Private_Declarations (E_Scope); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b5fac5c8594..f2b3eaff0e3 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -692,9 +692,9 @@ package body Exp_Ch3 is -- would be needed if this restriction was not active (so that we can -- detect attempts to call it), so set a dummy init_proc in place. -- This is only done though when actual default initialization is - -- needed, so we exclude the setting in the Is_Public case, such - -- as for arrays of scalars, since otherwise such objects would be - -- wrongly flagged as violating the restriction. + -- needed (and not done when only Is_Public is True), since otherwise + -- objects such as arrays of scalars could be wrongly flagged as + -- violating the restriction. if Restriction_Active (No_Default_Initialization) then if Has_Default_Init then @@ -732,7 +732,7 @@ package body Exp_Ch3 is -- in any case no point in inlining such complex init procs. if not Has_Task (Proc_Id) - and then not Controlled_Type (Proc_Id) + and then not Needs_Finalization (Proc_Id) then Set_Is_Inlined (Proc_Id); end if; @@ -1581,7 +1581,7 @@ package body Exp_Ch3 is Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then @@ -1694,11 +1694,11 @@ package body Exp_Ch3 is ---------------------------- procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is - Loc : Source_Ptr := Sloc (N); - Discr_Map : constant Elist_Id := New_Elmt_List; - Proc_Id : Entity_Id; - Rec_Type : Entity_Id; - Set_Tag : Entity_Id := Empty; + Loc : Source_Ptr := Sloc (N); + Discr_Map : constant Elist_Id := New_Elmt_List; + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Set_Tag : Entity_Id := Empty; function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; -- Build a assignment statement node which assigns to record component @@ -1865,7 +1865,7 @@ package body Exp_Ch3 is Kind := Nkind (Expression (N)); end if; - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) and then not Is_Inherently_Limited_Type (Typ) then @@ -2515,6 +2515,47 @@ package body Exp_Ch3 is Statement_List := New_List; + -- Loop through visible declarations of task types and protected + -- types moving any expanded code from the spec to the body of the + -- init procedure + + if Is_Task_Record_Type (Rec_Type) + or else Is_Protected_Record_Type (Rec_Type) + then + declare + Decl : constant Node_Id := + Parent (Corresponding_Concurrent_Type (Rec_Type)); + Def : Node_Id; + N1 : Node_Id; + N2 : Node_Id; + + begin + if Is_Task_Record_Type (Rec_Type) then + Def := Task_Definition (Decl); + else + Def := Protected_Definition (Decl); + end if; + + if Present (Def) then + N1 := First (Visible_Declarations (Def)); + while Present (N1) loop + N2 := N1; + N1 := Next (N1); + + if Nkind (N2) in N_Statement_Other_Than_Procedure_Call + or else Nkind (N2) in N_Raise_xxx_Error + or else Nkind (N2) = N_Procedure_Call_Statement + then + Append_To (Statement_List, + New_Copy_Tree (N2, New_Scope => Proc_Id)); + Rewrite (N2, Make_Null_Statement (Sloc (N2))); + Analyze (N2); + end if; + end loop; + end if; + end; + end if; + -- Loop through components, skipping pragmas, in 2 steps. The first -- step deals with regular components. The second step deals with -- components have per object constraints, and no explicit initia- @@ -3013,11 +3054,6 @@ package body Exp_Ch3 is elsif Is_Interface (Rec_Id) then return False; - elsif not Restriction_Active (No_Initialize_Scalars) - and then Is_Public (Rec_Id) - then - return True; - elsif (Has_Discriminants (Rec_Id) and then not Is_Unchecked_Union (Rec_Id)) or else Is_Tagged_Type (Rec_Id) @@ -3042,6 +3078,22 @@ package body Exp_Ch3 is Next_Component (Id); end loop; + -- As explained above, a record initialization procedure is needed + -- for public types in case Initialize_Scalars applies to a client. + -- However, such a procedure is not needed in the case where either + -- of restrictions No_Initialize_Scalars or No_Default_Initialization + -- apply. No_Initialize_Scalars excludes the possibility of using + -- Initialize_Scalars in any partition, and No_Default_Initialization + -- implies that no initialization should ever be done for objects of + -- the type, so is incompatible with Initialize_Scalars. + + if not Restriction_Active (No_Initialize_Scalars) + and then not Restriction_Active (No_Default_Initialization) + and then Is_Public (Rec_Id) + then + return True; + end if; + return False; end Requires_Init_Proc; @@ -3068,7 +3120,7 @@ package body Exp_Ch3 is -- If there are discriminants, build the discriminant map to replace -- discriminants by their discriminals in complex bound expressions. - -- These only arise for the corresponding records of protected types. + -- These only arise for the corresponding records of synchronized types. if Is_Concurrent_Record_Type (Rec_Type) and then Has_Discriminants (Rec_Type) @@ -3134,7 +3186,7 @@ package body Exp_Ch3 is if not Is_Concurrent_Type (Rec_Type) and then not Has_Task (Rec_Type) - and then not Controlled_Type (Rec_Type) + and then not Needs_Finalization (Rec_Type) then Set_Is_Inlined (Proc_Id); end if; @@ -4177,7 +4229,7 @@ package body Exp_Ch3 is -- Initialize call as it is required but one for each ancestor of -- its type. This processing is suppressed if No_Initialization set. - if not Controlled_Type (Typ) + if not Needs_Finalization (Typ) or else No_Initialization (N) then null; @@ -4515,7 +4567,7 @@ package body Exp_Ch3 is -- we plan to support in-place function results for some cases -- of nonlimited types. ???) - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) and then not BIP_Call then @@ -4990,7 +5042,7 @@ package body Exp_Ch3 is end if; elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); end if; @@ -5506,7 +5558,7 @@ package body Exp_Ch3 is Set_Has_Controlled_Component (Def_Id); elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then if No (Flist) then Flist := Add_Final_Chain (Def_Id); @@ -6133,7 +6185,7 @@ package body Exp_Ch3 is then null; - elsif (Controlled_Type (Desig_Type) + elsif (Needs_Finalization (Desig_Type) and then Convention (Desig_Type) /= Convention_Java and then Convention (Desig_Type) /= Convention_CIL) or else @@ -6157,7 +6209,7 @@ package body Exp_Ch3 is or else (Is_Array_Type (Desig_Type) and then not Is_Frozen (Desig_Type) - and then Controlled_Type (Component_Type (Desig_Type))) + and then Needs_Finalization (Component_Type (Desig_Type))) -- The designated type has controlled anonymous access -- discriminants. @@ -7831,7 +7883,7 @@ package body Exp_Ch3 is null; elsif Etype (Tag_Typ) = Tag_Typ - or else Controlled_Type (Tag_Typ) + or else Needs_Finalization (Tag_Typ) -- Ada 2005 (AI-251): We must also generate these subprograms if -- the immediate ancestor is an interface to ensure the correct diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2f95a84207d..6e763729a46 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -575,7 +575,7 @@ package body Exp_Ch4 is -- Start of processing for Expand_Allocator_Expression begin - if Is_Tagged_Type (T) or else Controlled_Type (T) then + if Is_Tagged_Type (T) or else Needs_Finalization (T) then -- Ada 2005 (AI-318-02): If the initialization expression is a call -- to a build-in-place function, then access to the allocated object @@ -669,7 +669,7 @@ package body Exp_Ch4 is Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); - if Controlled_Type (T) + if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter @@ -717,7 +717,7 @@ package body Exp_Ch4 is -- Inherit the final chain to ensure that the expansion of the -- aggregate is correct in case of controlled types - if Controlled_Type (Directly_Designated_Type (PtrT)) then + if Needs_Finalization (Directly_Designated_Type (PtrT)) then Set_Associated_Final_Chain (Def_Id, Associated_Final_Chain (PtrT)); end if; @@ -739,7 +739,7 @@ package body Exp_Ch4 is Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); - if Controlled_Type (T) + if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter @@ -835,8 +835,8 @@ package body Exp_Ch4 is Insert_Action (N, Tag_Assign); end if; - if Controlled_Type (DesigT) - and then Controlled_Type (T) + if Needs_Finalization (DesigT) + and then Needs_Finalization (T) then declare Attach : Node_Id; @@ -868,7 +868,7 @@ package body Exp_Ch4 is -- Normal case, not a secondary stack allocation else - if Controlled_Type (T) + if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter @@ -3502,7 +3502,7 @@ package body Exp_Ch4 is Parameter_Associations => Args)); end if; - if Controlled_Type (T) then + if Needs_Finalization (T) then -- Postpone the generation of a finalization call for the -- current allocator if it acts as a coextension. @@ -3591,34 +3591,33 @@ package body Exp_Ch4 is Set_Etype (N, Standard_Boolean); end if; - -- Check for cases of left argument is True or False + -- Check for cases where left argument is known to be True or False - if Nkind (Left) = N_Identifier then + if Compile_Time_Known_Value (Left) then -- If left argument is True, change (True and then Right) to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. - if Entity (Left) = Standard_True then + if Expr_Value_E (Left) = Standard_True then if Present (Actions (N)) then Insert_Actions (N, Actions (N)); end if; Rewrite (N, Right); - Adjust_Result_Type (N, Typ); - return; -- If left argument is False, change (False and then Right) to False. -- In this case we can forget the actions associated with Right, -- since they will never be executed. - elsif Entity (Left) = Standard_False then + else pragma Assert (Expr_Value_E (Left) = Standard_False); Kill_Dead_Code (Right); Kill_Dead_Code (Actions (N)); Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - Adjust_Result_Type (N, Typ); - return; end if; + + Adjust_Result_Type (N, Typ); + return; end if; -- If Actions are present, we expand @@ -3650,19 +3649,19 @@ package body Exp_Ch4 is -- No actions present, check for cases of right argument True/False - if Nkind (Right) = N_Identifier then + if Compile_Time_Known_Value (Right) then -- Change (Left and then True) to Left. Note that we know there are -- no actions associated with the True operand, since we just checked -- for this case above. - if Entity (Right) = Standard_True then + if Expr_Value_E (Right) = Standard_True then Rewrite (N, Left); -- Change (Left and then False) to False, making sure to preserve any -- side effects associated with the Left operand. - elsif Entity (Right) = Standard_False then + else pragma Assert (Expr_Value_E (Right) = Standard_False); Remove_Side_Effects (Left); Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); @@ -3827,8 +3826,10 @@ package body Exp_Ch4 is Lo_Orig : constant Node_Id := Original_Node (Lo); Hi_Orig : constant Node_Id := Original_Node (Hi); - Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo); - Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi); + Lcheck : constant Compare_Result := + Compile_Time_Compare (Lop, Lo, Assume_Valid => True); + Ucheck : constant Compare_Result := + Compile_Time_Compare (Lop, Hi, Assume_Valid => True); Warn1 : constant Boolean := Constant_Condition_Warnings @@ -6707,34 +6708,33 @@ package body Exp_Ch4 is Set_Etype (N, Standard_Boolean); end if; - -- Check for cases of left argument is True or False + -- Check for cases where left argument is known to be True or False - if Nkind (Left) = N_Identifier then + if Compile_Time_Known_Value (Left) then -- If left argument is False, change (False or else Right) to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. - if Entity (Left) = Standard_False then + if Expr_Value_E (Left) = Standard_False then if Present (Actions (N)) then Insert_Actions (N, Actions (N)); end if; Rewrite (N, Right); - Adjust_Result_Type (N, Typ); - return; -- If left argument is True, change (True and then Right) to True. In -- this case we can forget the actions associated with Right, since -- they will never be executed. - elsif Entity (Left) = Standard_True then + else pragma Assert (Expr_Value_E (Left) = Standard_True); Kill_Dead_Code (Right); Kill_Dead_Code (Actions (N)); Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - Adjust_Result_Type (N, Typ); - return; end if; + + Adjust_Result_Type (N, Typ); + return; end if; -- If Actions are present, we expand @@ -6766,19 +6766,19 @@ package body Exp_Ch4 is -- No actions present, check for cases of right argument True/False - if Nkind (Right) = N_Identifier then + if Compile_Time_Known_Value (Right) then -- Change (Left or else False) to Left. Note that we know there are -- no actions associated with the True operand, since we just checked -- for this case above. - if Entity (Right) = Standard_False then + if Expr_Value_E (Right) = Standard_False then Rewrite (N, Left); -- Change (Left or else True) to True, making sure to preserve any -- side effects associated with the Left operand. - elsif Entity (Right) = Standard_True then + else pragma Assert (Expr_Value_E (Right) = Standard_True); Remove_Side_Effects (Left); Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); @@ -9027,7 +9027,8 @@ package body Exp_Ch4 is Op1 : constant Node_Id := Left_Opnd (N); Op2 : constant Node_Id := Right_Opnd (N); - Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2); + Res : constant Compare_Result := + Compile_Time_Compare (Op1, Op2, Assume_Valid => True); -- Res indicates if compare outcome can be compile time determined True_Result : Boolean; diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index ff0689ea311..d1ed208f1b3 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 2215912b22c..d1c9d884e95 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -614,10 +614,14 @@ package body Exp_Ch5 is -- or upper bounds at compile time and compare them. else - Cresult := Compile_Time_Compare (Left_Lo, Right_Lo); + Cresult := + Compile_Time_Compare + (Left_Lo, Right_Lo, Assume_Valid => True); if Cresult = Unknown then - Cresult := Compile_Time_Compare (Left_Hi, Right_Hi); + Cresult := + Compile_Time_Compare + (Left_Hi, Right_Hi, Assume_Valid => True); end if; case Cresult is @@ -728,7 +732,7 @@ package body Exp_Ch5 is -- Cases where either Forwards_OK or Backwards_OK is true if Forwards_OK (N) or else Backwards_OK (N) then - if Controlled_Type (Component_Type (L_Type)) + if Needs_Finalization (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) @@ -862,7 +866,7 @@ package body Exp_Ch5 is Right_Opnd => Cright_Lo); end if; - if Controlled_Type (Component_Type (L_Type)) + if Needs_Finalization (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) @@ -1775,7 +1779,7 @@ package body Exp_Ch5 is return; elsif Is_Tagged_Type (Typ) - or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ)) + or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) then Tagged_Case : declare L : List_Id := No_List; @@ -1937,7 +1941,7 @@ package body Exp_Ch5 is -- If no restrictions on aborts, protect the whole assignment -- for controlled objects as per 9.8(11). - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then Expand_Ctrl_Actions and then Abort_Allowed then @@ -2371,6 +2375,7 @@ package body Exp_Ch5 is Parent (Return_Object_Entity); Parent_Function : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); + Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function); Is_Build_In_Place : constant Boolean := Is_Build_In_Place_Function (Parent_Function); @@ -2380,6 +2385,10 @@ package body Exp_Ch5 is Result : Node_Id; Exp : Node_Id; + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled or contains a controlled + -- subcomponent. + function Move_Activation_Chain return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain -- with parameters: @@ -2394,6 +2403,17 @@ package body Exp_Ch5 is -- From finalization list of the return statement -- To finalization list passed in by the caller + -------------------------- + -- Has_Controlled_Parts -- + -------------------------- + + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is + begin + return + Is_Controlled (Typ) + or else Has_Controlled_Component (Typ); + end Has_Controlled_Parts; + --------------------------- -- Move_Activation_Chain -- --------------------------- @@ -2518,23 +2538,23 @@ package body Exp_Ch5 is -- in the rather obscure case of a select-then-abort statement whose -- abortable part contains the return statement. - -- We test the type of the expression as well as the return type - -- of the function, because the latter may be a class-wide type - -- which is always treated as controlled, while the expression itself - -- has to have a definite type. The expression may be absent if a - -- constrained aggregate has been expanded into component assignments - -- so we have to check for this as well. + -- Check the type of the function to determine whether to move the + -- finalization list. A special case arises when processing a simple + -- return statement which has been rewritten as an extended return. + -- In that case check the type of the returned object or the original + -- expression. if Is_Build_In_Place - and then Controlled_Type (Etype (Parent_Function)) + and then + (Has_Controlled_Parts (Parent_Function_Typ) + or else (Is_Class_Wide_Type (Parent_Function_Typ) + and then + Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) + or else Has_Controlled_Parts (Etype (Return_Object_Entity)) + or else (Present (Exp) + and then Has_Controlled_Parts (Etype (Exp)))) then - if not Is_Class_Wide_Type (Etype (Parent_Function)) - or else - (Present (Exp) - and then Controlled_Type (Etype (Exp))) - then - Append_To (Statements, Move_Final_List); - end if; + Append_To (Statements, Move_Final_List); end if; -- Similarly to the above Move_Final_List, if the result type @@ -3655,7 +3675,23 @@ package body Exp_Ch5 is Exptyp : constant Entity_Id := Etype (Exp); -- The type of the expression (not necessarily the same as R_Type) + Subtype_Ind : Node_Id; + -- If the result type of the function is class-wide and the + -- expression has a specific type, then we use the expression's + -- type as the type of the return object. In cases where the + -- expression is an aggregate that is built in place, this avoids + -- the need for an expensive conversion of the return object to + -- the specific type on assignments to the individual components. + begin + if Is_Class_Wide_Type (R_Type) + and then not Is_Class_Wide_Type (Etype (Exp)) + then + Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); + else + Subtype_Ind := New_Occurrence_Of (R_Type, Loc); + end if; + -- For the case of a simple return that does not come from an extended -- return, in the case of Ada 2005 where we are returning a limited -- type, we rewrite "return <expression>;" to be: @@ -3678,7 +3714,7 @@ package body Exp_Ch5 is -- inherently limited). We might prefer to do this translation in all -- cases (except perhaps for the case of Ada 95 inherently limited), -- in order to fully exercise the Expand_N_Extended_Return_Statement - -- code. This would also allow us to to the build-in-place optimization + -- code. This would also allow us to do the build-in-place optimization -- for efficiency even in cases where it is semantically not required. -- As before, we check the type of the return expression rather than the @@ -3695,39 +3731,21 @@ package body Exp_Ch5 is Return_Object_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Subtype_Ind : Node_Id; + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Object_Entity, + Object_Definition => Subtype_Ind, + Expression => Exp); - begin - -- If the result type of the function is class-wide and the - -- expression has a specific type, then we use the expression's - -- type as the type of the return object. In cases where the - -- expression is an aggregate that is built in place, this avoids - -- the need for an expensive conversion of the return object to - -- the specific type on assignments to the individual components. - - if Is_Class_Wide_Type (R_Type) - and then not Is_Class_Wide_Type (Etype (Exp)) - then - Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); - else - Subtype_Ind := New_Occurrence_Of (R_Type, Loc); - end if; + Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl)); + -- Do not perform this high-level optimization if the result type + -- is an interface because the "this" pointer must be displaced. - declare - Obj_Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Object_Entity, - Object_Definition => Subtype_Ind, - Expression => Exp); - - Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Obj_Decl)); - - begin - Rewrite (N, Ext); - Analyze (N); - return; - end; + begin + Rewrite (N, Ext); + Analyze (N); + return; end; end if; @@ -3836,7 +3854,7 @@ package body Exp_Ch5 is and then (not Is_Array_Type (Exptyp) or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) - or else CW_Or_Controlled_Type (Utyp)) + or else CW_Or_Has_Controlled_Part (Utyp)) and then Nkind (Exp) = N_Function_Call then Set_By_Ref (N); @@ -3859,7 +3877,7 @@ package body Exp_Ch5 is -- controlled (by the virtue of restriction No_Finalization) because -- gigi is not able to properly allocate class-wide types. - elsif CW_Or_Controlled_Type (Utyp) then + elsif CW_Or_Has_Controlled_Part (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := @@ -3882,13 +3900,17 @@ package body Exp_Ch5 is Subtype_Mark => New_Reference_To (Etype (Exp), Loc), Expression => Relocate_Node (Exp))); + -- We do not want discriminant checks on the declaration, + -- given that it gets its value from the allocator. + + Set_No_Initialization (Alloc_Node); + Insert_List_Before_And_Analyze (N, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Reference_To (R_Type, Loc))), + Subtype_Indication => Subtype_Ind)), Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -4177,6 +4199,21 @@ package body Exp_Ch5 is Name => Make_Identifier (Loc, Name_uPostconditions), Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); end if; + + -- Ada 2005 (AI-251): If this return statement corresponds with an + -- simple return statement associated with an extended return statement + -- and the type of the returned object is an interface then generate an + -- implicit conversion to force displacement of the "this" pointer. + + if Ada_Version >= Ada_05 + and then Comes_From_Extended_Return_Statement (N) + and then Nkind (Expression (N)) = N_Identifier + and then Is_Interface (Utyp) + and then Utyp /= Underlying_Type (Exptyp) + then + Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp); + end if; end Expand_Simple_Function_Return; ------------------------------ @@ -4188,7 +4225,7 @@ package body Exp_Ch5 is L : constant Node_Id := Name (N); T : constant Entity_Id := Underlying_Type (Etype (L)); - Ctrl_Act : constant Boolean := Controlled_Type (T) + Ctrl_Act : constant Boolean := Needs_Finalization (T) and then not No_Ctrl_Actions (N); Save_Tag : constant Boolean := Is_Tagged_Type (T) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4c3f3da63f9..a84b0255ad8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -391,21 +391,20 @@ package body Exp_Ch6 is Final_List_Actual : Node_Id; Final_List_Formal : Node_Id; Is_Ctrl_Result : constant Boolean := - Controlled_Type + Needs_Finalization (Underlying_Type (Etype (Function_Id))); begin -- No such extra parameter is needed if there are no controlled parts. - -- The test for Controlled_Type accounts for class-wide results (which - -- potentially have controlled parts, even if the root type doesn't), - -- and the test for a tagged result type is needed because calls to - -- such a function can in general occur in dispatching contexts, which - -- must be treated the same as a call to class-wide functions. Both of - -- these situations require that a finalization list be passed. - - if not Is_Ctrl_Result - and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) - then + -- The test for Needs_Finalization accounts for class-wide results + -- (which potentially have controlled parts, even if the root type + -- doesn't), and the test for a tagged result type is needed because + -- calls to such a function can in general occur in dispatching + -- contexts, which must be treated the same as a call to class-wide + -- functions. Both of these situations require that a finalization list + -- be passed. + + if not Needs_BIP_Final_List (Function_Id) then return; end if; @@ -3034,7 +3033,7 @@ package body Exp_Ch6 is -- If the return type is limited the context is an initialization -- and different processing applies. - if Controlled_Type (Etype (Subp)) + if Needs_Finalization (Etype (Subp)) and then not Is_Inherently_Limited_Type (Etype (Subp)) and then not Is_Limited_Interface (Etype (Subp)) then @@ -4276,7 +4275,7 @@ package body Exp_Ch6 is elsif Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Spec_Id); end if; end; @@ -4903,7 +4902,7 @@ package body Exp_Ch6 is begin if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Subp); - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); end if; end; @@ -5592,4 +5591,24 @@ package body Exp_Ch6 is end if; end Make_Build_In_Place_Call_In_Object_Declaration; + -------------------------- + -- Needs_BIP_Final_List -- + -------------------------- + + function Needs_BIP_Final_List (E : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (E)); + Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + + begin + -- We need the BIP_Final_List if the result type needs finalization. We + -- also need it for tagged types, even if not class-wide, because some + -- type extension might need finalization, and all overriding functions + -- must have the same calling conventions. However, if there is a + -- pragma Restrictions (No_Finalization), we never need this parameter. + + return (Needs_Finalization (Result_Subt) + or else Is_Tagged_Type (Underlying_Type (Result_Subt))) + and then not Restriction_Active (No_Finalization); + end Needs_BIP_Final_List; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 79836a0e2bf..c470ee329ab 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -65,7 +65,7 @@ package Exp_Ch6 is -- caller or callee, and if the callee, whether to use the secondary -- stack or the heap. See Create_Extra_Formals. BIP_Final_List, - -- Present if result type has controlled parts. Pointer to caller's + -- Present if result type needs finalization. Pointer to caller's -- finalization list. BIP_Master, -- Present if result type contains tasks. Master associated with @@ -161,4 +161,9 @@ package Exp_Ch6 is -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression -- node applied to such a function call. + function Needs_BIP_Final_List (E : Entity_Id) return Boolean; + -- ???pragma Precondition (Is_Build_In_Place_Function (E)); + -- Ada 2005 (AI-318-02): Returns True if the function needs the + -- BIP_Final_List implicit parameter. + end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0140c7677f7..1d7cb78f77a 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -846,82 +846,14 @@ package body Exp_Ch7 is end if; end Check_Visibly_Controlled; - --------------------- - -- Controlled_Type -- - --------------------- - - function Controlled_Type (T : Entity_Id) return Boolean is - - function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; - -- If type is not frozen yet, check explicitly among its components, - -- because flag is not necessarily set. - - ----------------------------------- - -- Has_Some_Controlled_Component -- - ----------------------------------- - - function Has_Some_Controlled_Component - (Rec : Entity_Id) return Boolean - is - Comp : Entity_Id; - - begin - if Has_Controlled_Component (Rec) then - return True; - - elsif not Is_Frozen (Rec) then - if Is_Record_Type (Rec) then - Comp := First_Entity (Rec); - - while Present (Comp) loop - if not Is_Type (Comp) - and then Controlled_Type (Etype (Comp)) - then - return True; - end if; - - Next_Entity (Comp); - end loop; - - return False; - - elsif Is_Array_Type (Rec) then - return Is_Controlled (Component_Type (Rec)); - - else - return Has_Controlled_Component (Rec); - end if; - else - return False; - end if; - end Has_Some_Controlled_Component; - - -- Start of processing for Controlled_Type - - begin - -- Class-wide types must be treated as controlled because they may - -- contain an extension that has controlled components - - -- We can skip this if finalization is not available - - return (Is_Class_Wide_Type (T) - and then not In_Finalization_Root (T) - and then not Restriction_Active (No_Finalization)) - or else Is_Controlled (T) - or else Has_Some_Controlled_Component (T) - or else (Is_Concurrent_Type (T) - and then Present (Corresponding_Record_Type (T)) - and then Controlled_Type (Corresponding_Record_Type (T))); - end Controlled_Type; - - --------------------------- - -- CW_Or_Controlled_Type -- - --------------------------- + ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- - function CW_Or_Controlled_Type (T : Entity_Id) return Boolean is + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is begin - return Is_Class_Wide_Type (T) or else Controlled_Type (T); - end CW_Or_Controlled_Type; + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; -------------------------- -- Controller_Component -- @@ -1296,8 +1228,8 @@ package body Exp_Ch7 is if Is_Task_Allocation then Chain := Activation_Chain_Entity (N); - Decl := First (Declarations (N)); + Decl := First (Declarations (N)); while Nkind (Decl) /= N_Object_Declaration or else Defining_Identifier (Decl) /= Chain loop @@ -2038,7 +1970,7 @@ package body Exp_Ch7 is null; elsif Scope (Original_Record_Component (Comp)) = E - and then Controlled_Type (Etype (Comp)) + and then Needs_Finalization (Etype (Comp)) then return True; end if; @@ -3186,10 +3118,10 @@ package body Exp_Ch7 is and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then - declare S : Entity_Id; K : Entity_Kind; + begin S := Scope (Current_Scope); loop @@ -3273,6 +3205,74 @@ package body Exp_Ch7 is end Make_Transient_Block; ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Entity_Id) return Boolean is + + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because the Has_Controlled_Component flag is not necessarily set. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Rec : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Needs_Finalization (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Needs_Finalization (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + -- Class-wide types must be treated as controlled because they may + -- contain an extension that has controlled components + + -- We can skip this if finalization is not available + + return (Is_Class_Wide_Type (T) + and then not In_Finalization_Root (T) + and then not Restriction_Active (No_Finalization)) + or else Is_Controlled (T) + or else Has_Some_Controlled_Component (T) + or else (Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Needs_Finalization (Corresponding_Record_Type (T))); + end Needs_Finalization; + + ------------------------ -- Node_To_Be_Wrapped -- ------------------------ @@ -3429,7 +3429,7 @@ package body Exp_Ch7 is -- and the actual should be finalized on return from the call ??? if Nkind (N) = N_Object_Renaming_Declaration - and then Controlled_Type (Etype (Defining_Identifier (N))) + and then Needs_Finalization (Etype (Defining_Identifier (N))) then null; @@ -3439,7 +3439,7 @@ package body Exp_Ch7 is N_Selected_Component, N_Indexed_Component) and then - Controlled_Type + Needs_Finalization (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) then null; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index a9b9c4e06ca..b6c3ff26c24 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -57,14 +57,17 @@ package Exp_Ch7 is function Controller_Component (Typ : Entity_Id) return Entity_Id; -- Returns the entity of the component whose name is 'Name_uController' - function Controlled_Type (T : Entity_Id) return Boolean; - -- True if T potentially needs finalization actions + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; + -- True if T is a class-wide type, or if it has controlled parts ("part" + -- means T or any of its subcomponents). This is the same as + -- Needs_Finalization, except when pragma Restrictions (No_Finalization) + -- applies, in which case we know that class-wide objects do not contain + -- controlled parts. - function CW_Or_Controlled_Type (T : Entity_Id) return Boolean; - -- True if T is either a potentially controlled type or a class-wide type. - -- Note that in normal mode, class-wide types are potentially controlled so - -- this function is different from Controlled_Type only under restrictions - -- No_Finalization. + procedure Expand_Ctrl_Function_Call (N : Node_Id); + -- Expand a call to a function returning a controlled value. That is to + -- say attach the result of the call to the current finalization list, + -- which is the one of the transient scope created for such constructs. function Find_Final_List (E : Entity_Id; @@ -158,15 +161,17 @@ package Exp_Ch7 is -- object but not when finalizing the target of an assignment, it is not -- necessary either on scope exit. - procedure Expand_Ctrl_Function_Call (N : Node_Id); - -- Expand a call to a function returning a controlled value. That is to - -- say attach the result of the call to the current finalization list, - -- which is the one of the transient scope created for such constructs. - function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; -- Generate an implicit exception handler with an 'others' choice, -- converting any occurrence to a raise of Program_Error. + function Needs_Finalization (T : Entity_Id) return Boolean; + -- True if T potentially needs finalization actions. True if T is + -- controlled, or has subcomponents. Also True if T is a class-wide type, + -- because some type extension might add controlled subcomponents, except + -- that if pragma Restrictions (No_Finalization) applies, this is False for + -- class-wide types. + -------------------------------------------- -- Task and Protected Object finalization -- -------------------------------------------- diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 2f8b3223368..1552c77a7aa 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 591150101fc..3d1f776f8b3 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -812,9 +812,6 @@ package body Exp_Disp is -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 if Is_Access_Type (Operand_Typ) then - pragma Assert - (Is_Interface (Directly_Designated_Type (Operand_Typ))); - Rewrite (N, Unchecked_Convert_To (Etype (N), Make_Function_Call (Loc, @@ -6016,9 +6013,7 @@ package body Exp_Disp is begin -- The scope must be a package - if Ekind (Scop) /= E_Package - and then Ekind (Scop) /= E_Generic_Package - then + if not Is_Package_Or_Generic_Package (Scop) then return False; end if; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 38693f13b6a..da7210b7b12 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -8452,7 +8452,7 @@ package body Exp_Dist is -- Special DSA types - elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then Lib_RE := RE_FA_A; -- Other (non-primitive) types @@ -9317,11 +9317,14 @@ package body Exp_Dist is -- Special DSA types - elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then Lib_RE := RE_TA_A; + U_Type := Typ; elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then + -- No corresponding FA_TC ??? + Lib_RE := RE_TA_TC; -- Other (non-primitive) types @@ -10086,7 +10089,7 @@ package body Exp_Dist is -- Special DSA types - elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then Lib_RE := RE_TC_A; -- Other (non-primitive) types diff --git a/gcc/ada/exp_fixd.ads b/gcc/ada/exp_fixd.ads index 52f54019c9a..8c6780d9721 100644 --- a/gcc/ada/exp_fixd.ads +++ b/gcc/ada/exp_fixd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 0ecdad2e243..c04fb0f3a49 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index a33bf0472a2..d3f9334a607 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -815,7 +815,7 @@ package body Exp_Intr is -- Processing for pointer to controlled type - if Controlled_Type (Desig_T) then + if Needs_Finalization (Desig_T) then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 690ec21373b..0c2e815e2ff 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 6f34cae3c4c..d0b1b7f43a5 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -521,7 +521,7 @@ package body Exp_Strm is elsif P_Size <= Standard_Long_Float_Size and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size - or else Rt_Type = Standard_Float) + or else Rt_Type = Standard_Long_Float) then Lib_RE := RE_I_LF; @@ -735,7 +735,7 @@ package body Exp_Strm is elsif P_Size <= Standard_Long_Float_Size and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size - or else Rt_Type = Standard_Float) + or else Rt_Type = Standard_Long_Float) then Lib_RE := RE_W_LF; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index f9b9e33374e..acddeb11abd 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -57,7 +57,12 @@ package body Exp_Tss is elsif Is_Concurrent_Type (Full_Type) and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) then - return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type))); + -- The initialization routine to be called is that of the base type + -- of the corresponding record type, which may itself be a subtype + -- and possibly an itype. + + return Init_Proc + (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type)))); else Proc := Init_Proc (Base_Type (Full_Type)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 09850f644d4..8e367e1d79d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4533,7 +4533,7 @@ package body Exp_Util is elsif Nkind (Exp) = N_Unchecked_Type_Conversion and then not Safe_Unchecked_Type_Conversion (Exp) then - if CW_Or_Controlled_Type (Exp_Type) then + if CW_Or_Has_Controlled_Part (Exp_Type) then -- Use a renaming to capture the expression, rather than create -- a controlled temporary. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5e069f4c7a4..f77e1e70960 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -134,8 +134,7 @@ package body Freeze is -- the designated type. Otherwise freezing the access type does not freeze -- the designated type. - procedure Generate_Prim_Op_References - (Typ : Entity_Id); + procedure Generate_Prim_Op_References (Typ : Entity_Id); -- For a tagged type, generate implicit references to its primitive -- operations, for source navigation. @@ -519,7 +518,7 @@ package body Freeze is -- the address expression must be a constant. if (No (Expression (Decl)) - and then not Controlled_Type (Typ) + and then not Needs_Finalization (Typ) and then (not Has_Non_Null_Base_Init_Proc (Typ) or else Is_Imported (E))) @@ -548,7 +547,7 @@ package body Freeze is end if; if not Error_Posted (Expr) - and then not Controlled_Type (Typ) + and then not Needs_Finalization (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); end if; @@ -1382,7 +1381,7 @@ package body Freeze is elsif Is_Access_Type (E) and then Comes_From_Source (E) and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type - and then Controlled_Type (Designated_Type (E)) + and then Needs_Finalization (Designated_Type (E)) and then No (Associated_Final_Chain (E)) then Build_Final_List (Parent (E), E); @@ -1796,18 +1795,21 @@ package body Freeze is & "(component is little-endian)?", CLC); end if; - -- Do not allow non-contiguous field + -- Do not allow non-contiguous field else Error_Msg_N - ("attempt to specify non-contiguous field" - & " not permitted", CLC); + ("attempt to specify non-contiguous field " + & "not permitted", CLC); Error_Msg_N - ("\(caused by non-standard Bit_Order " - & "specified)", CLC); + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); end if; - -- Case where field fits in one storage unit + -- Case where field fits in one storage unit else -- Give warning if suspicious component clause @@ -2602,13 +2604,13 @@ package body Freeze is -- Ada 2005 (AI-326): Check wrong use of tagged -- incomplete type - -- + -- type T is tagged; -- function F (X : Boolean) return T; -- ERROR - -- The type must be declared in the current scope - -- for the use to be legal, and the full view - -- must be available when the construct that mentions - -- it is frozen. + + -- The type must be declared in the current scope for the + -- use to be legal, and the full view must be available + -- when the construct that mentions it is frozen. elsif Ekind (Etype (E)) = E_Incomplete_Type and then Is_Tagged_Type (Etype (E)) @@ -2654,7 +2656,6 @@ package body Freeze is begin T := First_Entity (E); - while Present (T) loop if Is_Type (T) then Generate_Prim_Op_References (T); @@ -5207,16 +5208,14 @@ package body Freeze is -- Generate_Prim_Op_References -- --------------------------------- - procedure Generate_Prim_Op_References - (Typ : Entity_Id) - is + procedure Generate_Prim_Op_References (Typ : Entity_Id) is Base_T : Entity_Id; Prim : Elmt_Id; Prim_List : Elist_Id; Ent : Entity_Id; begin - -- Handle subtypes of synchronized types. + -- Handle subtypes of synchronized types if Ekind (Typ) = E_Protected_Subtype or else Ekind (Typ) = E_Task_Subtype diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 64a1327a9e7..04d42966de2 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-alleve.adb b/gcc/ada/g-alleve.adb index 33a8d49fbcc..636d96f1036 100644 --- a/gcc/ada/g-alleve.adb +++ b/gcc/ada/g-alleve.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Soft Binding Version) -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-altcon.adb b/gcc/ada/g-altcon.adb index d3698a1ac44..1ee6a875a4e 100644 --- a/gcc/ada/g-altcon.adb +++ b/gcc/ada/g-altcon.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-altive.ads b/gcc/ada/g-altive.ads index 3a0caa1976b..855dbfd2e20 100644 --- a/gcc/ada/g-altive.ads +++ b/gcc/ada/g-altive.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-alveop.ads b/gcc/ada/g-alveop.ads index fc5728a3aa9..0897942ced7 100644 --- a/gcc/ada/g-alveop.ads +++ b/gcc/ada/g-alveop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-alvevi.ads b/gcc/ada/g-alvevi.ads index 32f43838cbb..9eb831d37a8 100644 --- a/gcc/ada/g-alvevi.ads +++ b/gcc/ada/g-alvevi.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb index 879aaac241c..0b72a59323a 100644 --- a/gcc/ada/g-arrspl.adb +++ b/gcc/ada/g-arrspl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-busorg.ads b/gcc/ada/g-busorg.ads index b7d4545c6d9..05566807cb9 100644 --- a/gcc/ada/g-busorg.ads +++ b/gcc/ada/g-busorg.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2006, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-calend.adb b/gcc/ada/g-calend.adb index 41fcd242059..9d3c33d3d35 100644 --- a/gcc/ada/g-calend.adb +++ b/gcc/ada/g-calend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-calend.ads b/gcc/ada/g-calend.ads index 4216195b1e3..c980f8eee92 100644 --- a/gcc/ada/g-calend.ads +++ b/gcc/ada/g-calend.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-casuti.ads b/gcc/ada/g-casuti.ads index d880eeaceaa..b32036d6745 100644 --- a/gcc/ada/g-casuti.ads +++ b/gcc/ada/g-casuti.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb index f7b318edbe3..469d1c18a93 100644 --- a/gcc/ada/g-catiio.adb +++ b/gcc/ada/g-catiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -560,13 +560,12 @@ package body GNAT.Calendar.Time_IO is D : String (1 .. 21); D_Length : constant Natural := Date'Length; - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; procedure Extract_Date (Year : out Year_Number; @@ -770,9 +769,6 @@ package body GNAT.Calendar.Time_IO is -- Start of processing for Value begin - Split (Clock, Year, Month, Day, Hour, Minute, Second, Sub_Second); - Sub_Second := 0.0; - -- Length checks if D_Length /= 8 @@ -792,12 +788,19 @@ package body GNAT.Calendar.Time_IO is D (1 .. D_Length) := Date; - if D_Length /= 8 - or else D (3) /= ':' - then + if D_Length /= 8 or else D (3) /= ':' then Extract_Date (Year, Month, Day, Time_Start); Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); + else + declare + Discard : Second_Duration; + pragma Unreferenced (Discard); + begin + Split (Clock, Year, Month, Day, Hour, Minute, Second, + Sub_Second => Discard); + end; + Extract_Time (1, Hour, Minute, Second, Check_Space => False); end if; @@ -813,17 +816,14 @@ package body GNAT.Calendar.Time_IO is raise Constraint_Error; end if; - return Time_Of (Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Time_Of (Year, Month, Day, Hour, Minute, Second); end Value; -------------- -- Put_Time -- -------------- - procedure Put_Time - (Date : Ada.Calendar.Time; - Picture : Picture_String) - is + procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is begin Ada.Text_IO.Put (Image (Date, Picture)); end Put_Time; diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/g-catiio.ads index 34a38878c9f..1f73c2198ec 100644 --- a/gcc/ada/g-catiio.ads +++ b/gcc/ada/g-catiio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -132,7 +132,7 @@ package GNAT.Calendar.Time_IO is -- -- Trailing characters (in particular spaces) are not allowed -- - -- yyyy*mm*dd + -- yyyy*mm*dd - ISO format -- yy*mm*dd - Year is assumed to be 20yy -- mm*dd*yyyy - (US date format) -- dd*mmm*yyyy - month spelled out @@ -141,12 +141,11 @@ package GNAT.Calendar.Time_IO is -- mmm dd, yyyy - month spelled out -- dd mmm yyyy - month spelled out -- - -- Constraint_Error is raised if the input string is malformatted or + -- Constraint_Error is raised if the input string is malformed (does not + -- conform to one of the above dates, or has an invalid time string), or -- the resulting time is not valid. - procedure Put_Time - (Date : Ada.Calendar.Time; - Picture : Picture_String); + procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String); -- Put Date with format Picture. Raise Picture_Error if bad picture string private diff --git a/gcc/ada/g-cgideb.adb b/gcc/ada/g-cgideb.adb index de20de30e55..863599b16be 100644 --- a/gcc/ada/g-cgideb.adb +++ b/gcc/ada/g-cgideb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2007, AdaCore -- +-- Copyright (C) 2000-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 11ed78a3476..b5a82d5dc9c 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -106,16 +106,18 @@ package body GNAT.Command_Line is procedure Remove (Line : in out Argument_List_Access; Index : Integer); -- Remove a specific element from Line - procedure Append - (Line : in out Argument_List_Access; - Str : String_Access); - -- Append a new element to Line + procedure Add + (Line : in out Argument_List_Access; + Str : String_Access; + Before : Boolean := False); + -- Add a new element to Line. If Before is True, the item is inserted at + -- the beginning, else it is appended. function Can_Have_Parameter (S : String) return Boolean; - -- Tell if S can have a parameter. + -- True when S can have a parameter function Require_Parameter (S : String) return Boolean; - -- Tell if S requires a paramter. + -- True when S requires a parameter function Actual_Switch (S : String) return String; -- Remove any possible trailing '!', ':', '?' and '=' @@ -125,7 +127,7 @@ package body GNAT.Command_Line is procedure For_Each_Simple_Switch (Cmd : Command_Line; Switch : String; - Parameter : String := ""; + Parameter : String := ""; Unalias : Boolean := True); -- Breaks Switch into as simple switches as possible (expanding aliases and -- ungrouping common prefixes when possible), and call Callback for each of @@ -143,14 +145,14 @@ package body GNAT.Command_Line is Result : Argument_List_Access; Sections : Argument_List_Access; Params : Argument_List_Access); - -- Group switches with common prefixes whenever possible. - -- Once they have been grouped, we also check items for possible aliasing + -- Group switches with common prefixes whenever possible. Once they have + -- been grouped, we also check items for possible aliasing. procedure Alias_Switches (Cmd : Command_Line; Result : Argument_List_Access; Params : Argument_List_Access); - -- When possible, replace or more switches by an alias, i.e. a shorter + -- When possible, replace one or more switches by an alias, i.e. a shorter -- version. function Looking_At @@ -1080,8 +1082,8 @@ package body GNAT.Command_Line is Config := new Command_Line_Configuration_Record; end if; - Append (Config.Aliases, new String'(Switch)); - Append (Config.Expansions, new String'(Expanded)); + Add (Config.Aliases, new String'(Switch)); + Add (Config.Expansions, new String'(Expanded)); end Define_Alias; ------------------- @@ -1097,7 +1099,7 @@ package body GNAT.Command_Line is Config := new Command_Line_Configuration_Record; end if; - Append (Config.Prefixes, new String'(Prefix)); + Add (Config.Prefixes, new String'(Prefix)); end Define_Prefix; ------------------- @@ -1113,7 +1115,7 @@ package body GNAT.Command_Line is Config := new Command_Line_Configuration_Record; end if; - Append (Config.Switches, new String'(Switch)); + Add (Config.Switches, new String'(Switch)); end Define_Switch; -------------------- @@ -1129,7 +1131,7 @@ package body GNAT.Command_Line is Config := new Command_Line_Configuration_Record; end if; - Append (Config.Sections, new String'(Section)); + Add (Config.Sections, new String'(Section)); end Define_Section; ------------------ @@ -1262,14 +1264,14 @@ package body GNAT.Command_Line is if not Is_Section then if Section = null then - -- Workaround some weird cases: some switches may + -- Work around some weird cases: some switches may -- expect parameters, but have the same value as -- longer switches: -gnaty3 (-gnaty, parameter=3) and -- -gnatya (-gnatya, no parameter). -- So we are calling add_switch here with parameter -- attached. This will be anyway correctly handled by - -- Add_Switch if -gnaty3 is actually furnished. + -- Add_Switch if -gnaty3 is actually provided. if Separator (Parser) = ASCII.NUL then Add_Switch @@ -1564,6 +1566,52 @@ package body GNAT.Command_Line is end loop; end if; + -- Test if added switch is a known switch with parameter attached + + if Parameter = "" + and then Cmd.Config /= null + and then Cmd.Config.Switches /= null + then + for S in Cmd.Config.Switches'Range loop + declare + Sw : constant String := + Actual_Switch (Cmd.Config.Switches (S).all); + Last : Natural; + Param : Natural; + + begin + -- Verify that switch starts with Sw + -- What if the "verification" fails??? + + if Switch'Length >= Sw'Length + and then Looking_At (Switch, Switch'First, Sw) + then + Param := Switch'First + Sw'Length - 1; + Last := Param; + + if Can_Have_Parameter (Cmd.Config.Switches (S).all) then + while Last < Switch'Last + and then Switch (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + end if; + + -- If full Switch is a known switch with attached parameter + -- then we use this parameter in the callback. + + if Last = Switch'Last then + Callback + (Switch (Switch'First .. Param), + Switch (Param + 1 .. Last)); + return; + + end if; + end if; + end; + end loop; + end if; + Callback (Switch, Parameter); end For_Each_Simple_Switch; @@ -1572,16 +1620,18 @@ package body GNAT.Command_Line is ---------------- procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ' '; - Section : String := "") + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + Section : String := ""; + Add_Before : Boolean := False) is Success : Boolean; pragma Unreferenced (Success); begin - Add_Switch (Cmd, Switch, Parameter, Separator, Section, Success); + Add_Switch + (Cmd, Switch, Parameter, Separator, Section, Add_Before, Success); end Add_Switch; ---------------- @@ -1589,16 +1639,17 @@ package body GNAT.Command_Line is ---------------- procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ' '; - Section : String := ""; - Success : out Boolean) + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + Section : String := ""; + Add_Before : Boolean := False; + Success : out Boolean) is procedure Add_Simple_Switch (Simple : String; Param : String); -- Add a new switch that has had all its aliases expanded, and switches - -- ungrouped. We know there is no more aliases in Switches + -- ungrouped. We know there are no more aliases in Switches. ----------------------- -- Add_Simple_Switch -- @@ -1626,40 +1677,53 @@ package body GNAT.Command_Line is end if; else - -- Do we already have this switch ? + -- Do we already have this switch? for C in Cmd.Expanded'Range loop if Cmd.Expanded (C).all = Simple and then ((Cmd.Params (C) = null and then Param = "") - or else - (Cmd.Params (C) /= null - and then Cmd.Params (C).all = Separator & Param)) + or else + (Cmd.Params (C) /= null + and then Cmd.Params (C).all = Separator & Param)) and then ((Cmd.Sections (C) = null and then Section = "") - or else - (Cmd.Sections (C) /= null - and then Cmd.Sections (C).all = Section)) + or else + (Cmd.Sections (C) /= null + and then Cmd.Sections (C).all = Section)) then return; end if; end loop; -- Inserting at least one switch + Success := True; - Append (Cmd.Expanded, new String'(Simple)); + Add (Cmd.Expanded, new String'(Simple), Add_Before); if Param /= "" then - Append (Cmd.Params, new String'(Separator & Param)); + Add + (Cmd.Params, + new String'(Separator & Param), + Add_Before); else - Append (Cmd.Params, null); + Add + (Cmd.Params, + null, + Add_Before); end if; if Section = "" then - Append (Cmd.Sections, null); + Add + (Cmd.Sections, + null, + Add_Before); else - Append (Cmd.Sections, new String'(Section)); + Add + (Cmd.Sections, + new String'(Section), + Add_Before); end if; end if; end Add_Simple_Switch; @@ -1698,26 +1762,35 @@ package body GNAT.Command_Line is Unchecked_Free (Tmp); end Remove; - ------------ - -- Append -- - ------------ + --------- + -- Add -- + --------- - procedure Append - (Line : in out Argument_List_Access; - Str : String_Access) + procedure Add + (Line : in out Argument_List_Access; + Str : String_Access; + Before : Boolean := False) is Tmp : Argument_List_Access := Line; + begin if Tmp /= null then Line := new Argument_List (Tmp'First .. Tmp'Last + 1); - Line (Tmp'Range) := Tmp.all; + + if Before then + Line (Tmp'First) := Str; + Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all; + else + Line (Tmp'Range) := Tmp.all; + Line (Tmp'Last + 1) := Str; + end if; + Unchecked_Free (Tmp); + else - Line := new Argument_List (1 .. 1); + Line := new Argument_List'(1 .. 1 => Str); end if; - - Line (Line'Last) := Str; - end Append; + end Add; ------------------- -- Remove_Switch -- @@ -1766,10 +1839,10 @@ package body GNAT.Command_Line is if Cmd.Expanded (C).all = Simple and then (Remove_All - or else (Cmd.Sections (C) = null - and then Section = "") - or else (Cmd.Sections (C) /= null - and then Section = Cmd.Sections (C).all)) + or else (Cmd.Sections (C) = null + and then Section = "") + or else (Cmd.Sections (C) /= null + and then Section = Cmd.Sections (C).all)) and then (not Has_Parameter or else Cmd.Params (C) /= null) then Remove (Cmd.Expanded, C); @@ -1789,7 +1862,7 @@ package body GNAT.Command_Line is end Remove_Simple_Switch; procedure Remove_Simple_Switches is - new For_Each_Simple_Switch (Remove_Simple_Switch); + new For_Each_Simple_Switch (Remove_Simple_Switch); -- Start of processing for Remove_Switch @@ -1826,10 +1899,10 @@ package body GNAT.Command_Line is if Cmd.Expanded (C).all = Simple and then ((Cmd.Sections (C) = null - and then Section = "") + and then Section = "") or else (Cmd.Sections (C) /= null - and then Section = Cmd.Sections (C).all)) + and then Section = Cmd.Sections (C).all)) and then ((Cmd.Params (C) = null and then Param = "") or else @@ -1847,7 +1920,7 @@ package body GNAT.Command_Line is Remove (Cmd.Sections, C); -- The switch is necessarily unique by construction of - -- Add_Switch + -- Add_Switch. return; @@ -1879,7 +1952,7 @@ package body GNAT.Command_Line is Params : Argument_List_Access) is function Compatible_Parameter (Param : String_Access) return Boolean; - -- Tell if the parameter can be part of a group + -- True when the parameter can be part of a group -------------------------- -- Compatible_Parameter -- @@ -2126,7 +2199,7 @@ package body GNAT.Command_Line is end loop; if not Found then - Append (Sections_List, Sections (E)); + Add (Sections_List, Sections (E)); end if; end if; end loop; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 41cdfb8e36d..12a9888cbc7 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -576,11 +576,12 @@ package GNAT.Command_Line is -- This function can be used to reset Cmd by passing an empty string. procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ' '; - Section : String := ""); + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + Section : String := ""; + Add_Before : Boolean := False); -- Add a new switch to the command line, and combine/group it with existing -- switches if possible. Nothing is done if the switch already exists with -- the same parameter. @@ -608,14 +609,18 @@ package GNAT.Command_Line is -- the switch is correctly placed in the command line, and the section -- added if not already present. For example, to add the -g switch into the -- -cargs section, you need to call (Cmd, "-g", Section => "-cargs") + -- + -- Add_Before allows insertion of the switch at the begining of the command + -- line. procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ' '; - Section : String := ""; - Success : out Boolean); + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + Section : String := ""; + Add_Before : Boolean := False; + Success : out Boolean); -- Same as above, returning the status of -- the operation diff --git a/gcc/ada/g-comver.adb b/gcc/ada/g-comver.adb index 2a0d120d832..ae3bf3bf66c 100644 --- a/gcc/ada/g-comver.adb +++ b/gcc/ada/g-comver.adb @@ -53,15 +53,18 @@ package body GNAT.Compiler_Version is function Version return String is begin - -- Search for terminating right paren + -- Search for terminating right paren or NUL ending the string for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop if GNAT_Version (J) = ')' then return GNAT_Version (Ver_Prefix'Length + 1 .. J); end if; + if GNAT_Version (J) = Character'Val (0) then + return GNAT_Version (Ver_Prefix'Length + 1 .. J - 1); + end if; end loop; - -- This should not happen (no right paren found) + -- This should not happen (no right paren or NUL found) return GNAT_Version; end Version; diff --git a/gcc/ada/g-curexc.ads b/gcc/ada/g-curexc.ads index 0e62ea38f73..ac5b93a2ba4 100644 --- a/gcc/ada/g-curexc.ads +++ b/gcc/ada/g-curexc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2005, AdaCore -- +-- Copyright (C) 1996-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 14f11916f6c..8533ad91ea7 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads index ca386802e12..2b6b6addfb7 100644 --- a/gcc/ada/g-debpoo.ads +++ b/gcc/ada/g-debpoo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index d34635c62b2..f27336697ab 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, AdaCore -- +-- Copyright (C) 1998-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads index cbb933ae3d4..f679d10de99 100644 --- a/gcc/ada/g-dynhta.ads +++ b/gcc/ada/g-dynhta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 9ad92288b72..216ff5b5f1e 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2007, AdaCore -- +-- Copyright (C) 2000-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-encstr.ads b/gcc/ada/g-encstr.ads index 2f0381d5d7c..59321dc506e 100755 --- a/gcc/ada/g-encstr.ads +++ b/gcc/ada/g-encstr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007, AdaCore -- +-- Copyright (C) 2007-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-excact.ads b/gcc/ada/g-excact.ads index 46fa32c2b54..26651904db7 100644 --- a/gcc/ada/g-excact.ads +++ b/gcc/ada/g-excact.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-except.ads b/gcc/ada/g-except.ads index d8428b79265..dd89467a15e 100644 --- a/gcc/ada/g-except.ads +++ b/gcc/ada/g-except.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, AdaCore -- +-- Copyright (C) 2000-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads index 5ec6f99c8dc..168a25554fb 100644 --- a/gcc/ada/g-expect.ads +++ b/gcc/ada/g-expect.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, AdaCore -- +-- Copyright (C) 2000-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-heasor.adb b/gcc/ada/g-heasor.adb index d520ef19962..caa2dacc904 100644 --- a/gcc/ada/g-heasor.adb +++ b/gcc/ada/g-heasor.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-hesora.adb b/gcc/ada/g-hesora.adb index ed686186088..cb54558a6c7 100644 --- a/gcc/ada/g-hesora.adb +++ b/gcc/ada/g-hesora.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2007, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-hesorg.adb b/gcc/ada/g-hesorg.adb index d7870d62cf5..3bcc01c0b92 100644 --- a/gcc/ada/g-hesorg.adb +++ b/gcc/ada/g-hesorg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads index 6373fa28652..5f7a27ccb75 100644 --- a/gcc/ada/g-htable.ads +++ b/gcc/ada/g-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2007, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads index f404a616ea2..9dde8fb4538 100644 --- a/gcc/ada/g-locfil.ads +++ b/gcc/ada/g-locfil.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-md5.adb b/gcc/ada/g-md5.adb index c41dae7c8ab..6c1148804fd 100644 --- a/gcc/ada/g-md5.adb +++ b/gcc/ada/g-md5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 2002-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-md5.ads b/gcc/ada/g-md5.ads index 223159609af..cea8eb6a802 100644 --- a/gcc/ada/g-md5.ads +++ b/gcc/ada/g-md5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 2002-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-memdum.ads b/gcc/ada/g-memdum.ads index f3ebd1aadb2..36b13e7cc95 100644 --- a/gcc/ada/g-memdum.ads +++ b/gcc/ada/g-memdum.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2005, AdaCore -- +-- Copyright (C) 2003-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-moreex.ads b/gcc/ada/g-moreex.ads index 9e4e3e29fd9..7412b074f2a 100644 --- a/gcc/ada/g-moreex.ads +++ b/gcc/ada/g-moreex.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, AdaCore -- +-- Copyright (C) 2000-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index 91cff110336..efec74af1c2 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2007, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-regexp.adb b/gcc/ada/g-regexp.adb index 2ccac8dc79a..d0ca5d494a1 100644 --- a/gcc/ada/g-regexp.adb +++ b/gcc/ada/g-regexp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-regexp.ads b/gcc/ada/g-regexp.ads index 5f4ddf6c4a5..4300ebf40a7 100644 --- a/gcc/ada/g-regexp.ads +++ b/gcc/ada/g-regexp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2007, AdaCore -- +-- Copyright (C) 1998-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb index 658a3a6a7ed..92ab7c3a79e 100644 --- a/gcc/ada/g-regpat.adb +++ b/gcc/ada/g-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-regpat.ads b/gcc/ada/g-regpat.ads index 13c7771270a..2290df8a64d 100644 --- a/gcc/ada/g-regpat.ads +++ b/gcc/ada/g-regpat.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2007, AdaCore -- +-- Copyright (C) 1996-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 2f729bd0314..0906aecc8ec 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1281,6 +1281,7 @@ package body GNAT.Sockets is procedure Initialize (Process_Blocking_IO : Boolean) is Expected : constant Boolean := not SOSC.Thread_Blocking_IO; + begin if Process_Blocking_IO /= Expected then raise Socket_Error with diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index 8c048eef132..c853ce41eb5 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -488,6 +488,7 @@ package body GNAT.Sockets.Thin is (Errno : Integer) return C.Strings.chars_ptr is use GNAT.Sockets.SOSC; + begin case Errno is when EINTR => return Error_Messages (N_EINTR); diff --git a/gcc/ada/g-soliop-mingw.ads b/gcc/ada/g-soliop-mingw.ads index ba7faa4fed0..d28db1859bf 100644 --- a/gcc/ada/g-soliop-mingw.ads +++ b/gcc/ada/g-soliop-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-soliop-solaris.ads b/gcc/ada/g-soliop-solaris.ads index cd3c5a3e68d..43fd2730532 100644 --- a/gcc/ada/g-soliop-solaris.ads +++ b/gcc/ada/g-soliop-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-soliop.ads b/gcc/ada/g-soliop.ads index 60a3bd98f6d..4016ab11bb8 100644 --- a/gcc/ada/g-soliop.ads +++ b/gcc/ada/g-soliop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index b39f2e5f4fa..c5c07f105e2 100644 --- a/gcc/ada/g-spipat.adb +++ b/gcc/ada/g-spipat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, AdaCore -- +-- Copyright (C) 1998-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads index 8ce8b1620e1..0ea2d3a3e54 100644 --- a/gcc/ada/g-spipat.ads +++ b/gcc/ada/g-spipat.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2007, AdaCore -- +-- Copyright (C) 1997-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-stheme.adb b/gcc/ada/g-stheme.adb index 5222f448dcf..8d118d550a4 100644 --- a/gcc/ada/g-stheme.adb +++ b/gcc/ada/g-stheme.adb @@ -51,7 +51,8 @@ package body Host_Error_Messages is use Interfaces.C.Strings; function TCP (P : char_array_access; Nul_Check : Boolean := False) return chars_ptr - renames To_Chars_Ptr; + renames To_Chars_Ptr; + begin case H_Errno is when SOSC.HOST_NOT_FOUND => @@ -66,7 +67,7 @@ package body Host_Error_Messages is when SOSC.NO_DATA => return TCP (Messages.NO_DATA'Access); - when others => + when others => return TCP (Messages.Unknown_Error'Access); end case; diff --git a/gcc/ada/g-string.adb b/gcc/ada/g-string.adb index 86b02f5d1f4..51d097a5ad4 100644 --- a/gcc/ada/g-string.adb +++ b/gcc/ada/g-string.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb index cd73a4aba9b..60f373a4257 100644 --- a/gcc/ada/g-table.adb +++ b/gcc/ada/g-table.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, AdaCore -- +-- Copyright (C) 1998-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-tasloc.adb b/gcc/ada/g-tasloc.adb index 52bd0e9cfa8..92563ccf7d1 100644 --- a/gcc/ada/g-tasloc.adb +++ b/gcc/ada/g-tasloc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, AdaCore -- +-- Copyright (C) 1997-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads index 3c0e62c71c1..d9f3040548f 100644 --- a/gcc/ada/g-traceb.ads +++ b/gcc/ada/g-traceb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb index 1d1fd3d9095..917e47855fb 100644 --- a/gcc/ada/g-trasym.adb +++ b/gcc/ada/g-trasym.adb @@ -102,7 +102,7 @@ package body GNAT.Traceback.Symbolic is -- The symbolic translation of an empty set of addresses is the -- the empty string. - if Traceback'Length <= 0 then + if Traceback'Length = 0 then return ""; end if; diff --git a/gcc/ada/g-utf_32.adb b/gcc/ada/g-utf_32.adb index 76c0f0843de..9dcd280ab98 100644 --- a/gcc/ada/g-utf_32.adb +++ b/gcc/ada/g-utf_32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 40017100128..c0b417f68f9 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -933,9 +933,11 @@ OSCONS_EXTRACT=../../../$(DECC) -DNATIVE \ ./s-oscons-tmplt.exe > s-oscons-tmplt.s else -OSCONS_CPP=$(GCC_FOR_TARGET) $(CFLAGS_FOR_TARGET) -E -C \ +OSCONS_CC=`echo "$(GCC_FOR_TARGET)" \ + | sed -e 's^\./xgcc^../../../xgcc^' -e 's^-B./^-B../../../^'` +OSCONS_CPP=$(OSCONS_CC) $(CFLAGS_FOR_TARGET) -E -C \ -DTARGET=\"$(target)\" s-oscons-tmplt.c > s-oscons-tmplt.i -OSCONS_EXTRACT=$(GCC_FOR_TARGET) $(CFLAGS_FOR_TARGET) -S s-oscons-tmplt.i +OSCONS_EXTRACT=$(OSCONS_CC) $(CFLAGS_FOR_TARGET) -S s-oscons-tmplt.i endif ada/s-oscons.ads : ada/s-oscons-tmplt.c ada/gsocket.h ada/xoscons.adb ada/xutil.ads ada/xutil.adb diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index a136f96bcc8..65dd02e7834 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -1303,12 +1303,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } } - if (definition && DECL_SIZE (gnu_decl) + if (definition && DECL_SIZE_UNIT (gnu_decl) && get_block_jmpbuf_decl () - && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST - || (flag_stack_check && !STACK_CHECK_BUILTIN - && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl), - STACK_CHECK_MAX_VAR_SIZE)))) + && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST + || (flag_stack_check == GENERIC_STACK_CHECK + && compare_tree_int (DECL_SIZE_UNIT (gnu_decl), + STACK_CHECK_MAX_VAR_SIZE) > 0))) add_stmt_with_node (build_call_1_expr (update_setjmp_buf_decl, build_unary_op (ADDR_EXPR, NULL_TREE, diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 97ff3bd2269..a67476eae70 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -73,6 +73,19 @@ #define TARGET_ABI_OPEN_VMS 0 #endif +/* For efficient float-to-int rounding, it is necessary to know whether + floating-point arithmetic on may use wider intermediate results. + When FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume + floating-point arithmetic does not widen if double precision is emulated. */ + +#ifndef FP_ARITH_MAY_WIDEN +#if defined(HAVE_extendsfdf2) +#define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2 +#else +#define FP_ARITH_MAY_WIDEN 0 +#endif +#endif + extern char *__gnat_to_canonical_file_spec (char *); int max_gnat_nodes; @@ -2249,7 +2262,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) { gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy, gnu_name); - set_expr_location_from_node (gnu_temp, gnat_actual); + set_expr_location_from_node (gnu_temp, gnat_node); append_to_statement_list (gnu_temp, &gnu_after_list); } } @@ -2601,7 +2614,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_actual, gnu_result); - set_expr_location_from_node (gnu_result, gnat_actual); + set_expr_location_from_node (gnu_result, gnat_node); append_to_statement_list (gnu_result, &gnu_before_list); scalar_return_list = TREE_CHAIN (scalar_return_list); gnu_name_list = TREE_CHAIN (gnu_name_list); @@ -6308,12 +6321,11 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, /* The following calculations depend on proper rounding to even of each arithmetic operation. In order to prevent excess precision from spoiling this property, use the widest hardware - floating-point type. + floating-point type if FP_ARITH_MAY_WIDEN is true. */ - FIXME: For maximum efficiency, this should only be done for machines - and types where intermediates may have extra precision. */ + calc_type = (FP_ARITH_MAY_WIDEN ? longest_float_type_node + : gnu_in_basetype); - calc_type = longest_float_type_node; /* FIXME: Should not have padding in the first place */ if (TREE_CODE (calc_type) == RECORD_TYPE && TYPE_IS_PADDING_P (calc_type)) diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 0462426251f..5077e640121 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1920,11 +1920,11 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, /* ??? For now, disable variable-sized allocators in the stack since we can't yet gimplify an ALLOCATE_EXPR. */ else if (gnat_pool == -1 - && TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check) + && TREE_CODE (gnu_size) == INTEGER_CST + && flag_stack_check != GENERIC_STACK_CHECK) { /* If the size is a constant, we can put it in the fixed portion of the stack frame to avoid the need to adjust the stack pointer. */ - if (TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check) { tree gnu_range = build_range_type (NULL_TREE, size_one_node, gnu_size); @@ -1937,9 +1937,8 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, return convert (ptr_void_type_node, build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl)); } - else - gcc_unreachable (); #if 0 + else return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align); #endif } diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 5918edda65b..204192c1223 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -20321,6 +20321,12 @@ a generic instantiation a full source location is a chain from the location of this construct in the generic unit to the place where this unit is instantiated. +@cindex @option{^-m^/DIAGNOSIS_LIMIT^} (@command{gnatcheck}) +@item ^-m@i{nnn}^/DIAGNOSIS_LIMIT=@i{nnn}^ +Maximum number of diagnoses to be sent to Stdout, @i{nnn} from o@dots{}1000, +the default value is 500. Zero means that there is no limitation on +the number of diagnostic messages to be printed into Stdout. + @cindex @option{^-q^/QUIET^} (@command{gnatcheck}) @item ^-q^/QUIET^ Quiet mode. All the diagnoses about rule violations are placed in the @@ -20396,12 +20402,7 @@ Read the rule options from the text file @var{rule_option_filename}, referred as @end table @noindent -The default behavior is that all the rule checks are enabled, except for -the checks performed by the compiler. -@ignore -and the checks associated with the -global rules. -@end ignore +The default behavior is that all the rule checks are disabled. A rule file is a text file containing a set of rule options. @cindex Rule file (for @code{gnatcheck}) @@ -21067,18 +21068,20 @@ This rule has no parameters. @cindex @code{Metrics} rule (for @command{gnatcheck}) @noindent -This is an umbrella rule for a set of metrics-based checks. Each metric-based -check has its own rule name that starts from the common prefix -@code{Metrics_}. For @option{+R} option, this name ends with @code{_GT} -(greater then) or @code{_LT} (less then). The parameter of the rule -@option{+R} option specifies bound (upper or lower, depending on the metric) -for the given metric. A construct is flagged if a specified metric can be -computed for it, and the resulting value is higher then the upper bound (or -less than the lower bound) specified. Parameters and metric names are not -case-sensitive @option{-R} option does not have a parameter and it turns OFF -the check for the metric indicated by the metric rule name. +There is a set of checks based on computing a metric value and comparing the +result with the specified upper (or lower, depending on a specific metric) +value specified for a given metric. A construct is flagged if a given metric +is applicable (can be computed) for it and the computed value is greater +then (lover then) the specified upper (lower) bound. -The following table shows the available metrics-based checks, including the +The name of any metric-based rule consists of the prefix @code{Metrics_} +followed by the name of the corresponding metric (see the table below). +For @option{+R} option, each metric-based rule has a numeric parameter +specifying the bound (integer or real, depending on a metric), @option{-R} +option for metric rules does not have a parameter. + +The following table shows the metric names for that the corresponding +metrics-based checks are supported by gnatcheck, including the constraint that must be satisfied by the bound that is specified for the check and what bound - upper (U) or lower (L) - should be specified. @@ -21101,7 +21104,7 @@ the same as for the corresponding metrics in @command{gnatmetric}. @emph{Example:} the rule @smallexample -+RMetrics_Cyclomatic_Complexity_GT : 7 ++RMetrics_Cyclomatic_Complexity : 7 @end smallexample @noindent means that all bodies with cyclomatic complexity exceeding 7 will be flagged. @@ -22536,6 +22539,9 @@ implemented in @code{gcov}: you can now list all your project's files into a text file, and provide this file to gcov as a parameter, preceded by a @@ (e.g. @samp{gcov @@mysrclist.txt}). +Note that on AIX compiling a static library with @code{-fprofile-arcs} is +not supported as there can be unresolved symbols during the final link. + @node Profiling an Ada Program using gprof @section Profiling an Ada Program using gprof @cindex gprof diff --git a/gcc/ada/gnatcmd.ads b/gcc/ada/gnatcmd.ads index d592256352a..6c2c8c7f50f 100644 --- a/gcc/ada/gnatcmd.ads +++ b/gcc/ada/gnatcmd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index 5592d528a2c..69415ef963e 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 530731330e0..4067c983949 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -36,15 +36,15 @@ package Gnatvsn is + Gnat_Static_Version_String : constant String := "GNU Ada"; + -- Static string identifying this version, that can be used as an argument + -- to e.g. pragma Ident. + function Gnat_Version_String return String; -- Version output when GNAT (compiler), or its related tools, including -- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run -- (with appropriate verbose option switch set). - Gnat_Static_Version_String : constant String := "GNU Ada"; - -- Static string identifying this version, that can be used as an argument - -- to e.g. pragma Ident. - type Gnat_Build_Type is (FSF, GPL); -- See Build_Type below for the meaning of these values. diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index b2225ff458c..2cccc0f1f51 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/i-cstrea-vms.adb b/gcc/ada/i-cstrea-vms.adb index cc1083d8a52..58d6c26e135 100644 --- a/gcc/ada/i-cstrea-vms.adb +++ b/gcc/ada/i-cstrea-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/i-pacdec.ads b/gcc/ada/i-pacdec.ads index 240c0672964..4b9485b1b76 100644 --- a/gcc/ada/i-pacdec.ads +++ b/gcc/ada/i-pacdec.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Version for IBM Mainframe Packed Decimal Format) -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/init.c b/gcc/ada/init.c index d2c22ea49d3..c4e260104ad 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -217,22 +217,6 @@ nanosleep (struct timestruc_t *Rqtp, struct timestruc_t *Rmtp) static void __gnat_error_handler (int sig, siginfo_t * si, void * uc); -/* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - -void -__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) -{ - /* We need to adjust the "Instruction Address Register" value, part of a - 'struct mstsave' wrapped as a jumpbuf in the mcontext field designated by - the signal data pointer we get. See sys/context.h + sys/mstsave.h */ - - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - mcontext->jmp_context.iar++; -} - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - static void __gnat_error_handler (int sig, siginfo_t * si, void * uc) { @@ -262,7 +246,6 @@ __gnat_error_handler (int sig, siginfo_t * si, void * uc) msg = "unhandled signal"; } - __gnat_adjust_context_for_raise (sig, uc); Raise_From_Signal_Handler (exception, msg); } @@ -464,26 +447,6 @@ __gnat_machine_state_length (void) static void __gnat_error_handler (int sig, siginfo_t *siginfo, void *ucontext); -#if defined (__hppa__) - -/* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - -void -__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) -{ - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - - if (UseWideRegs (mcontext)) - mcontext->ss_wide.ss_32.ss_pcoq_head_lo ++; - else - mcontext->ss_narrow.ss_pcoq_head ++; -} - -#endif - static void __gnat_error_handler (int sig, siginfo_t *siginfo ATTRIBUTE_UNUSED, void *ucontext) @@ -514,8 +477,6 @@ __gnat_error_handler msg = "unhandled signal"; } - __gnat_adjust_context_for_raise (sig, ucontext); - Raise_From_Signal_Handler (exception, msg); } @@ -617,17 +578,14 @@ void fake_linux_sigemptyset (sigset_t *set) { static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext); -/* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ +#if defined (i386) || defined (__x86_64__) || defined (__ia64__) #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE void __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) { -#ifndef __powerpc__ mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; -#endif /* On the i386 and x86-64 architectures, stack checking is performed by means of probes with moving stack pointer, that is to say the probed @@ -651,20 +609,19 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */ if (signo == SIGSEGV && pattern == 0x00240c83) mcontext->gregs[REG_ESP] += 4096; - mcontext->gregs[REG_EIP]++; #elif defined (__x86_64__) unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_RIP]; /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */ if (signo == SIGSEGV && (pattern & 0xffffffffff) == 0x00240c8348) mcontext->gregs[REG_RSP] += 4096; - mcontext->gregs[REG_RIP]++; #elif defined (__ia64__) + /* ??? The IA-64 unwinder doesn't compensate for signals. */ mcontext->sc_ip++; -#elif defined (__powerpc__) - ((ucontext_t *) ucontext)->uc_mcontext.regs->nip++; #endif } +#endif + static void __gnat_error_handler (int sig, siginfo_t *siginfo ATTRIBUTE_UNUSED, @@ -731,11 +688,10 @@ __gnat_error_handler (int sig, } recurse = 0; - /* We adjust the interrupted context here (and not in the - MD_FALLBACK_FRAME_STATE_FOR macro) because recent versions of the Native - POSIX Thread Library (NPTL) are compiled with DWARF-2 unwind information, - and hence the later macro is never executed for signal frames. */ - + /* We adjust the interrupted context here (and not in the fallback + unwinding routine) because recent versions of the Native POSIX + Thread Library (NPTL) are compiled with unwind information, so + the fallback routine is never executed for signal frames. */ __gnat_adjust_context_for_raise (sig, ucontext); Raise_From_Signal_Handler (exception, msg); @@ -1052,19 +1008,6 @@ __gnat_install_handler(void) static void __gnat_error_handler (int, siginfo_t *, ucontext_t *); -/* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - -void -__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, - void * ucontext) -{ - mcontext_t *mcontext = & ((ucontext_t *)ucontext)->uc_mcontext; - mcontext->gregs[REG_PC] += (1 - RETURN_ADDR_OFFSET); -} - static void __gnat_error_handler (int sig, siginfo_t *sip, ucontext_t *uctx) { @@ -1072,10 +1015,6 @@ __gnat_error_handler (int sig, siginfo_t *sip, ucontext_t *uctx) static int recurse = 0; const char *msg; - /* Adjusting is required for every fault context, so adjust for this one - now, before we possibly trigger a recursive fault below. */ - __gnat_adjust_context_for_raise (sig, (void *)uctx); - /* If this was an explicit signal from a "kill", just resignal it. */ if (SI_FROMUSER (sip)) { @@ -1167,6 +1106,10 @@ __gnat_install_handler (void) #elif defined (VMS) +/* Routine called from binder to override default feature values. */ +void __gnat_set_features (); +int __gnat_features_set = 0; + long __gnat_error_handler (int *, void *); #ifdef __IA64 @@ -1680,6 +1623,54 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) #endif +/* Feature logical name and global variable address pair */ +struct feature {char *name; int* gl_addr;}; + +/* Default values for GNAT features set by environment. */ +int __gl_no_malloc_64 = 0; + +/* Array feature logical names and global variable addresses */ +static struct feature features[] = { + {"GNAT$NO_MALLOC_64", &__gl_no_malloc_64}, + {0, 0} +}; + +void __gnat_set_features () +{ + struct descriptor_s name_desc, result_desc; + int i, status; + unsigned short rlen; + +#define MAXEQUIV 10 + char buff [MAXEQUIV]; + + /* Loop through features array and test name for enable/disable */ + for (i=0; features [i].name; i++) + { + name_desc.len = strlen (features [i].name); + name_desc.mbz = 0; + name_desc.adr = features [i].name; + + result_desc.len = MAXEQUIV - 1; + result_desc.mbz = 0; + result_desc.adr = buff; + + status = LIB$GET_LOGICAL (&name_desc, &result_desc, &rlen); + + if (((status & 1) == 1) && (rlen < MAXEQUIV)) + buff [rlen] = 0; + else + strcpy (buff, ""); + + if (strcmp (buff, "ENABLE") == 0) + *features [i].gl_addr = 1; + else if (strcmp (buff, "DISABLE") == 0) + *features [i].gl_addr = 0; + } + + __gnat_features_set = 1; +} + /*******************/ /* FreeBSD Section */ /*******************/ @@ -1691,19 +1682,6 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) #include <unistd.h> static void __gnat_error_handler (int, siginfo_t *, ucontext_t *); -void __gnat_adjust_context_for_raise (int, void*); - -/* __gnat_adjust_context_for_raise - see comments along with the default - version later in this file. */ - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - -void -__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) -{ - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - mcontext->mc_eip++; -} static void __gnat_error_handler (int sig, siginfo_t *info __attribute__ ((unused)), @@ -1739,7 +1717,6 @@ __gnat_error_handler (int sig, siginfo_t *info __attribute__ ((unused)), msg = "unhandled signal"; } - __gnat_adjust_context_for_raise (sig, ucontext); Raise_From_Signal_Handler (exception, msg); } @@ -1825,34 +1802,6 @@ __gnat_clear_exception_count (void) #endif } - -/* VxWorks context adjustment for targets that need/support it. */ - -void __gnat_adjust_context_for_raise (int, void*); - -#if defined (_ARCH_PPC) && !defined (VTHREADS) && !defined (__RTP__) - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - -/* We need the constant and structure definitions describing the machine - state. Part of this is normally retrieved from the VxWorks "regs.h" but - #including it here gets the GCC internals instance of this file instead. - We need to #include the version we need directly here, and prevent the - possibly indirect inclusion of the GCC one, as its contents is useless to - us and it depends on several other headers that we don't have at hand. */ -#include <arch/ppc/regsPpc.h> -#define GCC_REGS_H -#include <sigLib.h> - -void -__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *sigcontext) -{ - REG_SET * mcontext = ((struct sigcontext *) sigcontext)->sc_pregs; - mcontext->pc++; -} - -#endif - /* Handle different SIGnal to exception mappings in different VxWorks versions. */ static void @@ -1935,7 +1884,6 @@ __gnat_error_handler (int sig, void * si ATTRIBUTE_UNUSED, sigdelset (&mask, sig); sigprocmask (SIG_SETMASK, &mask, NULL); - __gnat_adjust_context_for_raise (sig, (void *)sc); __gnat_map_signal (sig); } @@ -2206,12 +2154,11 @@ void __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext ATTRIBUTE_UNUSED) { - /* Adjustments are currently required for the GCC ZCX propagation scheme - only. These adjustments (described below) are harmless for the other - schemes, so may be applied unconditionally. */ + /* We used to compensate here for the raised from call vs raised from signal + exception discrepancy with the GCC ZCX scheme, but this is now dealt with + generically (except for the Alpha and IA-64), see GCC PR other/26208. - /* Adjustments required for a GCC ZCX propagation scheme: - ------------------------------------------------------ + *** Call vs signal exception discrepancy with GCC ZCX scheme *** The GCC unwinder expects to be dealing with call return addresses, since this is the "nominal" case of what we retrieve while unwinding a regular @@ -2239,15 +2186,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, signo is passed because on some targets for some signals the PC in context points to the instruction after the faulting one, in which case - the unwinder adjustment is still desired. - - We used to perform the compensation in the GCC unwinding fallback macro. - The thread at http://gcc.gnu.org/ml/gcc-patches/2004-05/msg00343.html - describes a couple of issues with this approach. First, on some targets - the adjustment to apply depends on the triggering signal, which is not - easily accessible from the macro. Besides, other languages, e.g. Java, - deal with this by performing the adjustment in the signal handler before - the raise, so fallback adjustments just break those front-ends. */ + the unwinder adjustment is still desired. */ } #endif diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 999351a8d97..dd7ba06ade3 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -76,12 +76,6 @@ __gnat_initialize (void *eh) given that we have set Max_Digits etc with this in mind */ __gnat_init_float (); -#ifndef RTX - /* Initialize a lock for a process handle list - see adaint.c for the - implementation of __gnat_portable_no_block_spawn, __gnat_portable_wait */ - __gnat_plist_init(); -#endif - /* Note that we do not activate this for the compiler itself to avoid a bootstrap path problem. Older version of gnatbind will generate a call to __gnat_initialize() without argument. Therefore we cannot use eh in diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 0bb85492980..92334484d9b 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -188,7 +188,7 @@ package Lib.Xref is -- > = subprogram IN parameter -- = = subprogram IN OUT parameter -- < = subprogram OUT parameter - -- > = subprogram ACCESS parameter + -- ^ = subprogram ACCESS parameter -- b is used for spec entities that are repeated in a body, -- including the unit (subprogram, package, task, protected diff --git a/gcc/ada/link.c b/gcc/ada/link.c index 1ed24f80588..23e0e409539 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * diff --git a/gcc/ada/live.ads b/gcc/ada/live.ads index 4cc623771a7..016203d959d 100644 --- a/gcc/ada/live.ads +++ b/gcc/ada/live.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 1b5d7124e2b..c85e7ff13b2 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -27,6 +27,7 @@ with ALI; use ALI; with ALI.Util; use ALI.Util; with Csets; with Debug; +with Errutil; with Fmap; with Fname; use Fname; with Fname.SF; use Fname.SF; @@ -319,6 +320,15 @@ package body Make is Saved_Maximum_Processes : Natural := 0; + Gnatmake_Switch_Found : Boolean; + -- Set by Scan_Make_Arg. True when the switch is a gnatmake switch. + -- Tested by Add_Switches when switches in package Builder must all be + -- gnatmake switches. + + Switch_May_Be_Passed_To_The_Compiler : Boolean; + -- Set by Add_Switches and Switches_Of. True when unrecognized switches + -- are passed to the Ada compiler. + type Arg_List_Ref is access Argument_List; The_Saved_Gcc_Switches : Arg_List_Ref; @@ -719,10 +729,11 @@ package body Make is -- file, to avoid displaying the -gnatec switch for a temporary file. procedure Add_Switches - (The_Package : Package_Id; - File_Name : String; - Index : Int; - Program : Make_Program_Type); + (The_Package : Package_Id; + File_Name : String; + Index : Int; + Program : Make_Program_Type; + Unknown_Switches_To_The_Compiler : Boolean := True); procedure Add_Switch (S : String_Access; Program : Make_Program_Type; @@ -1237,64 +1248,40 @@ package body Make is ------------------ procedure Add_Switches - (The_Package : Package_Id; - File_Name : String; - Index : Int; - Program : Make_Program_Type) + (The_Package : Package_Id; + File_Name : String; + Index : Int; + Program : Make_Program_Type; + Unknown_Switches_To_The_Compiler : Boolean := True) is Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin + Switch_May_Be_Passed_To_The_Compiler := + Unknown_Switches_To_The_Compiler; + if File_Name'Length > 0 then Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Switches := Switches_Of - (Source_File => Name_Find, - Source_File_Name => File_Name, - Source_Index => Index, - Naming => Project_Tree.Projects.Table - (Main_Project).Naming, - In_Package => The_Package, - Allow_ALI => - Program = Binder or else Program = Linker); - - case Switches.Kind is - when Undefined => - null; - - when List => - Program_Args := Program; - - Switch_List := Switches.Values; - - while Switch_List /= Nil_String loop - Element := Project_Tree.String_Elements.Table (Switch_List); - Get_Name_String (Element.Value); - - if Name_Len > 0 then - declare - Argv : constant String := Name_Buffer (1 .. Name_Len); - -- We need a copy, because Name_Buffer may be modified - - begin - if Verbose_Mode then - Write_Str (" Adding "); - Write_Line (Argv); - end if; - - Scan_Make_Arg (Argv, And_Save => False); - end; - end if; - - Switch_List := Element.Next; - end loop; - - when Single => - Program_Args := Program; - Get_Name_String (Switches.Value); + (Source_File => Name_Find, + Source_File_Name => File_Name, + Source_Index => Index, + Naming => Project_Tree.Projects.Table + (Main_Project).Naming, + In_Package => The_Package, + Allow_ALI => Program = Binder or else Program = Linker); + + if Switches.Kind = List then + Program_Args := Program; + + Switch_List := Switches.Values; + while Switch_List /= Nil_String loop + Element := Project_Tree.String_Elements.Table (Switch_List); + Get_Name_String (Element.Value); if Name_Len > 0 then declare @@ -1308,9 +1295,25 @@ package body Make is end if; Scan_Make_Arg (Argv, And_Save => False); + + if not Gnatmake_Switch_Found + and then not Switch_May_Be_Passed_To_The_Compiler + then + Errutil.Error_Msg + ('"' & Argv & + """ is not a gnatmake switch. Consider moving " & + "it to Global_Compilation_Switches.", + Element.Location); + Errutil.Finalize; + Make_Failed + ("*** illegal switch """, Argv, """"); + end if; end; end if; - end case; + + Switch_List := Element.Next; + end loop; + end if; end if; end Add_Switches; @@ -1437,6 +1440,10 @@ package body Make is O_File : out File_Name_Type; O_Stamp : out Time_Stamp_Type) is + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean; + function First_New_Spec (A : ALI_Id) return File_Name_Type; -- Looks in the with table entries of A and returns the spec file name -- of the first withed unit (subprogram) for which no spec existed when @@ -1451,6 +1458,34 @@ package body Make is -- services, but this causes the whole compiler to be dragged along -- for gnatbind and gnatmake. + -------------------------- + -- File_Not_A_Source_Of -- + -------------------------- + + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean + is + UID : Prj.Unit_Index; + U_Data : Unit_Data; + + begin + UID := Units_Htable.Get (Project_Tree.Units_HT, Uname); + + if UID /= Prj.No_Unit_Index then + U_Data := Project_Tree.Units.Table (UID); + + if U_Data.File_Names (Body_Part).Name /= Sfile + and then U_Data.File_Names (Specification).Name /= Sfile + then + Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); + return True; + end if; + end if; + + return False; + end File_Not_A_Source_Of; + -------------------- -- First_New_Spec -- -------------------- @@ -1824,22 +1859,37 @@ package body Make is end if; end if; - elsif Main_Project /= No_Project then + elsif not Read_Only and then Main_Project /= No_Project then -- Check if a file name does not correspond to the mapping of -- units to file names. declare + SD : Sdep_Record; WR : With_Record; Unit_Name : Name_Id; - UID : Prj.Unit_Index; - U_Data : Unit_Data; begin U_Chk : for U in ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop + -- Check if the file name is one of the source of the + -- unit. + + Get_Name_String (Units.Table (U).Uname); + Name_Len := Name_Len - 2; + Unit_Name := Name_Find; + + if File_Not_A_Source_Of + (Unit_Name, Units.Table (U).Sfile) + then + ALI := No_ALI_Id; + return; + end if; + + -- Do the same check for each of the withed units. + W_Check : for W in Units.Table (U).First_With .. @@ -1852,29 +1902,30 @@ package body Make is Name_Len := Name_Len - 2; Unit_Name := Name_Find; - UID := Units_Htable.Get - (Project_Tree.Units_HT, Unit_Name); - - if UID /= Prj.No_Unit_Index then - U_Data := Project_Tree.Units.Table (UID); - - if U_Data.File_Names (Body_Part).Name /= WR.Sfile - and then - U_Data.File_Names (Specification).Name /= - WR.Sfile - then - ALI := No_ALI_Id; - - Verbose_Msg - (Unit_Name, " sources do not include ", - Name_Id (WR.Sfile)); - - return; - end if; + if File_Not_A_Source_Of (Unit_Name, WR.Sfile) then + ALI := No_ALI_Id; + return; end if; end if; end loop W_Check; end loop U_Chk; + + -- Check also the subunits + + D_Check : + for D in ALIs.Table (ALI).First_Sdep .. + ALIs.Table (ALI).Last_Sdep + loop + SD := Sdep.Table (D); + Unit_Name := SD.Subunit_Name; + + if Unit_Name /= No_Name then + if File_Not_A_Source_Of (Unit_Name, SD.Sfile) then + ALI := No_ALI_Id; + return; + end if; + end if; + end loop D_Check; end; -- Check that the ALI file is in the correct object directory. @@ -1928,8 +1979,9 @@ package body Make is Add_Str_To_Name_Buffer (Res_Obj_Dir); if Name_Len > 1 and then - (Name_Buffer (Name_Len) = '/' or else - Name_Buffer (Name_Len) = Directory_Separator) + (Name_Buffer (Name_Len) = '/' + or else + Name_Buffer (Name_Len) = Directory_Separator) then Name_Len := Name_Len - 1; end if; @@ -4878,7 +4930,7 @@ package body Make is if Verbose_Mode then Write_Eol; - Display_Version ("GNATMAKE ", "1995"); + Display_Version ("GNATMAKE", "1995"); end if; if Main_Project /= No_Project @@ -5038,6 +5090,12 @@ package body Make is In_Packages => The_Packages, In_Tree => Project_Tree); + Default_Switches_Array : Array_Id; + + Global_Compilation_Array : Array_Element_Id; + Global_Compilation_Elem : Array_Element; + Global_Compilation_Switches : Variable_Value; + begin -- We fail if we cannot find the main source file @@ -5083,6 +5141,37 @@ package body Make is if Builder_Package /= No_Package then + Global_Compilation_Array := Prj.Util.Value_Of + (Name => Name_Global_Compilation_Switches, + In_Arrays => Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays, + In_Tree => Project_Tree); + + Default_Switches_Array := + Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays; + + while Default_Switches_Array /= No_Array and then + Project_Tree.Arrays.Table (Default_Switches_Array).Name /= + Name_Default_Switches + loop + Default_Switches_Array := + Project_Tree.Arrays.Table (Default_Switches_Array).Next; + end loop; + + if Global_Compilation_Array /= No_Array_Element and then + Default_Switches_Array /= No_Array + then + Errutil.Error_Msg + ("Default_Switches forbidden in presence of " & + "Global_Compilation_Switches. Use Switches instead.", + Project_Tree.Arrays.Table + (Default_Switches_Array).Location); + Errutil.Finalize; + Make_Failed + ("*** illegal combination of Builder attributes"); + end if; + -- If there is only one main, we attempt to get the gnatmake -- switches for this main (if any). If there are no specific -- switch for this particular main, get the general gnatmake @@ -5096,10 +5185,12 @@ package body Make is end if; Add_Switches - (File_Name => Main_Unit_File_Name, - Index => Main_Index, - The_Package => Builder_Package, - Program => None); + (File_Name => Main_Unit_File_Name, + Index => Main_Index, + The_Package => Builder_Package, + Program => None, + Unknown_Switches_To_The_Compiler => + Global_Compilation_Array = No_Array_Element); else -- If there are several mains, we always get the general @@ -5149,10 +5240,11 @@ package body Make is end if; Add_Switches - (File_Name => " ", - Index => 0, - The_Package => Builder_Package, - Program => None); + (File_Name => " ", + Index => 0, + The_Package => Builder_Package, + Program => None, + Unknown_Switches_To_The_Compiler => False); elsif Defaults /= Nil_Variable_Value then if not Quiet_Output @@ -5178,6 +5270,59 @@ package body Make is end if; end; end if; + + -- Take into account attribute Global_Compilation_Switches + -- ("Ada"). + + declare + Index : Name_Id; + List : String_List_Id; + Elem : String_Element; + + begin + while Global_Compilation_Array /= No_Array_Element loop + Global_Compilation_Elem := + Project_Tree.Array_Elements.Table + (Global_Compilation_Array); + + Get_Name_String (Global_Compilation_Elem.Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Index := Name_Find; + + if Index = Name_Ada then + Global_Compilation_Switches := + Global_Compilation_Elem.Value; + + if Global_Compilation_Switches /= Nil_Variable_Value + and then not Global_Compilation_Switches.Default + then + -- We have found attribute + -- Global_Compilation_Switches ("Ada"): put the + -- switches in the appropriate table. + + List := Global_Compilation_Switches.Values; + + while List /= Nil_String loop + Elem := + Project_Tree.String_Elements.Table (List); + + if Elem.Value /= No_Name then + Add_Switch + (Get_Name_String (Elem.Value), + Compiler, + And_Save => False); + end if; + + List := Elem.Next; + end loop; + + exit; + end if; + end if; + + Global_Compilation_Array := Global_Compilation_Elem.Next; + end loop; + end; end if; Osint.Add_Default_Search_Dirs; @@ -7528,6 +7673,8 @@ package body Make is Success : Boolean; begin + Gnatmake_Switch_Found := True; + pragma Assert (Argv'First = 1); if Argv'Length = 0 then @@ -8068,14 +8215,14 @@ package body Make is Add_Switch (Argv, Compiler, And_Save => And_Save); Add_Switch (Argv, Binder, And_Save => And_Save); - -- All other switches are processed by Scan_Make_Switches. - -- If the call returns with Success = False, then the switch is - -- passed to the compiler. + -- All other switches are processed by Scan_Make_Switches. If the + -- call returns with Gnatmake_Switch_Found = False, then the switch + -- is passed to the compiler. else - Scan_Make_Switches (Argv, Success); + Scan_Make_Switches (Argv, Gnatmake_Switch_Found); - if not Success then + if not Gnatmake_Switch_Found then Add_Switch (Argv, Compiler, And_Save => And_Save); end if; end if; @@ -8119,6 +8266,8 @@ package body Make is In_Tree => Project_Tree); begin + -- First, try Switches (<file name>) + Switches := Prj.Util.Value_Of (Index => Name_Id (Source_File), @@ -8126,6 +8275,8 @@ package body Make is In_Array => Switches_Array, In_Tree => Project_Tree); + -- Check also without the suffix + if Switches = Nil_Variable_Value then declare Name : String (1 .. Source_File_Name'Length + 3); @@ -8189,6 +8340,24 @@ package body Make is end; end if; + -- Next, try Switches ("Ada") + + if Switches = Nil_Variable_Value then + Switches := + Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree, + Force_Lower_Case_Index => True); + + if Switches /= Nil_Variable_Value then + Switch_May_Be_Passed_To_The_Compiler := False; + end if; + end if; + + -- Next, try Switches (others) + if Switches = Nil_Variable_Value then Switches := Prj.Util.Value_Of @@ -8196,8 +8365,14 @@ package body Make is Src_Index => 0, In_Array => Switches_Array, In_Tree => Project_Tree); + + if Switches /= Nil_Variable_Value then + Switch_May_Be_Passed_To_The_Compiler := False; + end if; end if; + -- And finally, Default_Switches ("Ada") + if Switches = Nil_Variable_Value then Switches := Prj.Util.Value_Of diff --git a/gcc/ada/math_lib.adb b/gcc/ada/math_lib.adb index 8014f8412cf..81df8513f8a 100644 --- a/gcc/ada/math_lib.adb +++ b/gcc/ada/math_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/mdll-utl.adb b/gcc/ada/mdll-utl.adb index 4011db1323b..85bc2a3a63b 100644 --- a/gcc/ada/mdll-utl.adb +++ b/gcc/ada/mdll-utl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/mdll.ads b/gcc/ada/mdll.ads index 49174d405cd..45c6a4578b4 100644 --- a/gcc/ada/mdll.ads +++ b/gcc/ada/mdll.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb index 2ece4fae68b..3aae5c4db98 100644 --- a/gcc/ada/memroot.adb +++ b/gcc/ada/memroot.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, AdaCore -- +-- Copyright (C) 1997-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/memroot.ads b/gcc/ada/memroot.ads index 1b3d9ba467a..484b6217378 100644 --- a/gcc/ada/memroot.ads +++ b/gcc/ada/memroot.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2007, AdaCore -- +-- Copyright (C) 1997-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb index ad5c900a8ab..ad9a1e7d990 100644 --- a/gcc/ada/memtrack.adb +++ b/gcc/ada/memtrack.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h index e8d95558d0d..2e1a56756fd 100644 --- a/gcc/ada/mingw32.h +++ b/gcc/ada/mingw32.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2002-2007, Free Software Foundation, Inc. * + * Copyright (C) 2002-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads index 21aae82813a..ce36d7f0077 100644 --- a/gcc/ada/mlib-tgt.ads +++ b/gcc/ada/mlib-tgt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 533144a42ee..c18eafd6d31 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index 2a1b9cbc077..6182c8b01fe 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h index d30423b09a6..1dd9394e924 100644 --- a/gcc/ada/nlists.h +++ b/gcc/ada/nlists.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 859a4170ead..75ea7e8feec 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -49,6 +49,7 @@ package body Opt is Ada_Version_Config := Ada_Version; Ada_Version_Explicit_Config := Ada_Version_Explicit; Assertions_Enabled_Config := Assertions_Enabled; + Assume_No_Invalid_Values_Config := Assume_No_Invalid_Values; Check_Policy_List_Config := Check_Policy_List; Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; @@ -78,6 +79,7 @@ package body Opt is Ada_Version := Save.Ada_Version; Ada_Version_Explicit := Save.Ada_Version_Explicit; Assertions_Enabled := Save.Assertions_Enabled; + Assume_No_Invalid_Values := Save.Assume_No_Invalid_Values; Check_Policy_List := Save.Check_Policy_List; Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; @@ -102,6 +104,7 @@ package body Opt is Save.Ada_Version := Ada_Version; Save.Ada_Version_Explicit := Ada_Version_Explicit; Save.Assertions_Enabled := Assertions_Enabled; + Save.Assume_No_Invalid_Values := Assume_No_Invalid_Values; Save.Check_Policy_List := Check_Policy_List; Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; @@ -134,27 +137,30 @@ package body Opt is -- since the whole point of this is that it still properly indicates -- the configuration setting even in a run time unit. - Ada_Version := Ada_Version_Runtime; - Dynamic_Elaboration_Checks := False; - Extensions_Allowed := True; - External_Name_Exp_Casing := As_Is; - External_Name_Imp_Casing := Lowercase; - Optimize_Alignment := 'O'; - Persistent_BSS_Mode := False; - Use_VADS_Size := False; - Optimize_Alignment_Local := True; + Ada_Version := Ada_Version_Runtime; + Dynamic_Elaboration_Checks := False; + Extensions_Allowed := True; + External_Name_Exp_Casing := As_Is; + External_Name_Imp_Casing := Lowercase; + Optimize_Alignment := 'O'; + Persistent_BSS_Mode := False; + Use_VADS_Size := False; + Optimize_Alignment_Local := True; -- For an internal unit, assertions/debug pragmas are off unless this - -- is the main unit and they were explicitly enabled. + -- is the main unit and they were explicitly enabled. We also make + -- sure we do not assume that values are necessarily valid. if Main_Unit then - Assertions_Enabled := Assertions_Enabled_Config; - Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; - Check_Policy_List := Check_Policy_List_Config; + Assertions_Enabled := Assertions_Enabled_Config; + Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; + Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; + Check_Policy_List := Check_Policy_List_Config; else - Assertions_Enabled := False; - Debug_Pragmas_Enabled := False; - Check_Policy_List := Empty; + Assertions_Enabled := False; + Assume_No_Invalid_Values := False; + Debug_Pragmas_Enabled := False; + Check_Policy_List := Empty; end if; -- Case of non-internal unit @@ -163,6 +169,7 @@ package body Opt is Ada_Version := Ada_Version_Config; Ada_Version_Explicit := Ada_Version_Explicit_Config; Assertions_Enabled := Assertions_Enabled_Config; + Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; Check_Policy_List := Check_Policy_List_Config; Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index b0bde56b50d..542dc2568d0 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -144,10 +144,6 @@ package Opt is -- Set to non null when Bind_Alternate_Main_Name is True. This value -- is modified as needed by Gnatbind.Scan_Bind_Arg. - Assertions_Enabled : Boolean := False; - -- GNAT - -- Enable assertions made using pragma Assert - ASIS_Mode : Boolean := False; -- GNAT -- Enable semantic checks and tree transformations that are important @@ -158,6 +154,19 @@ package Opt is -- Back_Annotate_Rep_Info flag in this case. At the moment this does not -- make very much sense, because GNSA cannot do back annotation). + Assertions_Enabled : Boolean := False; + -- GNAT + -- Enable assertions made using pragma Assert + + Assume_No_Invalid_Values : Boolean := True; + -- ??? true for now, enable by setting to false later + -- GNAT + -- Normallly, in accordance with (RM 13.9.1 (9-11)) the front end assumes + -- that values could have invalid representations, unless it can clearly + -- prove that the values are valid. If this switch is set (by -gnatB or by + -- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values + -- are valid and in range of their representations. + Back_Annotate_Rep_Info : Boolean := False; -- GNAT -- If set True, enables back annotation of representation information @@ -1414,6 +1423,13 @@ package Opt is -- mode, as possibly set by the command line switch -gnata, and possibly -- modified by the use of the configuration pragma Assertion_Policy. + Assume_No_Invalid_Values_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch for assuming no invalid + -- values enabled mode mode, as possibly set by the command line switch + -- -gnatB, and possibly modified by the use of the configuration pragma + -- Assume_No_Invalid_Values. + Check_Policy_List_Config : Node_Id; -- GNAT -- This points to the list of N_Pragma nodes for Check_Policy pragmas @@ -1612,6 +1628,7 @@ private Ada_Version : Ada_Version_Type; Ada_Version_Explicit : Ada_Version_Type; Assertions_Enabled : Boolean; + Assume_No_Invalid_Values : Boolean; Check_Policy_List : Node_Id; Debug_Pragmas_Enabled : Boolean; Dynamic_Elaboration_Checks : Boolean; diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads index d3ecee64c38..a6b601fd296 100644 --- a/gcc/ada/osint-b.ads +++ b/gcc/ada/osint-b.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/osint-c.ads b/gcc/ada/osint-c.ads index 7a2872d2bf6..3c9cb69d378 100644 --- a/gcc/ada/osint-c.ads +++ b/gcc/ada/osint-c.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 7f7ef93fb3b..da3c3538a10 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 2ac26fee2c4..951d3087540 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index cd2d6c9976c..80a566beb5c 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 5129b1e867f..ddc7b61fd10 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 7879b1dd83e..188893a4b28 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 585e9c7d45a..89310ad665c 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index bc2a47eeec6..9874c4fcef9 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index ba32f387b6a..fc2360cd149 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1050,6 +1050,7 @@ begin when Pragma_Abort_Defer | Pragma_Assertion_Policy | + Pragma_Assume_No_Invalid_Values | Pragma_AST_Entry | Pragma_All_Calls_Remote | Pragma_Annotate | diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb index b4f4189f123..cbf1d1ef01e 100644 --- a/gcc/ada/par-sync.adb +++ b/gcc/ada/par-sync.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 634e5b322e1..a4c3b2d4999 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 6ce31875351..bf9d7dfe5a3 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 6f18c81034d..db6a70cd7b0 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -7720,6 +7720,9 @@ package body Prj.Nmsc is end if; end loop; + when Mixed_Case => + null; + when others => OK := False; end case; @@ -8163,7 +8166,9 @@ package body Prj.Nmsc is then Source_To_Replace := Source; - elsif Unit /= No_Name then + elsif Unit /= No_Name + and then not Src_Data.Locally_Removed + then Error_Msg_Name_1 := Unit; Error_Msg (Project, In_Tree, diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index c4626b15ded..67fa43dfe85 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 24d42e40a27..03e7327b82e 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -1417,6 +1417,11 @@ package body Prj.Proc is From_Project_Node_Tree); -- The name of the attribute + Current_Location : constant Source_Ptr := + Location_Of + (Current_Item, + From_Project_Node_Tree); + New_Array : Array_Id; -- The new associative array created @@ -1483,20 +1488,22 @@ package body Prj.Proc is if Pkg /= No_Package then In_Tree.Arrays.Table (New_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => - In_Tree.Packages.Table (Pkg).Decl.Arrays); + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Packages.Table + (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := New_Array; else In_Tree.Arrays.Table (New_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => - In_Tree.Projects.Table (Project).Decl.Arrays); + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Projects.Table + (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := New_Array; @@ -1706,6 +1713,11 @@ package body Prj.Proc is (Current_Item, From_Project_Node_Tree); + Current_Location : constant Source_Ptr := + Location_Of + (Current_Item, + From_Project_Node_Tree); + begin -- Process a typed variable declaration @@ -1970,22 +1982,22 @@ package body Prj.Proc is if Pkg /= No_Package then In_Tree.Arrays.Table (The_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => - In_Tree.Packages.Table - (Pkg).Decl.Arrays); + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Packages.Table + (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := The_Array; else In_Tree.Arrays.Table (The_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => - In_Tree.Projects.Table - (Project).Decl.Arrays); + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Projects.Table + (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := The_Array; diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads index 19173003eac..d0b4b593941 100644 --- a/gcc/ada/prj-strt.ads +++ b/gcc/ada/prj-strt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 27fba81bf09..d06138e1bdf 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -64,7 +64,7 @@ package Prj is -- Tri-state to decide if -lgnarl is needed when linking type Mode is (Multi_Language, Ada_Only); - -- Ada_Only: mode for gnatmake, gnatname, the GNAT driver + -- Ada_Only: mode for gnatmake, gnatclean, gnatname, the GNAT driver -- Multi_Language: mode for gprbuild, gprclean type Project_Qualifier is @@ -253,9 +253,10 @@ package Prj is type Array_Id is new Nat; No_Array : constant Array_Id := 0; type Array_Data is record - Name : Name_Id := No_Name; - Value : Array_Element_Id := No_Array_Element; - Next : Array_Id := No_Array; + Name : Name_Id := No_Name; + Location : Source_Ptr := No_Location; + Value : Array_Element_Id := No_Array_Element; + Next : Array_Id := No_Array; end record; -- Each Array_Data value represents an array. -- Value is the id of the first element. diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index e2662e14f23..434213b7d89 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -663,16 +663,21 @@ db_action_for (action_descriptor *action, _Unwind_Context *uw_context) return; } - /* Search the call_site_table of REGION for an entry appropriate for the - UW_CONTEXT's ip. If one is found, store the associated landing_pad and - action_table entry, and set the ACTION kind to unknown for further - analysis. Otherwise, set the ACTION kind to nothing. + UW_CONTEXT's IP. If one is found, store the associated landing_pad + and action_table entry, and set the ACTION kind to unknown for further + analysis. Otherwise, set the ACTION kind to nothing. There are two variants of this routine, depending on the underlying - mechanism (dwarf/sjlj), which account for differences in the tables - organization. -*/ + mechanism (DWARF/SJLJ), which account for differences in the tables. */ + +#ifdef __APPLE__ +/* On MacOS X, versions older than 10.5 don't export _Unwind_GetIPInfo. */ +#undef HAVE_GETIPINFO +#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1050 +#define HAVE_GETIPINFO 1 +#endif +#endif #ifdef __USING_SJLJ_EXCEPTIONS__ @@ -683,14 +688,21 @@ get_call_site_action_for (_Unwind_Context *uw_context, region_descriptor *region, action_descriptor *action) { - _Unwind_Ptr call_site - = _Unwind_GetIP (uw_context) - 1; - /* Subtract 1 because GetIP returns the actual call_site value + 1. */ + int ip_before_insn = 0; +#ifdef HAVE_GETIPINFO + _Unwind_Ptr call_site = _Unwind_GetIPInfo (uw_context, &ip_before_insn); +#else + _Unwind_Ptr call_site = _Unwind_GetIP (uw_context); +#endif + /* Subtract 1 if necessary because GetIPInfo returns the actual call site + value + 1 in this case. */ + if (!ip_before_insn) + call_site--; /* call_site is a direct index into the call-site table, with two special - values : -1 for no-action and 0 for "terminate". The latter should never - show up for Ada. To test for the former, beware that _Unwind_Ptr might be - unsigned. */ + values : -1 for no-action and 0 for "terminate". The latter should never + show up for Ada. To test for the former, beware that _Unwind_Ptr might + be unsigned. */ if ((int)call_site < 0) { @@ -712,18 +724,17 @@ get_call_site_action_for (_Unwind_Context *uw_context, action->kind = unknown; /* We have a direct index into the call-site table, but this table is - made of leb128 values, the encoding length of which is variable. We + made of leb128 values, the encoding length of which is variable. We can't merely compute an offset from the index, then, but have to read all the entries before the one of interest. */ - const unsigned char * p = region->call_site_table; + const unsigned char *p = region->call_site_table; do { p = read_uleb128 (p, &cs_lp); p = read_uleb128 (p, &cs_action); } while (--call_site); - action->landing_pad = cs_lp + 1; if (cs_action) @@ -735,29 +746,28 @@ get_call_site_action_for (_Unwind_Context *uw_context, } } -#else -/* ! __USING_SJLJ_EXCEPTIONS__ */ +#else /* !__USING_SJLJ_EXCEPTIONS__ */ static void get_call_site_action_for (_Unwind_Context *uw_context, region_descriptor *region, action_descriptor *action) { - _Unwind_Ptr ip - = _Unwind_GetIP (uw_context) - 1; - /* Subtract 1 because GetIP yields a call return address while we are - interested in information for the call point. This does not always yield - the exact call instruction address but always brings the ip back within - the corresponding region. - - ??? When unwinding up from a signal handler triggered by a trap on some - instruction, we usually have the faulting instruction address here and - subtracting 1 might get us into the wrong region. */ - - const unsigned char * p - = region->call_site_table; - - /* Unless we are able to determine otherwise ... */ + const unsigned char *p = region->call_site_table; + int ip_before_insn = 0; +#ifdef HAVE_GETIPINFO + _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); +#else + _Unwind_Ptr ip = _Unwind_GetIP (uw_context); +#endif + /* Subtract 1 if necessary because GetIPInfo yields a call return address + in this case, while we are interested in information for the call point. + This does not always yield the exact call instruction address but always + brings the IP back within the corresponding region. */ + if (!ip_before_insn) + ip--; + + /* Unless we are able to determine otherwise... */ action->kind = nothing; db (DB_CSITE, "\n"); @@ -778,7 +788,7 @@ get_call_site_action_for (_Unwind_Context *uw_context, region->base+cs_start, cs_start, cs_len, region->lp_base+cs_lp, cs_lp); - /* The table is sorted, so if we've passed the ip, stop. */ + /* The table is sorted, so if we've passed the IP, stop. */ if (ip < region->base + cs_start) break; @@ -807,7 +817,7 @@ get_call_site_action_for (_Unwind_Context *uw_context, db (DB_CSITE, "---\n"); } -#endif +#endif /* __USING_SJLJ_EXCEPTIONS__ */ /* With CHOICE an exception choice representing an "exception - when" argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 6764994e4f3..178cb2fa43f 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 39d037a15d9..33128cfb099 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 34e84065907..5404fcdcd2b 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -697,7 +697,7 @@ package Rtsfind is RE_Get_Local_Partition_Id, -- System.DSA_Services RE_Get_Passive_Partition_Id, -- System.DSA_Services - RE_Any_Content_Ptr, -- System.DSA_Types + RE_Any_Container_Ptr, -- System.DSA_Types RE_Register_Exception, -- System.Exception_Table @@ -1261,11 +1261,8 @@ package Rtsfind is RE_SS_Mark, -- System.Secondary_Stack RE_SS_Release, -- System.Secondary_Stack - RE_Shared_Var_Close, -- System.Shared_Storage RE_Shared_Var_Lock, -- System.Shared_Storage - RE_Shared_Var_ROpen, -- System.Shared_Storage RE_Shared_Var_Unlock, -- System.Shared_Storage - RE_Shared_Var_WOpen, -- System.Shared_Storage RE_Shared_Var_Procs, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library @@ -1854,7 +1851,7 @@ package Rtsfind is RE_Get_Local_Partition_Id => System_DSA_Services, RE_Get_Passive_Partition_Id => System_DSA_Services, - RE_Any_Content_Ptr => System_DSA_Types, + RE_Any_Container_Ptr => System_DSA_Types, RE_Register_Exception => System_Exception_Table, @@ -2418,11 +2415,8 @@ package Rtsfind is RE_SS_Pool => System_Secondary_Stack, RE_SS_Release => System_Secondary_Stack, - RE_Shared_Var_Close => System_Shared_Storage, RE_Shared_Var_Lock => System_Shared_Storage, - RE_Shared_Var_ROpen => System_Shared_Storage, RE_Shared_Var_Unlock => System_Shared_Storage, - RE_Shared_Var_WOpen => System_Shared_Storage, RE_Shared_Var_Procs => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, diff --git a/gcc/ada/s-arit64.ads b/gcc/ada/s-arit64.ads index b414949b127..b7276544092 100644 --- a/gcc/ada/s-arit64.ads +++ b/gcc/ada/s-arit64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb index ed724322958..5ae74de2fba 100644 --- a/gcc/ada/s-auxdec.adb +++ b/gcc/ada/s-auxdec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/Or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-casuti.ads b/gcc/ada/s-casuti.ads index 6831942d3fb..f865d527768 100644 --- a/gcc/ada/s-casuti.ads +++ b/gcc/ada/s-casuti.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-fatflt.ads b/gcc/ada/s-fatflt.ads index a1290791948..5bc3c61159c 100644 --- a/gcc/ada/s-fatflt.ads +++ b/gcc/ada/s-fatflt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index f690177a59f..d935c277528 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-fatlfl.ads b/gcc/ada/s-fatlfl.ads index b4c5c510af8..69d0cac743a 100644 --- a/gcc/ada/s-fatlfl.ads +++ b/gcc/ada/s-fatlfl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-fatllf.ads b/gcc/ada/s-fatllf.ads index 6869d8e7e85..6cefe2365ee 100644 --- a/gcc/ada/s-fatllf.ads +++ b/gcc/ada/s-fatllf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-fatsfl.ads b/gcc/ada/s-fatsfl.ads index 8539723bf04..e012ae8d0f8 100644 --- a/gcc/ada/s-fatsfl.ads +++ b/gcc/ada/s-fatsfl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 7c20fb18f38..d2af05c2048 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -38,7 +38,6 @@ with Interfaces.C_Streams; use Interfaces.C_Streams; with System.CRTL; with System.Case_Util; use System.Case_Util; -with System.OS_Constants; with System.OS_Lib; with System.Soft_Links; @@ -994,11 +993,27 @@ package body System.File_IO is -- Should we raise Device_Error for ENOSPC??? - if System.OS_Lib.Errno = System.OS_Constants.ENOENT then - raise Name_Error; - else - raise Use_Error; - end if; + declare + subtype Cint is Interfaces.C.int; + + function Is_File_Not_Found_Error + (Errno_Value : Cint) return Cint; + -- Non-zero when the given errno value indicates a non- + -- existing file. + + pragma Import + (C, Is_File_Not_Found_Error, + "__gnat_is_file_not_found_error"); + + begin + if + Is_File_Not_Found_Error (Cint (System.OS_Lib.Errno)) /= 0 + then + raise Name_Error; + else + raise Use_Error; + end if; + end; end if; end if; end if; diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index 2d6defb3e6b..225e461e120 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads index 0f4b7d189bf..4fcb8ecd0bb 100644 --- a/gcc/ada/s-finroo.ads +++ b/gcc/ada/s-finroo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-hibaen.ads b/gcc/ada/s-hibaen.ads index d7ae2325106..ad76109e11d 100644 --- a/gcc/ada/s-hibaen.ads +++ b/gcc/ada/s-hibaen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads index d7bcbef5f38..e036288bc4b 100644 --- a/gcc/ada/s-htable.ads +++ b/gcc/ada/s-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2007, AdaCore -- +-- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-imgcha.adb b/gcc/ada/s-imgcha.adb index 3d9bbe9b86b..4c8829e9eff 100644 --- a/gcc/ada/s-imgcha.adb +++ b/gcc/ada/s-imgcha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-imgenu.ads b/gcc/ada/s-imgenu.ads index 9dc66e68634..8b558d0381d 100644 --- a/gcc/ada/s-imgenu.ads +++ b/gcc/ada/s-imgenu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-imgint.adb b/gcc/ada/s-imgint.adb index a6c31489e69..68d914d97c8 100644 --- a/gcc/ada/s-imgint.adb +++ b/gcc/ada/s-imgint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb index bbcf225a1dd..c0de23ad76f 100644 --- a/gcc/ada/s-imgrea.adb +++ b/gcc/ada/s-imgrea.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-inmaop-dummy.adb b/gcc/ada/s-inmaop-dummy.adb index 4c7f77c63ae..675c0c3272c 100644 --- a/gcc/ada/s-inmaop-dummy.adb +++ b/gcc/ada/s-inmaop-dummy.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- diff --git a/gcc/ada/s-inmaop.ads b/gcc/ada/s-inmaop.ads index 2e9674d22df..1618850d441 100644 --- a/gcc/ada/s-inmaop.ads +++ b/gcc/ada/s-inmaop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- diff --git a/gcc/ada/s-mastop-irix.adb b/gcc/ada/s-mastop-irix.adb index a5b04e08117..8ff5bc8a9e3 100644 --- a/gcc/ada/s-mastop-irix.adb +++ b/gcc/ada/s-mastop-irix.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Version for IRIX/MIPS) -- -- -- --- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-memory-mingw.adb b/gcc/ada/s-memory-mingw.adb index da01b9b80e4..12af9377f14 100644 --- a/gcc/ada/s-memory-mingw.adb +++ b/gcc/ada/s-memory-mingw.adb @@ -4,9 +4,9 @@ -- -- -- S Y S T E M . M E M O R Y -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb index cfc539fcbdd..9826c2f5e60 100644 --- a/gcc/ada/s-memory.adb +++ b/gcc/ada/s-memory.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-memory.ads b/gcc/ada/s-memory.ads index e455af6f5a6..6cbcabbb9f1 100644 --- a/gcc/ada/s-memory.ads +++ b/gcc/ada/s-memory.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 8364d16076e..b5f55485446 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -719,12 +719,12 @@ package System.OS_Lib is -- "Spawn" should not be used in tasking applications. procedure Spawn - (Program_Name : String; - Args : Argument_List; - Output_File : String; - Success : out Boolean; - Return_Code : out Integer; - Err_To_Out : Boolean := True); + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Success : out Boolean; + Return_Code : out Integer; + Err_To_Out : Boolean := True); -- Similar to the procedure above, but saves the output of the command to -- a file with the name Output_File. -- diff --git a/gcc/ada/s-osinte-lynxos-3.adb b/gcc/ada/s-osinte-lynxos-3.adb index 09cbfca99b7..1b53436f68d 100644 --- a/gcc/ada/s-osinte-lynxos-3.adb +++ b/gcc/ada/s-osinte-lynxos-3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2008, 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- -- diff --git a/gcc/ada/s-osprim-vms.adb b/gcc/ada/s-osprim-vms.adb index 93138414571..71e36c66293 100644 --- a/gcc/ada/s-osprim-vms.adb +++ b/gcc/ada/s-osprim-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, 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- -- diff --git a/gcc/ada/s-parame-ae653.ads b/gcc/ada/s-parame-ae653.ads index 5d4fd4caed8..1c06371ea55 100644 --- a/gcc/ada/s-parame-ae653.ads +++ b/gcc/ada/s-parame-ae653.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads index 865ed763f44..b68199c4369 100644 --- a/gcc/ada/s-parame-hpux.ads +++ b/gcc/ada/s-parame-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads index b9119bc00d7..37b8521ead7 100644 --- a/gcc/ada/s-parame-vms-alpha.ads +++ b/gcc/ada/s-parame-vms-alpha.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads index 4273df9dd95..e9f59e139fd 100644 --- a/gcc/ada/s-parame-vms-ia64.ads +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parame-vms-restrict.ads b/gcc/ada/s-parame-vms-restrict.ads index a0404edaac2..ef0a28d57c9 100644 --- a/gcc/ada/s-parame-vms-restrict.ads +++ b/gcc/ada/s-parame-vms-restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads index bc0ee16ca60..46666f63a81 100644 --- a/gcc/ada/s-parame-vxworks.ads +++ b/gcc/ada/s-parame-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index a94b22296bc..0a7e1fc4675 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb index 94b08326c25..d73da1340d9 100644 --- a/gcc/ada/s-parint.adb +++ b/gcc/ada/s-parint.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Dummy body for non-distributed case) -- -- -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2008, 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- -- diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads index 9191c0731b6..2562b73d2e5 100644 --- a/gcc/ada/s-parint.ads +++ b/gcc/ada/s-parint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- 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- -- diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb index 5d7318da3eb..3279a542fc1 100644 --- a/gcc/ada/s-poosiz.adb +++ b/gcc/ada/s-poosiz.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-proinf-irix-athread.ads b/gcc/ada/s-proinf-irix-athread.ads index aa266ac924d..cc612d4f93a 100644 --- a/gcc/ada/s-proinf-irix-athread.ads +++ b/gcc/ada/s-proinf-irix-athread.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-proinf.ads b/gcc/ada/s-proinf.ads index f5133d66ad1..3a72f61e405 100644 --- a/gcc/ada/s-proinf.ads +++ b/gcc/ada/s-proinf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb index 2dae7b29103..268ec219308 100755 --- a/gcc/ada/s-regexp.adb +++ b/gcc/ada/s-regexp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2007, AdaCore -- +-- Copyright (C) 1999-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb index c4ef8628c0b..b5d8a990bf6 100644 --- a/gcc/ada/s-shasto.adb +++ b/gcc/ada/s-shasto.adb @@ -33,6 +33,7 @@ with Ada.IO_Exceptions; with Ada.Streams; +with Ada.Streams.Stream_IO; with System.Global_Locks; with System.Soft_Links; @@ -55,6 +56,8 @@ package body System.Shared_Storage is package SFI renames System.File_IO; + package SIO renames Ada.Streams.Stream_IO; + type String_Access is access String; procedure Free is new Ada.Unchecked_Deallocation (Object => String, Name => String_Access); @@ -168,6 +171,26 @@ package body System.Shared_Storage is -- created entry is returned, after first moving it to the head of -- the LRU chain. If not, then null is returned. + function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns null if the + -- corresponding shared storage does not exist, and otherwise, if + -- the storage does exist, a Stream_Access value that references + -- the shared storage, ready to read the current value. + + function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns a Stream_Access value + -- that references the shared storage, ready to write the new + -- value. The storage is created by this call if it does not + -- already exist. + + procedure Shared_Var_Close (Var : SIO.Stream_Access); + -- This routine signals the end of a read/assign operation. It can + -- be useful to embrace a read/write operation between a call to + -- open and a call to close which protect the whole operation. + -- Otherwise, two simultaneous operations can result in the + -- raising of exception Data_Error by setting the access mode of + -- the variable in an incorrect mode. + --------------- -- Enter_SFE -- --------------- diff --git a/gcc/ada/s-shasto.ads b/gcc/ada/s-shasto.ads index 2fd0341b7b6..40089a33075 100644 --- a/gcc/ada/s-shasto.ads +++ b/gcc/ada/s-shasto.ads @@ -82,30 +82,16 @@ -- For each shared variable, var, an instantiation of the below generic -- package is created which provides Read and Write supporting procedures. --- The routine Shared_Var_ROpen in package System.Shared_Storage --- either returns null if the storage does not exist, or otherwise a --- Stream_Access value that references the corresponding shared --- storage, ready to read the current value. - --- The routine Shared_Var_WOpen in package System.Shared_Storage --- returns a Stream_Access value that references the corresponding --- shared storage, ready to write the new value. - --- Note that there is no general synchronization for these storage --- read and write operations, since it is assumed that a correctly --- operating programs will provide appropriate synchronization. In --- particular, variables can be protected using protected types with --- no entries. - --- The routine Shared_Var_Close is called to indicate the end of a --- read/write operations. This can be useful even in the context of --- the GNAT implementation. For instance, when a read operation and a --- write operation occur at the same time on the same partition, as --- the same stream is used simultaneously, both operations can --- terminate abruptly by raising exception Mode_Error because the --- stream has been opened in read mode and then in write mode and at --- least used by the read operation. To avoid this unexpected --- behaviour, we introduce a synchronization at the partition level. +-- The routine Read in package System.Shared_Storage.Shared_Var_Procs +-- ensures to assign variable V to the last written value among processes +-- referencing it. A call to this procedure is generated by the expander +-- before each read access to the shared variable. + +-- The routine Write in package System.Shared_Storage.Shared_Var_Proc +-- set a new value to the shared variable and, according to the used +-- implementation, propagate this value among processes referencing it. +-- A call to this procedure is generated by the expander after each +-- assignement of the shared varible. -- Note: a special circuit allows the use of stream attributes Read and -- Write for limited types (using the corresponding attribute for the @@ -150,32 +136,8 @@ -- These calls to the read and assign routines, as well as the lock -- and unlock routines, are inserted by the expander (see exp_smem.adb). -with Ada.Streams.Stream_IO; - package System.Shared_Storage is - package SIO renames Ada.Streams.Stream_IO; - - function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; - -- As described above, this routine returns null if the - -- corresponding shared storage does not exist, and otherwise, if - -- the storage does exist, a Stream_Access value that references - -- the shared storage, ready to read the current value. - - function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; - -- As described above, this routine returns a Stream_Access value - -- that references the shared storage, ready to write the new - -- value. The storage is created by this call if it does not - -- already exist. - - procedure Shared_Var_Close (Var : SIO.Stream_Access); - -- This routine signals the end of a read/assign operation. It can - -- be useful to embrace a read/write operation between a call to - -- open and a call to close which protect the whole operation. - -- Otherwise, two simultaneous operations can result in the - -- raising of exception Data_Error by setting the access mode of - -- the variable in an incorrect mode. - procedure Shared_Var_Lock (Var : String); -- This procedure claims the shared storage lock. It is used for -- protected types in shared passive packages. A call to this @@ -185,7 +147,7 @@ package System.Shared_Storage is procedure Shared_Var_Unlock (Var : String); -- This procedure releases the shared storage lock obtained by a - -- prior call to the Shared_Mem_Lock procedure, and is to be + -- prior call to the Shared_Var_Lock procedure, and is to be -- generated as the last operation in the body of a protected -- subprogram. diff --git a/gcc/ada/s-sopco3.adb b/gcc/ada/s-sopco3.adb index bdd11aa7b0d..6637b082de1 100644 --- a/gcc/ada/s-sopco3.adb +++ b/gcc/ada/s-sopco3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ package body System.String_Ops_Concat_3 is function Str_Concat_3 (S1, S2, S3 : String) return String is begin - if S1'Length <= 0 then + if S1'Length = 0 then return S2 & S3; else diff --git a/gcc/ada/s-sopco4.adb b/gcc/ada/s-sopco4.adb index 8770a67034e..f7751aaae5a 100644 --- a/gcc/ada/s-sopco4.adb +++ b/gcc/ada/s-sopco4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ package body System.String_Ops_Concat_4 is function Str_Concat_4 (S1, S2, S3, S4 : String) return String is begin - if S1'Length <= 0 then + if S1'Length = 0 then return S2 & S3 & S4; else diff --git a/gcc/ada/s-sopco5.adb b/gcc/ada/s-sopco5.adb index 45eafd1a79c..bacae9f7aa0 100644 --- a/gcc/ada/s-sopco5.adb +++ b/gcc/ada/s-sopco5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ package body System.String_Ops_Concat_5 is function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String is begin - if S1'Length <= 0 then + if S1'Length = 0 then return S2 & S3 & S4 & S5; else diff --git a/gcc/ada/s-strops.adb b/gcc/ada/s-strops.adb index 4e434726b07..e92c3bb7a6c 100644 --- a/gcc/ada/s-strops.adb +++ b/gcc/ada/s-strops.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ package body System.String_Ops is function Str_Concat (X, Y : String) return String is begin - if X'Length <= 0 then + if X'Length = 0 then return Y; else @@ -91,7 +91,7 @@ package body System.String_Ops is function Str_Concat_SC (X : String; Y : Character) return String is begin - if X'Length <= 0 then + if X'Length = 0 then return (1 => Y); else diff --git a/gcc/ada/s-utf_32.adb b/gcc/ada/s-utf_32.adb index 25716e53627..d57c730bbf2 100755 --- a/gcc/ada/s-utf_32.adb +++ b/gcc/ada/s-utf_32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -5103,7 +5103,7 @@ package body System.UTF_32 is begin -- Deal with FFFE/FFFF cases - if U mod 2#1_0000# >= 16#FFFE# then + if U mod 16#1_0000# >= 16#FFFE# then return Fe; -- Otherwise search table diff --git a/gcc/ada/s-wwdcha.adb b/gcc/ada/s-wwdcha.adb index 3580a0142f5..6f2d1ceedd2 100644 --- a/gcc/ada/s-wwdcha.adb +++ b/gcc/ada/s-wwdcha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,20 +43,11 @@ package body System.WWd_Char is begin W := 0; for C in Lo .. Hi loop - -- For Character range, use length of image - - if Character'Pos (C) < 256 then - declare - S : constant Wide_String := Character'Wide_Image (C); - begin - W := Natural'Max (W, S'Length); - end; - - -- For wide character, always max out at 12 (Hex_hhhhhhhh) - - else - return 12; - end if; + declare + S : constant Wide_String := Character'Wide_Image (C); + begin + W := Natural'Max (W, S'Length); + end; end loop; return W; @@ -72,21 +63,11 @@ package body System.WWd_Char is begin W := 0; for C in Lo .. Hi loop - - -- For Character range, use length of image - - if Character'Pos (C) < 256 then - declare - S : constant String := Character'Image (C); - begin - W := Natural'Max (W, S'Length); - end; - - -- For wide character, always max out at 12 (Hex_hhhhhhhh) - - else - return 12; - end if; + declare + S : constant String := Character'Image (C); + begin + W := Natural'Max (W, S'Length); + end; end loop; return W; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index d16b7d6b8c4..13ab96c6c63 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2155,20 +2155,31 @@ package body Sem_Aggr is begin Imm_Type := Base_Type (Typ); - while Is_Derived_Type (Imm_Type) - and then Etype (Imm_Type) /= Base_Type (A_Type) - loop - Imm_Type := Etype (Base_Type (Imm_Type)); + while Is_Derived_Type (Imm_Type) loop + if Etype (Imm_Type) = Base_Type (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 + -- use the partial view for the ancestor part. + + elsif Is_Private_Type (Etype (Imm_Type)) + and then Present (Full_View (Etype (Imm_Type))) + and then Base_Type (A_Type) = Full_View (Etype (Imm_Type)) + then + A_Type := Etype (Imm_Type); + return True; + + else + Imm_Type := Etype (Base_Type (Imm_Type)); + end if; end loop; - if not Is_Derived_Type (Base_Type (Typ)) - or else Etype (Imm_Type) /= Base_Type (A_Type) - then - Error_Msg_NE ("expect ancestor type of &", A, Typ); - return False; - else - return True; - end if; + -- If previous loop did not find a proper ancestor, report error. + + Error_Msg_NE ("expect ancestor type of &", A, Typ); + return False; end Valid_Ancestor_Type; -- Start of processing for Resolve_Extension_Aggregate diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 367f25555c1..273c04f8185 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -433,8 +433,7 @@ package body Sem_Cat is -- of an RCI unit. return Is_Remote_Call_Interface (Unit_Entity) - and then (Ekind (Unit_Entity) = E_Package - or else Ekind (Unit_Entity) = E_Generic_Package) + and then Is_Package_Or_Generic_Package (Unit_Entity) and then Unit_Kind /= N_Package_Body and then List_Containing (N) = Visible_Declarations @@ -459,8 +458,7 @@ package body Sem_Cat is -- There are no restrictions on the body of a Remote Types unit return Is_Remote_Types (Unit_Entity) - and then (Ekind (Unit_Entity) = E_Package - or else Ekind (Unit_Entity) = E_Generic_Package) + and then Is_Package_Or_Generic_Package (Unit_Entity) and then Unit_Kind /= N_Package_Body and then not In_Package_Body (Unit_Entity) and then not In_Instance; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index f81cca8ea12..6331c0443ea 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2007,9 +2007,7 @@ package body Sem_Ch10 is -- all the parents are bodies. Restore full visibility of their -- private entities. - if Ekind (Scop) = E_Package - or else Ekind (Scop) = E_Generic_Package - then + if Is_Package_Or_Generic_Package (Scop) then Set_In_Package_Body (Scop); Install_Private_Declarations (Scop); end if; @@ -2099,9 +2097,7 @@ package body Sem_Ch10 is -- context includes another subunit of the same parent which in -- turn includes a child unit in its context. - if Ekind (Par_Unit) = E_Package - or else Ekind (Par_Unit) = E_Generic_Package - then + if Is_Package_Or_Generic_Package (Par_Unit) then if not Is_Immediately_Visible (Par_Unit) or else (Present (First_Entity (Par_Unit)) and then not Is_Immediately_Visible diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 30628b6864a..c956e7cbada 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5202,8 +5202,7 @@ package body Sem_Ch12 is Inst_Par := Entity (Prefix (Gen_Id)); while Present (Inst_Par) - and then Ekind (Inst_Par) /= E_Package - and then Ekind (Inst_Par) /= E_Generic_Package + and then not Is_Package_Or_Generic_Package (Inst_Par) loop Inst_Par := Homonym (Inst_Par); end loop; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index fe5305fa40f..0de30ebaec7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -222,66 +222,69 @@ package body Sem_Ch13 is Comp := First_Component_Or_Discriminant (R); while Present (Comp) loop declare - CC : constant Node_Id := Component_Clause (Comp); - Fbit : constant Uint := Static_Integer (First_Bit (CC)); + CC : constant Node_Id := Component_Clause (Comp); begin if Present (CC) then + declare + Fbit : constant Uint := Static_Integer (First_Bit (CC)); - -- Case of component with size > max machine scalar - - if Esize (Comp) > Max_Machine_Scalar_Size then + begin + -- Case of component with size > max machine scalar - -- Must begin on byte boundary + if Esize (Comp) > Max_Machine_Scalar_Size then - if Fbit mod SSU /= 0 then - Error_Msg_N - ("illegal first bit value for reverse bit order", - First_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + -- Must begin on byte boundary - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - First_Bit (CC)); + if Fbit mod SSU /= 0 then + Error_Msg_N + ("illegal first bit value for reverse bit order", + First_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; - -- Must end on byte boundary + Error_Msg_N + ("\must be a multiple of ^ if size greater than ^", + First_Bit (CC)); - elsif Esize (Comp) mod SSU /= 0 then - Error_Msg_N - ("illegal last bit value for reverse bit order", - Last_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + -- Must end on byte boundary - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - Last_Bit (CC)); + elsif Esize (Comp) mod SSU /= 0 then + Error_Msg_N + ("illegal last bit value for reverse bit order", + Last_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; - -- OK, give warning if enabled + Error_Msg_N + ("\must be a multiple of ^ if size greater than ^", + Last_Bit (CC)); - elsif Warn_On_Reverse_Bit_Order then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CC); + -- OK, give warning if enabled - if Bytes_Big_Endian then - Error_Msg_N - ("\bytes are not reversed " - & "(component is big-endian)?", CC); - else + elsif Warn_On_Reverse_Bit_Order then Error_Msg_N - ("\bytes are not reversed " - & "(component is little-endian)?", CC); + ("multi-byte field specified with non-standard" + & " Bit_Order?", CC); + + if Bytes_Big_Endian then + Error_Msg_N + ("\bytes are not reversed " + & "(component is big-endian)?", CC); + else + Error_Msg_N + ("\bytes are not reversed " + & "(component is little-endian)?", CC); + end if; end if; - end if; - -- Case where size is not greater than max machine scalar. - -- For now, we just count these. + -- Case where size is not greater than max machine + -- scalar. For now, we just count these. - else - Num_CC := Num_CC + 1; - end if; + else + Num_CC := Num_CC + 1; + end if; + end; end if; end; @@ -433,18 +436,20 @@ package body Sem_Ch13 is if Warn_On_Reverse_Bit_Order then Error_Msg_Uint_1 := MSS; Error_Msg_N - ("?reverse bit order in machine " & - "scalar of length^", First_Bit (CC)); + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); Error_Msg_Uint_1 := NFB; Error_Msg_Uint_2 := NLB; if Bytes_Big_Endian then Error_Msg_NE - ("?\big-endian range for component & is ^ .. ^", + ("?\info: big-endian range for " + & "component & is ^ .. ^", First_Bit (CC), Comp); else Error_Msg_NE - ("?\little-endian range for component & is ^ .. ^", + ("?\info: little-endian range " + & "for component & is ^ .. ^", First_Bit (CC), Comp); end if; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e5954a92110..a26d4b703cd 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1465,10 +1465,7 @@ package body Sem_Ch5 is function One_Bound (Original_Bound : Node_Id; Analyzed_Bound : Node_Id) return Node_Id; - -- Create one declaration followed by one assignment statement - -- to capture the value of bound. We create a separate assignment - -- in order to force the creation of a block in case the bound - -- contains a call that uses the secondary stack. + -- Capture value of bound and return captured value --------------- -- One_Bound -- @@ -1499,15 +1496,53 @@ package body Sem_Ch5 is then Analyze_And_Resolve (Original_Bound, Typ); return Original_Bound; - - else - Analyze_And_Resolve (Original_Bound, Typ); end if; + -- Here we need to capture the value + + Analyze_And_Resolve (Original_Bound, Typ); + Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + -- Normally, the best approach is simply to generate a constant + -- declaration that captures the bound. However, there is a nasty + -- case where this is wrong. If the bound is complex, and has a + -- possible use of the secondary stack, we need to generate a + -- separate assignment statement to ensure the creation of a block + -- which will release the secondary stack. + + -- We prefer the constant declaration, since it leaves us with a + -- proper trace of the value, useful in optimizations that get rid + -- of junk range checks. + + -- Probably we want something like the Side_Effect_Free routine + -- in Exp_Util, but for now, we just optimize the cases of 'Last + -- and 'First applied to an entity, since these are the important + -- cases for range check optimizations. + + if Nkind (Original_Bound) = N_Attribute_Reference + and then (Attribute_Name (Original_Bound) = Name_First + or else + Attribute_Name (Original_Bound) = Name_Last) + and then Is_Entity_Name (Prefix (Original_Bound)) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Original_Bound)); + + Insert_Before (Parent (N), Decl); + Analyze (Decl); + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); + return Expression (Decl); + end if; + + -- Here we make a declaration with a separate assignment statement + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Id, diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1e84b266745..9a319d992a4 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1724,6 +1724,12 @@ package body Sem_Ch6 is "if subprogram is primitive", Body_Spec); end if; + + elsif Style_Check + and then Is_Overriding_Operation (Spec_Id) + then + pragma Assert (Unit_Declaration_Node (Body_Id) = N); + Style.Missing_Overriding (N, Body_Id); end if; end Verify_Overriding_Indicator; @@ -3112,7 +3118,7 @@ package body Sem_Ch6 is -- actions interfere in complex ways with inlining. elsif Ekind (Subp) = E_Function - and then Controlled_Type (Etype (Subp)) + and then Needs_Finalization (Etype (Subp)) then Cannot_Inline ("cannot inline & (controlled return type)?", N, Subp); @@ -3921,7 +3927,7 @@ package body Sem_Ch6 is if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); end if; end; @@ -4167,6 +4173,10 @@ package body Sem_Ch6 is Set_Is_Overriding_Operation (Subp); end if; + if Style_Check and then not Must_Override (Spec) then + Style.Missing_Overriding (Decl, Subp); + end if; + -- If Subp is an operator, it may override a predefined operation. -- In that case overridden_subp is empty because of our implicit -- representation for predefined operators. We have to check whether the @@ -4190,16 +4200,23 @@ package body Sem_Ch6 is ("subprogram & overrides predefined operator ", Spec, Subp); end if; - elsif Is_Overriding_Operation (Subp) then - null; - elsif Must_Override (Spec) then - if not Operator_Matches_Spec (Subp, Subp) then - Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); - - else + if Is_Overriding_Operation (Subp) then Set_Is_Overriding_Operation (Subp); + + elsif not Operator_Matches_Spec (Subp, Subp) then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; + + elsif not Error_Posted (Subp) + and then Style_Check + and then Operator_Matches_Spec (Subp, Subp) + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))) + then + Set_Is_Overriding_Operation (Subp); + Style.Missing_Overriding (Decl, Subp); end if; elsif Must_Override (Spec) then @@ -5251,13 +5268,9 @@ package body Sem_Ch6 is -- returns. This is true even if we are able to get away with -- having 'in out' parameters, which are normally illegal for -- functions. This formal is also needed when the function has - -- a tagged result, because generally such functions can be called - -- in a dispatching context and such calls must be handled like - -- calls to class-wide functions. + -- a tagged result. - if Controlled_Type (Result_Subt) - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) - then + if Needs_BIP_Final_List (E) then Discard := Add_Extra_Formal (E, RTE (RE_Finalizable_Ptr_Ptr), @@ -6481,7 +6494,7 @@ package body Sem_Ch6 is procedure Check_Private_Overriding (T : Entity_Id) is begin - if Ekind (Current_Scope) = E_Package + if Is_Package_Or_Generic_Package (Current_Scope) and then In_Private_Part (Current_Scope) and then Visible_Part_Type (T) and then not In_Instance @@ -6566,8 +6579,7 @@ package body Sem_Ch6 is elsif Current_Scope = Standard_Standard then null; - elsif ((Ekind (Current_Scope) = E_Package - or else Ekind (Current_Scope) = E_Generic_Package) + elsif (Is_Package_Or_Generic_Package (Current_Scope) and then not In_Package_Body (Current_Scope)) or else Is_Overriding then diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index ee3300bb938..ef9a6540b0c 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -847,10 +847,7 @@ package body Sem_Ch7 is Set_Is_Known_Non_Null (E, False); end if; - elsif Ekind (E) = E_Package - or else - Ekind (E) = E_Generic_Package - then + elsif Is_Package_Or_Generic_Package (E) then Clear_Constants (E, First_Entity (E)); Clear_Constants (E, First_Private_Entity (E)); end if; @@ -1145,8 +1142,7 @@ package body Sem_Ch7 is declare Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); begin - if (Ekind (Comp_Unit) = E_Package - or else Ekind (Comp_Unit) = E_Generic_Package) + if Is_Package_Or_Generic_Package (Comp_Unit) and then not In_Private_Part (Comp_Unit) and then not In_Instance then @@ -1308,8 +1304,7 @@ package body Sem_Ch7 is Set_Is_Pure (Id, PF); Init_Size_Align (Id); - if (Ekind (Current_Scope) /= E_Package - and then Ekind (Current_Scope) /= E_Generic_Package) + if not Is_Package_Or_Generic_Package (Current_Scope) or else In_Private_Part (Current_Scope) then Error_Msg_N ("invalid context for private declaration", N); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index c52f5ad7dcb..96eac0e1785 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1822,16 +1822,19 @@ package body Sem_Ch8 is -- Ada 2005: check overriding indicator - if Must_Override (Specification (N)) - and then not Is_Overriding_Operation (Rename_Spec) - then - Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); + if Is_Overriding_Operation (Rename_Spec) then + if Must_Not_Override (Specification (N)) then + Error_Msg_NE + ("subprogram& overrides inherited operation", + N, Rename_Spec); + elsif + Style_Check and then not Must_Override (Specification (N)) + then + Style.Missing_Overriding (N, Rename_Spec); + end if; - elsif Must_Not_Override (Specification (N)) - and then Is_Overriding_Operation (Rename_Spec) - then - Error_Msg_NE - ("subprogram& overrides inherited operation", N, Rename_Spec); + elsif Must_Override (Specification (N)) then + Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); end if; -- Normal subprogram renaming (not renaming as body) @@ -1965,9 +1968,11 @@ package body Sem_Ch8 is -- Most common case: subprogram renames subprogram. No body is generated -- in this case, so we must indicate the declaration is complete as is. + -- and inherit various attributes of the renamed subprogram. if No (Rename_Spec) then Set_Has_Completion (New_S); + Set_Is_Imported (New_S, Is_Imported (Entity (Nam))); Set_Is_Pure (New_S, Is_Pure (Entity (Nam))); Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam))); @@ -2933,9 +2938,8 @@ package body Sem_Ch8 is Error_Msg_N ("renamed generic unit must be a library unit", Name (N)); - elsif Ekind (Old_E) = E_Package - or else Ekind (Old_E) = E_Generic_Package - then + elsif Is_Package_Or_Generic_Package (Old_E) then + -- Inherit categorization flags New_E := Defining_Entity (N); @@ -6645,8 +6649,7 @@ package body Sem_Ch8 is then Full_Vis := True; - elsif (Ekind (S) = E_Package - or else Ekind (S) = E_Generic_Package) + elsif Is_Package_Or_Generic_Package (S) and then (In_Private_Part (S) or else In_Package_Body (S)) then @@ -7051,49 +7054,95 @@ package body Sem_Ch8 is -- as use visible. The analysis then reinstalls the spec along with -- its context. The use clause P.T is now recognized as redundant, -- but in the wrong context. Do not emit a warning in such cases. + -- Do not emit a warning either if we are in an instance, there + -- is no redundancy between an outer use_clause and one that appears + -- within the generic. and then not Spec_Reloaded_For_Body + and then not In_Instance then -- The type already has a use clause if In_Use (T) then + + -- Case where we know the current use clause for the type + if Present (Current_Use_Clause (T)) then - declare + Use_Clause_Known : declare Clause1 : constant Node_Id := Parent (Id); Clause2 : constant Node_Id := Current_Use_Clause (T); + Ent1 : Entity_Id; + Ent2 : Entity_Id; Err_No : Node_Id; Unit1 : Node_Id; Unit2 : Node_Id; + function Entity_Of_Unit (U : Node_Id) return Entity_Id; + -- Return the appropriate entity for determining which unit + -- has a deeper scope: the defining entity for U, unless U + -- is a package instance, in which case we retrieve the + -- entity of the instance spec. + + -------------------- + -- Entity_Of_Unit -- + -------------------- + + function Entity_Of_Unit (U : Node_Id) return Entity_Id is + begin + if Nkind (U) = N_Package_Instantiation + and then Analyzed (U) + then + return Defining_Entity (Instance_Spec (U)); + else + return Defining_Entity (U); + end if; + end Entity_Of_Unit; + + -- Start of processing for Use_Clause_Known + begin + -- If both current use type clause and the use type + -- clause for the type are at the compilation unit level, + -- one of the units must be an ancestor of the other, and + -- the warning belongs on the descendant. + if Nkind (Parent (Clause1)) = N_Compilation_Unit - and then Nkind (Parent (Clause2)) = N_Compilation_Unit + and then + Nkind (Parent (Clause2)) = N_Compilation_Unit then + Unit1 := Unit (Parent (Clause1)); + Unit2 := Unit (Parent (Clause2)); + -- There is a redundant use type clause in a child unit. -- Determine which of the units is more deeply nested. + -- If a unit is a package instance, retrieve the entity + -- and its scope from the instance spec. - Unit1 := Defining_Entity (Unit (Parent (Clause1))); - Unit2 := Defining_Entity (Unit (Parent (Clause2))); + Ent1 := Entity_Of_Unit (Unit1); + Ent2 := Entity_Of_Unit (Unit2); - if Scope (Unit2) = Standard_Standard then + if Scope (Ent2) = Standard_Standard then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); Err_No := Clause1; - elsif Scope (Unit1) = Standard_Standard then + elsif Scope (Ent1) = Standard_Standard then Error_Msg_Sloc := Sloc (Id); Err_No := Clause2; - else - -- Determine which is the descendant unit + -- If both units are child units, we determine which one + -- is the descendant by the scope distance to the + -- ultimate parent unit. + else declare S1, S2 : Entity_Id; begin - S1 := Scope (Unit1); - S2 := Scope (Unit2); + S1 := Scope (Ent1); + S2 := Scope (Ent2); while S1 /= Standard_Standard - and then S2 /= Standard_Standard + and then + S2 /= Standard_Standard loop S1 := Scope (S1); S2 := Scope (S2); @@ -7112,16 +7161,25 @@ package body Sem_Ch8 is Error_Msg_NE ("& is already use-visible through previous " & "use_type_clause #?", Err_No, Id); + + -- Case where current use type clause and the use type + -- clause for the type are not both at the compilation unit + -- level. In this case we don't have location information. + else Error_Msg_NE - ("& is already use-visible through previous use type " - & "clause?", Id, Id); + ("& is already use-visible through previous " + & "use type clause?", Id, Id); end if; - end; + end Use_Clause_Known; + + -- Here if Current_Use_Clause is not set for T, another case + -- where we do not have the location information available. + else Error_Msg_NE - ("& is already use-visible through previous use type " - & "clause?", Id, Id); + ("& is already use-visible through previous " + & "use type clause?", Id, Id); end if; -- The package where T is declared is already used diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index d8067915838..b9c1d13313c 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -378,11 +378,16 @@ package body Sem_Eval is -------------------------- function Compile_Time_Compare - (L, R : Node_Id; - Rec : Boolean := False) return Compare_Result + (L, R : Node_Id; + Assume_Valid : Boolean; + Rec : Boolean := False) return Compare_Result is - Ltyp : constant Entity_Id := Etype (L); - Rtyp : constant Entity_Id := Etype (R); + Ltyp : Entity_Id := Etype (L); + Rtyp : Entity_Id := Etype (R); + -- These get reset to the base type for the case of entities where + -- Is_Known_Valid is not set. This takes care of handling possible + -- invalid representations using the value of the base type, in + -- accordance with RM 13.9.1(10). procedure Compare_Decompose (N : Node_Id; @@ -739,6 +744,20 @@ package body Sem_Eval is return Unknown; end if; + -- Replace types by base types for the case of entities which are + -- not known to have valid representations. This takes care of + -- properly dealing with invalid representations. + + if not Assume_Valid then + if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then + Ltyp := Base_Type (Ltyp); + end if; + + if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then + Rtyp := Base_Type (Rtyp); + end if; + end if; + -- Here is where we check for comparisons against maximum bounds of -- types, where we know that no value can be outside the bounds of -- the subtype. Note that this routine is allowed to assume that all @@ -758,28 +777,32 @@ package body Sem_Eval is -- See if we can get a decisive check against one operand and -- a bound of the other operand (four possible tests here). - case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is + case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), + Assume_Valid, Rec => True) is when LT => return LT; when LE => return LE; when EQ => return LE; when others => null; end case; - case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is + case Compile_Time_Compare (L, Type_High_Bound (Rtyp), + Assume_Valid, Rec => True) is when GT => return GT; when GE => return GE; when EQ => return GE; when others => null; end case; - case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is + case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, + Assume_Valid, Rec => True) is when GT => return GT; when GE => return GE; when EQ => return GE; when others => null; end case; - case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is + case Compile_Time_Compare (Type_High_Bound (Ltyp), R, + Assume_Valid, Rec => True) is when LT => return LT; when LE => return LE; when EQ => return LE; @@ -998,14 +1021,17 @@ package body Sem_Eval is return False; end if; - -- If this is not a static expression and we are in configurable run - -- time mode, then we consider it not known at compile time. This - -- avoids anomalies where whether something is permitted with a given - -- configurable run-time library depends on how good the compiler is - -- at optimizing and knowing that things are constant when they - -- are non-static. + -- If this is not a static expression or a null literal, and we are in + -- configurable run-time mode, then we consider it not known at compile + -- time. This avoids anomalies where whether something is allowed with a + -- given configurable run-time library depends on how good the compiler + -- is at optimizing and knowing that things are constant when they are + -- nonstatic. - if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then + if Configurable_Run_Time_Mode + and then K /= N_Null + and then not Is_Static_Expression (Op) + then return False; end if; @@ -3482,9 +3508,10 @@ package body Sem_Eval is -------------------- function In_Subrange_Of - (T1 : Entity_Id; - T2 : Entity_Id; - Fixed_Int : Boolean := False) return Boolean + (T1 : Entity_Id; + T2 : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean := False) return Boolean is L1 : Node_Id; H1 : Node_Id; @@ -3511,9 +3538,9 @@ package body Sem_Eval is -- Check bounds to see if comparison possible at compile time - if Compile_Time_Compare (L1, L2) in Compare_GE + if Compile_Time_Compare (L1, L2, Assume_Valid) in Compare_GE and then - Compile_Time_Compare (H1, H2) in Compare_LE + Compile_Time_Compare (H1, H2, Assume_Valid) in Compare_LE then return True; end if; @@ -3763,10 +3790,10 @@ package body Sem_Eval is --------------------- function Is_Out_Of_Range - (N : Node_Id; - Typ : Entity_Id; - Fixed_Int : Boolean := False; - Int_Real : Boolean := False) return Boolean + (N : Node_Id; + Typ : Entity_Id; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean is Val : Uint; Valr : Ureal; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index f0dcd522b15..f294ed43337 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -43,7 +43,7 @@ package Sem_Eval is -- Handling of Static Expressions -- ------------------------------------ - -- This package contains a set of routine that process individual + -- This package contains a set of routines that process individual -- subexpression nodes with the objective of folding (precomputing) the -- value of static expressions that are known at compile time and properly -- computing the setting of two flags that appear in every subexpression @@ -133,16 +133,21 @@ package Sem_Eval is subtype Compare_GE is Compare_Result range EQ .. GE; subtype Compare_LE is Compare_Result range LT .. EQ; function Compile_Time_Compare - (L, R : Node_Id; - Rec : Boolean := False) return Compare_Result; + (L, R : Node_Id; + Assume_Valid : Boolean; + Rec : Boolean := False) return Compare_Result; -- Given two expression nodes, finds out whether it can be determined at -- compile time how the runtime values will compare. An Unknown result -- means that the result of a comparison cannot be determined at compile -- time, otherwise the returned result indicates the known result of the -- comparison, given as tightly as possible (i.e. EQ or LT is preferred - -- returned value to LE). Rec is a parameter that is set True for a - -- recursive call from within Compile_Time_Compare to avoid some infinite - -- recursion cases. It should never be set by a client. + -- returned value to LE). If Assume_Valid is true, the result reflects + -- the result of assuming that entities involved in the comparison have + -- valid representations. If Assume_Valid is false, then the base type of + -- any involved entity is used so that no assumption of validity is made. + -- Rec is a parameter that is set True for a recursive call from within + -- Compile_Time_Compare to avoid some infinite recursion cases. It should + -- never be set by a client. procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id); -- This procedure is called after it has been determined that Expr is not @@ -357,14 +362,17 @@ package Sem_Eval is -- and Fixed_Int are used as in routine Is_In_Range above. function In_Subrange_Of - (T1 : Entity_Id; - T2 : Entity_Id; - Fixed_Int : Boolean := False) return Boolean; + (T1 : Entity_Id; + T2 : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that the range of -- values for scalar type T1 are always in the range of scalar type T2. A -- result of False does not mean that T1 is not in T2's subrange, only that -- it cannot be determined at compile time. Flag Fixed_Int is used as in - -- routine Is_In_Range above. + -- routine Is_In_Range above. If Assume_Valid is true, the result reflects + -- the result of assuming that entities involved in the comparison have + -- valid representations. function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; -- Returns True if it can guarantee that Lo .. Hi is a null range. If it diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c1c661b08c0..e2d02aeef90 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1383,10 +1383,7 @@ package body Sem_Prag is -- the end of the package declarations (for details, see -- Analyze_Package_Specification.Analyze_PPCs). - if Ekind (Scope (S)) /= E_Package - and then - Ekind (Scope (S)) /= E_Generic_Package - then + if not Is_Package_Or_Generic_Package (Scope (S)) then Analyze_PPC_In_Decl_Part (N, S); end if; @@ -3539,8 +3536,7 @@ package body Sem_Prag is elsif (C = Convention_Java or else C = Convention_CIL) and then - (Ekind (Def_Id) = E_Package - or else Ekind (Def_Id) = E_Generic_Package + (Is_Package_Or_Generic_Package (Def_Id) or else Ekind (Def_Id) = E_Exception or else Nkind (Parent (Def_Id)) = N_Component_Declaration) then @@ -4307,9 +4303,7 @@ package body Sem_Prag is E : Entity_Id; In_Package_Spec : constant Boolean := - (Ekind (Current_Scope) = E_Package - or else - Ekind (Current_Scope) = E_Generic_Package) + Is_Package_Or_Generic_Package (Current_Scope) and then not In_Package_Body (Current_Scope); procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); @@ -5295,6 +5289,25 @@ package body Sem_Prag is Opt.Check_Policy_List := N; end Assertion_Policy; + ------------------------------ + -- Assume_No_Invalid_Values -- + ------------------------------ + + -- pragma Assume_No_Invalid_Values (On | Off); + + when Pragma_Assume_No_Invalid_Values => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + + if Chars (Expression (Arg1)) = Name_On then + Assume_No_Invalid_Values := True; + else + Assume_No_Invalid_Values := False; + end if; + --------------- -- AST_Entry -- --------------- @@ -6321,8 +6334,8 @@ package body Sem_Prag is -- pragma Discard_Names [([On =>] LOCAL_NAME)]; when Pragma_Discard_Names => Discard_Names : declare - E_Id : Entity_Id; E : Entity_Id; + E_Id : Entity_Id; begin Check_Ada_83_Warning; @@ -6352,6 +6365,7 @@ package body Sem_Prag is Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); + E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then @@ -6361,8 +6375,8 @@ package body Sem_Prag is end if; if (Is_First_Subtype (E) - and then (Is_Enumeration_Type (E) - or else Is_Tagged_Type (E))) + and then + (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then Set_Discard_Names (E); @@ -6370,6 +6384,7 @@ package body Sem_Prag is Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; + end if; end if; end Discard_Names; @@ -9069,9 +9084,11 @@ package body Sem_Prag is if Present (Ename) then -- If entity name matches, we are fine + -- Save entity in pragma argument, for ASIS use. if Chars (Ename) = Chars (Ent) then - null; + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); -- If entity name does not match, only possibility is an -- enumeration literal from an enumeration type declaration. @@ -9089,6 +9106,8 @@ package body Sem_Prag is "enumeration literal"); elsif Chars (Ent) = Chars (Ename) then + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); exit; else @@ -9215,9 +9234,7 @@ package body Sem_Prag is declare Ent : constant Entity_Id := Find_Lib_Unit_Name; begin - if Ekind (Ent) = E_Package - or else Ekind (Ent) = E_Generic_Package - then + if Is_Package_Or_Generic_Package (Ent) then Set_Obsolescent (Ent); return; end if; @@ -12204,6 +12221,7 @@ package body Sem_Prag is Pragma_Annotate => -1, Pragma_Assert => -1, Pragma_Assertion_Policy => 0, + Pragma_Assume_No_Invalid_Values => 0, Pragma_Asynchronous => -1, Pragma_Atomic => 0, Pragma_Atomic_Components => 0, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e1d042c92c2..83c3f4b21f2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4616,14 +4616,6 @@ package body Sem_Util is return Has_Preelaborable_Initialization (Base_Type (E)); end if; - -- Other private types never have preelaborable initialization - - if Is_Private_Type (E) then - return False; - end if; - - -- Here for all non-private view - -- All elementary types have preelaborable initialization if Is_Elementary_Type (E) then @@ -4643,6 +4635,13 @@ package body Sem_Util is elsif Is_Derived_Type (E) then + -- If the derived type is a private extension then it doesn't have + -- preelaborable initialization. + + if Ekind (Base_Type (E)) = E_Record_Type_With_Private then + return False; + end if; + -- First check whether ancestor type has preelaborable initialization Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); @@ -4663,6 +4662,13 @@ package body Sem_Util is Has_PE := False; end if; + -- Private types not derived from a type having preelaborable init and + -- that are not marked with pragma Preelaborable_Initialization do not + -- have preelaborable initialization. + + elsif Is_Private_Type (E) then + return False; + -- Record type has PI if it is non private and all components have PI elsif Is_Record_Type (E) then @@ -7031,11 +7037,8 @@ package body Sem_Util is -- If scope is a package, also clear current values of all -- private entities in the scope. - if Ekind (S) = E_Package - or else - Ekind (S) = E_Generic_Package - or else - Is_Concurrent_Type (S) + if Is_Package_Or_Generic_Package (S) + or else Is_Concurrent_Type (S) then Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); end if; @@ -8974,6 +8977,16 @@ package body Sem_Util is and then not Needs_Debug_Info (E) then Set_Debug_Info_Needed (E); + + -- For a private type, indicate that the full view also needs + -- debug information. + + if Is_Type (E) + and then Is_Private_Type (E) + and then Present (Full_View (E)) + then + Set_Debug_Info_Needed (Full_View (E)); + end if; end if; end Set_Debug_Info_Needed_If_Not_Set; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index c22d0ce475a..feb19ce5631 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1294,11 +1294,8 @@ package body Sem_Warn is or else (Ekind (E1) = E_Package and then - Ekind (Cunit_Entity (Current_Sem_Unit)) /= - E_Package - and then - Ekind (Cunit_Entity (Current_Sem_Unit)) /= - E_Generic_Package)) + not Is_Package_Or_Generic_Package + (Cunit_Entity (Current_Sem_Unit)))) -- Exclude instantiations, since there is no reason why every -- entity in an instantiation should be referenced. @@ -1432,7 +1429,7 @@ package body Sem_Warn is -- formal package, because the corresponding body is not analyzed. <<Continue>> - if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package) + if (Is_Package_Or_Generic_Package (E1) and then Nkind (Parent (E1)) = N_Package_Specification and then Nkind (Original_Node (Unit_Declaration_Node (E1))) diff --git a/gcc/ada/sinfo-cn.adb b/gcc/ada/sinfo-cn.adb index 14f6e11134f..2b4eaa2d961 100644 --- a/gcc/ada/sinfo-cn.adb +++ b/gcc/ada/sinfo-cn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index d038e4372a4..28656c0ad1d 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -179,6 +179,7 @@ package body Snames is "ada_05#" & "ada_2005#" & "assertion_policy#" & + "assume_no_invalid_values#" & "c_pass_by_copy#" & "check_name#" & "check_policy#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 8037ee18934..930d2886019 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -334,22 +334,23 @@ package Snames is Name_Ada_05 : constant Name_Id := N + 118; -- GNAT Name_Ada_2005 : constant Name_Id := N + 119; -- GNAT Name_Assertion_Policy : constant Name_Id := N + 120; -- Ada 05 - Name_C_Pass_By_Copy : constant Name_Id := N + 121; -- GNAT - Name_Check_Name : constant Name_Id := N + 122; -- GNAT - Name_Check_Policy : constant Name_Id := N + 123; -- GNAT - Name_Compile_Time_Error : constant Name_Id := N + 124; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 125; -- GNAT - Name_Compiler_Unit : constant Name_Id := N + 126; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 127; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 128; -- GNAT - Name_Debug_Policy : constant Name_Id := N + 129; -- GNAT - Name_Detect_Blocking : constant Name_Id := N + 130; -- Ada 05 - Name_Discard_Names : constant Name_Id := N + 131; - Name_Elaboration_Checks : constant Name_Id := N + 132; -- GNAT - Name_Eliminate : constant Name_Id := N + 133; -- GNAT - Name_Extend_System : constant Name_Id := N + 134; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 135; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 136; -- GNAT + Name_Assume_No_Invalid_Values : constant Name_Id := N + 121; -- GNAT + Name_C_Pass_By_Copy : constant Name_Id := N + 122; -- GNAT + Name_Check_Name : constant Name_Id := N + 123; -- GNAT + Name_Check_Policy : constant Name_Id := N + 124; -- GNAT + Name_Compile_Time_Error : constant Name_Id := N + 125; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 126; -- GNAT + Name_Compiler_Unit : constant Name_Id := N + 127; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 128; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 129; -- GNAT + Name_Debug_Policy : constant Name_Id := N + 130; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + 131; -- Ada 05 + Name_Discard_Names : constant Name_Id := N + 132; + Name_Elaboration_Checks : constant Name_Id := N + 133; -- GNAT + Name_Eliminate : constant Name_Id := N + 134; -- GNAT + Name_Extend_System : constant Name_Id := N + 135; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 136; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 137; -- GNAT -- Note: Fast_Math is not in this list because its name matches -- GNAT -- the name of the corresponding attribute. However, it is @@ -357,49 +358,49 @@ package Snames is -- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and -- correctly recognize and process Fast_Math. - Name_Favor_Top_Level : constant Name_Id := N + 137; -- GNAT - Name_Float_Representation : constant Name_Id := N + 138; -- GNAT - Name_Implicit_Packing : constant Name_Id := N + 139; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 140; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 141; -- GNAT - Name_License : constant Name_Id := N + 142; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 143; - Name_Long_Float : constant Name_Id := N + 144; -- VMS - Name_No_Run_Time : constant Name_Id := N + 145; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 146; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 147; - Name_Optimize_Alignment : constant Name_Id := N + 148; -- GNAT - Name_Persistent_BSS : constant Name_Id := N + 149; -- GNAT - Name_Polling : constant Name_Id := N + 150; -- GNAT - Name_Priority_Specific_Dispatching : constant Name_Id := N + 151; -- Ada 05 - Name_Profile : constant Name_Id := N + 152; -- Ada 05 - Name_Profile_Warnings : constant Name_Id := N + 153; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 154; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 155; - Name_Ravenscar : constant Name_Id := N + 156; -- GNAT - Name_Restricted_Run_Time : constant Name_Id := N + 157; -- GNAT - Name_Restrictions : constant Name_Id := N + 158; - Name_Restriction_Warnings : constant Name_Id := N + 159; -- GNAT - Name_Reviewable : constant Name_Id := N + 160; - Name_Source_File_Name : constant Name_Id := N + 161; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 162; -- GNAT - Name_Style_Checks : constant Name_Id := N + 163; -- GNAT - Name_Suppress : constant Name_Id := N + 164; - Name_Suppress_Exception_Locations : constant Name_Id := N + 165; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 166; - Name_Universal_Data : constant Name_Id := N + 167; -- AAMP - Name_Unsuppress : constant Name_Id := N + 168; -- Ada 05 - Name_Use_VADS_Size : constant Name_Id := N + 169; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 170; -- GNAT - Name_Warnings : constant Name_Id := N + 171; -- GNAT - Name_Wide_Character_Encoding : constant Name_Id := N + 172; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 172; + Name_Favor_Top_Level : constant Name_Id := N + 138; -- GNAT + Name_Float_Representation : constant Name_Id := N + 139; -- GNAT + Name_Implicit_Packing : constant Name_Id := N + 140; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 141; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 142; -- GNAT + Name_License : constant Name_Id := N + 143; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 144; + Name_Long_Float : constant Name_Id := N + 145; -- VMS + Name_No_Run_Time : constant Name_Id := N + 146; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 147; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 148; + Name_Optimize_Alignment : constant Name_Id := N + 149; -- GNAT + Name_Persistent_BSS : constant Name_Id := N + 150; -- GNAT + Name_Polling : constant Name_Id := N + 151; -- GNAT + Name_Priority_Specific_Dispatching : constant Name_Id := N + 152; -- Ada 05 + Name_Profile : constant Name_Id := N + 153; -- Ada 05 + Name_Profile_Warnings : constant Name_Id := N + 154; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 155; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 156; + Name_Ravenscar : constant Name_Id := N + 157; -- GNAT + Name_Restricted_Run_Time : constant Name_Id := N + 158; -- GNAT + Name_Restrictions : constant Name_Id := N + 159; + Name_Restriction_Warnings : constant Name_Id := N + 160; -- GNAT + Name_Reviewable : constant Name_Id := N + 161; + Name_Source_File_Name : constant Name_Id := N + 162; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 163; -- GNAT + Name_Style_Checks : constant Name_Id := N + 164; -- GNAT + Name_Suppress : constant Name_Id := N + 165; + Name_Suppress_Exception_Locations : constant Name_Id := N + 166; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 167; + Name_Universal_Data : constant Name_Id := N + 168; -- AAMP + Name_Unsuppress : constant Name_Id := N + 169; -- Ada 05 + Name_Use_VADS_Size : constant Name_Id := N + 170; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 171; -- GNAT + Name_Warnings : constant Name_Id := N + 172; -- GNAT + Name_Wide_Character_Encoding : constant Name_Id := N + 173; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 173; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 173; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 174; - Name_Annotate : constant Name_Id := N + 175; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 174; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 175; + Name_Annotate : constant Name_Id := N + 176; -- GNAT -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is @@ -407,83 +408,83 @@ package Snames is -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Name_AST_Entry. - Name_Assert : constant Name_Id := N + 176; -- Ada 05 - Name_Asynchronous : constant Name_Id := N + 177; - Name_Atomic : constant Name_Id := N + 178; - Name_Atomic_Components : constant Name_Id := N + 179; - Name_Attach_Handler : constant Name_Id := N + 180; - Name_Check : constant Name_Id := N + 181; -- GNAT - Name_CIL_Constructor : constant Name_Id := N + 182; -- GNAT - Name_Comment : constant Name_Id := N + 183; -- GNAT - Name_Common_Object : constant Name_Id := N + 184; -- GNAT - Name_Complete_Representation : constant Name_Id := N + 185; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 186; -- GNAT - Name_Controlled : constant Name_Id := N + 187; - Name_Convention : constant Name_Id := N + 188; - Name_CPP_Class : constant Name_Id := N + 189; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 190; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 191; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 192; -- GNAT - Name_Debug : constant Name_Id := N + 193; -- GNAT - Name_Elaborate : constant Name_Id := N + 194; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 195; - Name_Elaborate_Body : constant Name_Id := N + 196; - Name_Export : constant Name_Id := N + 197; - Name_Export_Exception : constant Name_Id := N + 198; -- VMS - Name_Export_Function : constant Name_Id := N + 199; -- GNAT - Name_Export_Object : constant Name_Id := N + 200; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 201; -- GNAT - Name_Export_Value : constant Name_Id := N + 202; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 203; -- GNAT - Name_External : constant Name_Id := N + 204; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 205; -- GNAT - Name_Ident : constant Name_Id := N + 206; -- VMS - Name_Implemented_By_Entry : constant Name_Id := N + 207; -- Ada 05 - Name_Import : constant Name_Id := N + 208; - Name_Import_Exception : constant Name_Id := N + 209; -- VMS - Name_Import_Function : constant Name_Id := N + 210; -- GNAT - Name_Import_Object : constant Name_Id := N + 211; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 212; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 213; -- GNAT - Name_Inline : constant Name_Id := N + 214; - Name_Inline_Always : constant Name_Id := N + 215; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 216; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 217; + Name_Assert : constant Name_Id := N + 177; -- Ada 05 + Name_Asynchronous : constant Name_Id := N + 178; + Name_Atomic : constant Name_Id := N + 179; + Name_Atomic_Components : constant Name_Id := N + 180; + Name_Attach_Handler : constant Name_Id := N + 181; + Name_Check : constant Name_Id := N + 182; -- GNAT + Name_CIL_Constructor : constant Name_Id := N + 183; -- GNAT + Name_Comment : constant Name_Id := N + 184; -- GNAT + Name_Common_Object : constant Name_Id := N + 185; -- GNAT + Name_Complete_Representation : constant Name_Id := N + 186; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 187; -- GNAT + Name_Controlled : constant Name_Id := N + 188; + Name_Convention : constant Name_Id := N + 189; + Name_CPP_Class : constant Name_Id := N + 190; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 191; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 192; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 193; -- GNAT + Name_Debug : constant Name_Id := N + 194; -- GNAT + Name_Elaborate : constant Name_Id := N + 195; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 196; + Name_Elaborate_Body : constant Name_Id := N + 197; + Name_Export : constant Name_Id := N + 198; + Name_Export_Exception : constant Name_Id := N + 199; -- VMS + Name_Export_Function : constant Name_Id := N + 200; -- GNAT + Name_Export_Object : constant Name_Id := N + 201; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 202; -- GNAT + Name_Export_Value : constant Name_Id := N + 203; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 204; -- GNAT + Name_External : constant Name_Id := N + 205; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 206; -- GNAT + Name_Ident : constant Name_Id := N + 207; -- VMS + Name_Implemented_By_Entry : constant Name_Id := N + 208; -- Ada 05 + Name_Import : constant Name_Id := N + 209; + Name_Import_Exception : constant Name_Id := N + 210; -- VMS + Name_Import_Function : constant Name_Id := N + 211; -- GNAT + Name_Import_Object : constant Name_Id := N + 212; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 213; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 214; -- GNAT + Name_Inline : constant Name_Id := N + 215; + Name_Inline_Always : constant Name_Id := N + 216; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 217; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 218; -- Note: Interface is not in this list because its name matches -- GNAT -- an Ada 2005 keyword. However it is included in the definition -- of the type Attribute_Id, and the functions Get_Pragma_Id and -- Is_Pragma_Id correctly recognize and process Name_Storage_Size. - Name_Interface_Name : constant Name_Id := N + 218; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 219; - Name_Interrupt_Priority : constant Name_Id := N + 220; - Name_Java_Constructor : constant Name_Id := N + 221; -- GNAT - Name_Java_Interface : constant Name_Id := N + 222; -- GNAT - Name_Keep_Names : constant Name_Id := N + 223; -- GNAT - Name_Link_With : constant Name_Id := N + 224; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 225; -- GNAT - Name_Linker_Constructor : constant Name_Id := N + 226; -- GNAT - Name_Linker_Destructor : constant Name_Id := N + 227; -- GNAT - Name_Linker_Options : constant Name_Id := N + 228; - Name_Linker_Section : constant Name_Id := N + 229; -- GNAT - Name_List : constant Name_Id := N + 230; - Name_Machine_Attribute : constant Name_Id := N + 231; -- GNAT - Name_Main : constant Name_Id := N + 232; -- GNAT - Name_Main_Storage : constant Name_Id := N + 233; -- GNAT - Name_Memory_Size : constant Name_Id := N + 234; -- Ada 83 - Name_No_Body : constant Name_Id := N + 235; -- GNAT - Name_No_Return : constant Name_Id := N + 236; -- GNAT - Name_Obsolescent : constant Name_Id := N + 237; -- GNAT - Name_Optimize : constant Name_Id := N + 238; - Name_Pack : constant Name_Id := N + 239; - Name_Page : constant Name_Id := N + 240; - Name_Passive : constant Name_Id := N + 241; -- GNAT - Name_Postcondition : constant Name_Id := N + 242; -- GNAT - Name_Precondition : constant Name_Id := N + 243; -- GNAT - Name_Preelaborable_Initialization : constant Name_Id := N + 244; -- Ada 05 - Name_Preelaborate : constant Name_Id := N + 245; - Name_Preelaborate_05 : constant Name_Id := N + 246; -- GNAT + Name_Interface_Name : constant Name_Id := N + 219; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 220; + Name_Interrupt_Priority : constant Name_Id := N + 221; + Name_Java_Constructor : constant Name_Id := N + 222; -- GNAT + Name_Java_Interface : constant Name_Id := N + 223; -- GNAT + Name_Keep_Names : constant Name_Id := N + 224; -- GNAT + Name_Link_With : constant Name_Id := N + 225; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 226; -- GNAT + Name_Linker_Constructor : constant Name_Id := N + 227; -- GNAT + Name_Linker_Destructor : constant Name_Id := N + 228; -- GNAT + Name_Linker_Options : constant Name_Id := N + 229; + Name_Linker_Section : constant Name_Id := N + 230; -- GNAT + Name_List : constant Name_Id := N + 231; + Name_Machine_Attribute : constant Name_Id := N + 232; -- GNAT + Name_Main : constant Name_Id := N + 233; -- GNAT + Name_Main_Storage : constant Name_Id := N + 234; -- GNAT + Name_Memory_Size : constant Name_Id := N + 235; -- Ada 83 + Name_No_Body : constant Name_Id := N + 236; -- GNAT + Name_No_Return : constant Name_Id := N + 237; -- GNAT + Name_Obsolescent : constant Name_Id := N + 238; -- GNAT + Name_Optimize : constant Name_Id := N + 239; + Name_Pack : constant Name_Id := N + 240; + Name_Page : constant Name_Id := N + 241; + Name_Passive : constant Name_Id := N + 242; -- GNAT + Name_Postcondition : constant Name_Id := N + 243; -- GNAT + Name_Precondition : constant Name_Id := N + 244; -- GNAT + Name_Preelaborable_Initialization : constant Name_Id := N + 245; -- Ada 05 + Name_Preelaborate : constant Name_Id := N + 246; + Name_Preelaborate_05 : constant Name_Id := N + 247; -- GNAT -- Note: Priority is not in this list because its name matches -- the name of the corresponding attribute. However, it is @@ -491,16 +492,16 @@ package Snames is -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Priority. Priority is a standard Ada 95 pragma. - Name_Psect_Object : constant Name_Id := N + 247; -- VMS - Name_Pure : constant Name_Id := N + 248; - Name_Pure_05 : constant Name_Id := N + 249; -- GNAT - Name_Pure_Function : constant Name_Id := N + 250; -- GNAT - Name_Relative_Deadline : constant Name_Id := N + 251; -- Ada 05 - Name_Remote_Call_Interface : constant Name_Id := N + 252; - Name_Remote_Types : constant Name_Id := N + 253; - Name_Share_Generic : constant Name_Id := N + 254; -- GNAT - Name_Shared : constant Name_Id := N + 255; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 256; + Name_Psect_Object : constant Name_Id := N + 248; -- VMS + Name_Pure : constant Name_Id := N + 249; + Name_Pure_05 : constant Name_Id := N + 250; -- GNAT + Name_Pure_Function : constant Name_Id := N + 251; -- GNAT + Name_Relative_Deadline : constant Name_Id := N + 252; -- Ada 05 + Name_Remote_Call_Interface : constant Name_Id := N + 253; + Name_Remote_Types : constant Name_Id := N + 254; + Name_Share_Generic : constant Name_Id := N + 255; -- GNAT + Name_Shared : constant Name_Id := N + 256; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 257; -- Note: Storage_Size is not in this list because its name -- matches the name of the corresponding attribute. However, @@ -511,30 +512,30 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because -- of a clash with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 257; -- GNAT - Name_Static_Elaboration_Desired : constant Name_Id := N + 258; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 259; -- GNAT - Name_Subtitle : constant Name_Id := N + 260; -- GNAT - Name_Suppress_All : constant Name_Id := N + 261; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 262; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 263; -- GNAT - Name_System_Name : constant Name_Id := N + 264; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 265; -- GNAT - Name_Task_Name : constant Name_Id := N + 266; -- GNAT - Name_Task_Storage : constant Name_Id := N + 267; -- VMS - Name_Time_Slice : constant Name_Id := N + 268; -- GNAT - Name_Title : constant Name_Id := N + 269; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 270; -- Ada 05 - Name_Unimplemented_Unit : constant Name_Id := N + 271; -- GNAT - Name_Universal_Aliasing : constant Name_Id := N + 272; -- GNAT - Name_Unmodified : constant Name_Id := N + 273; -- GNAT - Name_Unreferenced : constant Name_Id := N + 274; -- GNAT - Name_Unreferenced_Objects : constant Name_Id := N + 275; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 276; -- GNAT - Name_Volatile : constant Name_Id := N + 277; - Name_Volatile_Components : constant Name_Id := N + 278; - Name_Weak_External : constant Name_Id := N + 279; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 279; + Name_Source_Reference : constant Name_Id := N + 258; -- GNAT + Name_Static_Elaboration_Desired : constant Name_Id := N + 259; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 260; -- GNAT + Name_Subtitle : constant Name_Id := N + 261; -- GNAT + Name_Suppress_All : constant Name_Id := N + 262; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 263; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 264; -- GNAT + Name_System_Name : constant Name_Id := N + 265; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 266; -- GNAT + Name_Task_Name : constant Name_Id := N + 267; -- GNAT + Name_Task_Storage : constant Name_Id := N + 268; -- VMS + Name_Time_Slice : constant Name_Id := N + 269; -- GNAT + Name_Title : constant Name_Id := N + 270; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 271; -- Ada 05 + Name_Unimplemented_Unit : constant Name_Id := N + 272; -- GNAT + Name_Universal_Aliasing : constant Name_Id := N + 273; -- GNAT + Name_Unmodified : constant Name_Id := N + 274; -- GNAT + Name_Unreferenced : constant Name_Id := N + 275; -- GNAT + Name_Unreferenced_Objects : constant Name_Id := N + 276; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 277; -- GNAT + Name_Volatile : constant Name_Id := N + 278; + Name_Volatile_Components : constant Name_Id := N + 279; + Name_Weak_External : constant Name_Id := N + 280; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 280; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -545,120 +546,120 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 280; - Name_Ada : constant Name_Id := N + 280; - Name_Assembler : constant Name_Id := N + 281; - Name_CIL : constant Name_Id := N + 282; - Name_COBOL : constant Name_Id := N + 283; - Name_CPP : constant Name_Id := N + 284; - Name_Fortran : constant Name_Id := N + 285; - Name_Intrinsic : constant Name_Id := N + 286; - Name_Java : constant Name_Id := N + 287; - Name_Stdcall : constant Name_Id := N + 288; - Name_Stubbed : constant Name_Id := N + 289; - Last_Convention_Name : constant Name_Id := N + 289; + First_Convention_Name : constant Name_Id := N + 281; + Name_Ada : constant Name_Id := N + 281; + Name_Assembler : constant Name_Id := N + 282; + Name_CIL : constant Name_Id := N + 283; + Name_COBOL : constant Name_Id := N + 284; + Name_CPP : constant Name_Id := N + 285; + Name_Fortran : constant Name_Id := N + 286; + Name_Intrinsic : constant Name_Id := N + 287; + Name_Java : constant Name_Id := N + 288; + Name_Stdcall : constant Name_Id := N + 289; + Name_Stubbed : constant Name_Id := N + 290; + Last_Convention_Name : constant Name_Id := N + 290; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 290; - Name_Assembly : constant Name_Id := N + 291; + Name_Asm : constant Name_Id := N + 291; + Name_Assembly : constant Name_Id := N + 292; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 292; + Name_Default : constant Name_Id := N + 293; -- Name_External (previously defined as pragma) -- The following names are preset as synonyms for CPP - Name_C_Plus_Plus : constant Name_Id := N + 293; + Name_C_Plus_Plus : constant Name_Id := N + 294; -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 294; - Name_Win32 : constant Name_Id := N + 295; + Name_DLL : constant Name_Id := N + 295; + Name_Win32 : constant Name_Id := N + 296; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 296; - Name_Assertion : constant Name_Id := N + 297; - Name_Attribute_Name : constant Name_Id := N + 298; - Name_Body_File_Name : constant Name_Id := N + 299; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 300; - Name_Casing : constant Name_Id := N + 301; - Name_Code : constant Name_Id := N + 302; - Name_Component : constant Name_Id := N + 303; - Name_Component_Size_4 : constant Name_Id := N + 304; - Name_Copy : constant Name_Id := N + 305; - Name_D_Float : constant Name_Id := N + 306; - Name_Descriptor : constant Name_Id := N + 307; - Name_Dot_Replacement : constant Name_Id := N + 308; - Name_Dynamic : constant Name_Id := N + 309; - Name_Entity : constant Name_Id := N + 310; - Name_Entry_Count : constant Name_Id := N + 311; - Name_External_Name : constant Name_Id := N + 312; - Name_First_Optional_Parameter : constant Name_Id := N + 313; - Name_Form : constant Name_Id := N + 314; - Name_G_Float : constant Name_Id := N + 315; - Name_Gcc : constant Name_Id := N + 316; - Name_Gnat : constant Name_Id := N + 317; - Name_GPL : constant Name_Id := N + 318; - Name_IEEE_Float : constant Name_Id := N + 319; - Name_Ignore : constant Name_Id := N + 320; - Name_Info : constant Name_Id := N + 321; - Name_Internal : constant Name_Id := N + 322; - Name_Link_Name : constant Name_Id := N + 323; - Name_Lowercase : constant Name_Id := N + 324; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 325; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 326; - Name_Max_Size : constant Name_Id := N + 327; - Name_Mechanism : constant Name_Id := N + 328; - Name_Message : constant Name_Id := N + 329; - Name_Mixedcase : constant Name_Id := N + 330; - Name_Modified_GPL : constant Name_Id := N + 331; - Name_Name : constant Name_Id := N + 332; - Name_NCA : constant Name_Id := N + 333; - Name_No : constant Name_Id := N + 334; - Name_No_Dependence : constant Name_Id := N + 335; - Name_No_Dynamic_Attachment : constant Name_Id := N + 336; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 337; - Name_No_Requeue : constant Name_Id := N + 338; - Name_No_Requeue_Statements : constant Name_Id := N + 339; - Name_No_Task_Attributes : constant Name_Id := N + 340; - Name_No_Task_Attributes_Package : constant Name_Id := N + 341; - Name_On : constant Name_Id := N + 342; - Name_Parameter_Types : constant Name_Id := N + 343; - Name_Reference : constant Name_Id := N + 344; - Name_Restricted : constant Name_Id := N + 345; - Name_Result_Mechanism : constant Name_Id := N + 346; - Name_Result_Type : constant Name_Id := N + 347; - Name_Runtime : constant Name_Id := N + 348; - Name_SB : constant Name_Id := N + 349; - Name_Secondary_Stack_Size : constant Name_Id := N + 350; - Name_Section : constant Name_Id := N + 351; - Name_Semaphore : constant Name_Id := N + 352; - Name_Short_Descriptor : constant Name_Id := N + 353; - Name_Simple_Barriers : constant Name_Id := N + 354; - Name_Spec_File_Name : constant Name_Id := N + 355; - Name_State : constant Name_Id := N + 356; - Name_Static : constant Name_Id := N + 357; - Name_Stack_Size : constant Name_Id := N + 358; - Name_Subunit_File_Name : constant Name_Id := N + 359; - Name_Task_Stack_Size_Default : constant Name_Id := N + 360; - Name_Task_Type : constant Name_Id := N + 361; - Name_Time_Slicing_Enabled : constant Name_Id := N + 362; - Name_Top_Guard : constant Name_Id := N + 363; - Name_UBA : constant Name_Id := N + 364; - Name_UBS : constant Name_Id := N + 365; - Name_UBSB : constant Name_Id := N + 366; - Name_Unit_Name : constant Name_Id := N + 367; - Name_Unknown : constant Name_Id := N + 368; - Name_Unrestricted : constant Name_Id := N + 369; - Name_Uppercase : constant Name_Id := N + 370; - Name_User : constant Name_Id := N + 371; - Name_VAX_Float : constant Name_Id := N + 372; - Name_VMS : constant Name_Id := N + 373; - Name_Vtable_Ptr : constant Name_Id := N + 374; - Name_Working_Storage : constant Name_Id := N + 375; + Name_As_Is : constant Name_Id := N + 297; + Name_Assertion : constant Name_Id := N + 298; + Name_Attribute_Name : constant Name_Id := N + 299; + Name_Body_File_Name : constant Name_Id := N + 300; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 301; + Name_Casing : constant Name_Id := N + 302; + Name_Code : constant Name_Id := N + 303; + Name_Component : constant Name_Id := N + 304; + Name_Component_Size_4 : constant Name_Id := N + 305; + Name_Copy : constant Name_Id := N + 306; + Name_D_Float : constant Name_Id := N + 307; + Name_Descriptor : constant Name_Id := N + 308; + Name_Dot_Replacement : constant Name_Id := N + 309; + Name_Dynamic : constant Name_Id := N + 310; + Name_Entity : constant Name_Id := N + 311; + Name_Entry_Count : constant Name_Id := N + 312; + Name_External_Name : constant Name_Id := N + 313; + Name_First_Optional_Parameter : constant Name_Id := N + 314; + Name_Form : constant Name_Id := N + 315; + Name_G_Float : constant Name_Id := N + 316; + Name_Gcc : constant Name_Id := N + 317; + Name_Gnat : constant Name_Id := N + 318; + Name_GPL : constant Name_Id := N + 319; + Name_IEEE_Float : constant Name_Id := N + 320; + Name_Ignore : constant Name_Id := N + 321; + Name_Info : constant Name_Id := N + 322; + Name_Internal : constant Name_Id := N + 323; + Name_Link_Name : constant Name_Id := N + 324; + Name_Lowercase : constant Name_Id := N + 325; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 326; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 327; + Name_Max_Size : constant Name_Id := N + 328; + Name_Mechanism : constant Name_Id := N + 329; + Name_Message : constant Name_Id := N + 330; + Name_Mixedcase : constant Name_Id := N + 331; + Name_Modified_GPL : constant Name_Id := N + 332; + Name_Name : constant Name_Id := N + 333; + Name_NCA : constant Name_Id := N + 334; + Name_No : constant Name_Id := N + 335; + Name_No_Dependence : constant Name_Id := N + 336; + Name_No_Dynamic_Attachment : constant Name_Id := N + 337; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 338; + Name_No_Requeue : constant Name_Id := N + 339; + Name_No_Requeue_Statements : constant Name_Id := N + 340; + Name_No_Task_Attributes : constant Name_Id := N + 341; + Name_No_Task_Attributes_Package : constant Name_Id := N + 342; + Name_On : constant Name_Id := N + 343; + Name_Parameter_Types : constant Name_Id := N + 344; + Name_Reference : constant Name_Id := N + 345; + Name_Restricted : constant Name_Id := N + 346; + Name_Result_Mechanism : constant Name_Id := N + 347; + Name_Result_Type : constant Name_Id := N + 348; + Name_Runtime : constant Name_Id := N + 349; + Name_SB : constant Name_Id := N + 350; + Name_Secondary_Stack_Size : constant Name_Id := N + 351; + Name_Section : constant Name_Id := N + 352; + Name_Semaphore : constant Name_Id := N + 353; + Name_Short_Descriptor : constant Name_Id := N + 354; + Name_Simple_Barriers : constant Name_Id := N + 355; + Name_Spec_File_Name : constant Name_Id := N + 356; + Name_State : constant Name_Id := N + 357; + Name_Static : constant Name_Id := N + 358; + Name_Stack_Size : constant Name_Id := N + 359; + Name_Subunit_File_Name : constant Name_Id := N + 360; + Name_Task_Stack_Size_Default : constant Name_Id := N + 361; + Name_Task_Type : constant Name_Id := N + 362; + Name_Time_Slicing_Enabled : constant Name_Id := N + 363; + Name_Top_Guard : constant Name_Id := N + 364; + Name_UBA : constant Name_Id := N + 365; + Name_UBS : constant Name_Id := N + 366; + Name_UBSB : constant Name_Id := N + 367; + Name_Unit_Name : constant Name_Id := N + 368; + Name_Unknown : constant Name_Id := N + 369; + Name_Unrestricted : constant Name_Id := N + 370; + Name_Uppercase : constant Name_Id := N + 371; + Name_User : constant Name_Id := N + 372; + Name_VAX_Float : constant Name_Id := N + 373; + Name_VMS : constant Name_Id := N + 374; + Name_Vtable_Ptr : constant Name_Id := N + 375; + Name_Working_Storage : constant Name_Id := N + 376; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -672,178 +673,178 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 376; - Name_Abort_Signal : constant Name_Id := N + 376; -- GNAT - Name_Access : constant Name_Id := N + 377; - Name_Address : constant Name_Id := N + 378; - Name_Address_Size : constant Name_Id := N + 379; -- GNAT - Name_Aft : constant Name_Id := N + 380; - Name_Alignment : constant Name_Id := N + 381; - Name_Asm_Input : constant Name_Id := N + 382; -- GNAT - Name_Asm_Output : constant Name_Id := N + 383; -- GNAT - Name_AST_Entry : constant Name_Id := N + 384; -- VMS - Name_Bit : constant Name_Id := N + 385; -- GNAT - Name_Bit_Order : constant Name_Id := N + 386; - Name_Bit_Position : constant Name_Id := N + 387; -- GNAT - Name_Body_Version : constant Name_Id := N + 388; - Name_Callable : constant Name_Id := N + 389; - Name_Caller : constant Name_Id := N + 390; - Name_Code_Address : constant Name_Id := N + 391; -- GNAT - Name_Component_Size : constant Name_Id := N + 392; - Name_Compose : constant Name_Id := N + 393; - Name_Constrained : constant Name_Id := N + 394; - Name_Count : constant Name_Id := N + 395; - Name_Default_Bit_Order : constant Name_Id := N + 396; -- GNAT - Name_Definite : constant Name_Id := N + 397; - Name_Delta : constant Name_Id := N + 398; - Name_Denorm : constant Name_Id := N + 399; - Name_Digits : constant Name_Id := N + 400; - Name_Elaborated : constant Name_Id := N + 401; -- GNAT - Name_Emax : constant Name_Id := N + 402; -- Ada 83 - Name_Enabled : constant Name_Id := N + 403; -- GNAT - Name_Enum_Rep : constant Name_Id := N + 404; -- GNAT - Name_Enum_Val : constant Name_Id := N + 405; -- GNAT - Name_Epsilon : constant Name_Id := N + 406; -- Ada 83 - Name_Exponent : constant Name_Id := N + 407; - Name_External_Tag : constant Name_Id := N + 408; - Name_Fast_Math : constant Name_Id := N + 409; -- GNAT - Name_First : constant Name_Id := N + 410; - Name_First_Bit : constant Name_Id := N + 411; - Name_Fixed_Value : constant Name_Id := N + 412; -- GNAT - Name_Fore : constant Name_Id := N + 413; - Name_Has_Access_Values : constant Name_Id := N + 414; -- GNAT - Name_Has_Discriminants : constant Name_Id := N + 415; -- GNAT - Name_Has_Tagged_Values : constant Name_Id := N + 416; -- GNAT - Name_Identity : constant Name_Id := N + 417; - Name_Img : constant Name_Id := N + 418; -- GNAT - Name_Integer_Value : constant Name_Id := N + 419; -- GNAT - Name_Invalid_Value : constant Name_Id := N + 420; -- GNAT - Name_Large : constant Name_Id := N + 421; -- Ada 83 - Name_Last : constant Name_Id := N + 422; - Name_Last_Bit : constant Name_Id := N + 423; - Name_Leading_Part : constant Name_Id := N + 424; - Name_Length : constant Name_Id := N + 425; - Name_Machine_Emax : constant Name_Id := N + 426; - Name_Machine_Emin : constant Name_Id := N + 427; - Name_Machine_Mantissa : constant Name_Id := N + 428; - Name_Machine_Overflows : constant Name_Id := N + 429; - Name_Machine_Radix : constant Name_Id := N + 430; - Name_Machine_Rounding : constant Name_Id := N + 431; -- Ada 05 - Name_Machine_Rounds : constant Name_Id := N + 432; - Name_Machine_Size : constant Name_Id := N + 433; -- GNAT - Name_Mantissa : constant Name_Id := N + 434; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 435; - Name_Maximum_Alignment : constant Name_Id := N + 436; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 437; -- GNAT - Name_Mod : constant Name_Id := N + 438; -- Ada 05 - Name_Model_Emin : constant Name_Id := N + 439; - Name_Model_Epsilon : constant Name_Id := N + 440; - Name_Model_Mantissa : constant Name_Id := N + 441; - Name_Model_Small : constant Name_Id := N + 442; - Name_Modulus : constant Name_Id := N + 443; - Name_Null_Parameter : constant Name_Id := N + 444; -- GNAT - Name_Object_Size : constant Name_Id := N + 445; -- GNAT - Name_Old : constant Name_Id := N + 446; -- GNAT - Name_Partition_ID : constant Name_Id := N + 447; - Name_Passed_By_Reference : constant Name_Id := N + 448; -- GNAT - Name_Pool_Address : constant Name_Id := N + 449; - Name_Pos : constant Name_Id := N + 450; - Name_Position : constant Name_Id := N + 451; - Name_Priority : constant Name_Id := N + 452; -- Ada 05 - Name_Range : constant Name_Id := N + 453; - Name_Range_Length : constant Name_Id := N + 454; -- GNAT - Name_Result : constant Name_Id := N + 455; -- GNAT - Name_Round : constant Name_Id := N + 456; - Name_Safe_Emax : constant Name_Id := N + 457; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 458; - Name_Safe_Large : constant Name_Id := N + 459; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 460; - Name_Safe_Small : constant Name_Id := N + 461; -- Ada 83 - Name_Scale : constant Name_Id := N + 462; - Name_Scaling : constant Name_Id := N + 463; - Name_Signed_Zeros : constant Name_Id := N + 464; - Name_Size : constant Name_Id := N + 465; - Name_Small : constant Name_Id := N + 466; - Name_Storage_Size : constant Name_Id := N + 467; - Name_Storage_Unit : constant Name_Id := N + 468; -- GNAT - Name_Stream_Size : constant Name_Id := N + 469; -- Ada 05 - Name_Tag : constant Name_Id := N + 470; - Name_Target_Name : constant Name_Id := N + 471; -- GNAT - Name_Terminated : constant Name_Id := N + 472; - Name_To_Address : constant Name_Id := N + 473; -- GNAT - Name_Type_Class : constant Name_Id := N + 474; -- GNAT - Name_UET_Address : constant Name_Id := N + 475; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 476; - Name_Unchecked_Access : constant Name_Id := N + 477; - Name_Unconstrained_Array : constant Name_Id := N + 478; - Name_Universal_Literal_String : constant Name_Id := N + 479; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 480; -- GNAT - Name_VADS_Size : constant Name_Id := N + 481; -- GNAT - Name_Val : constant Name_Id := N + 482; - Name_Valid : constant Name_Id := N + 483; - Name_Value_Size : constant Name_Id := N + 484; -- GNAT - Name_Version : constant Name_Id := N + 485; - Name_Wchar_T_Size : constant Name_Id := N + 486; -- GNAT - Name_Wide_Wide_Width : constant Name_Id := N + 487; -- Ada 05 - Name_Wide_Width : constant Name_Id := N + 488; - Name_Width : constant Name_Id := N + 489; - Name_Word_Size : constant Name_Id := N + 490; -- GNAT + First_Attribute_Name : constant Name_Id := N + 377; + Name_Abort_Signal : constant Name_Id := N + 377; -- GNAT + Name_Access : constant Name_Id := N + 378; + Name_Address : constant Name_Id := N + 379; + Name_Address_Size : constant Name_Id := N + 380; -- GNAT + Name_Aft : constant Name_Id := N + 381; + Name_Alignment : constant Name_Id := N + 382; + Name_Asm_Input : constant Name_Id := N + 383; -- GNAT + Name_Asm_Output : constant Name_Id := N + 384; -- GNAT + Name_AST_Entry : constant Name_Id := N + 385; -- VMS + Name_Bit : constant Name_Id := N + 386; -- GNAT + Name_Bit_Order : constant Name_Id := N + 387; + Name_Bit_Position : constant Name_Id := N + 388; -- GNAT + Name_Body_Version : constant Name_Id := N + 389; + Name_Callable : constant Name_Id := N + 390; + Name_Caller : constant Name_Id := N + 391; + Name_Code_Address : constant Name_Id := N + 392; -- GNAT + Name_Component_Size : constant Name_Id := N + 393; + Name_Compose : constant Name_Id := N + 394; + Name_Constrained : constant Name_Id := N + 395; + Name_Count : constant Name_Id := N + 396; + Name_Default_Bit_Order : constant Name_Id := N + 397; -- GNAT + Name_Definite : constant Name_Id := N + 398; + Name_Delta : constant Name_Id := N + 399; + Name_Denorm : constant Name_Id := N + 400; + Name_Digits : constant Name_Id := N + 401; + Name_Elaborated : constant Name_Id := N + 402; -- GNAT + Name_Emax : constant Name_Id := N + 403; -- Ada 83 + Name_Enabled : constant Name_Id := N + 404; -- GNAT + Name_Enum_Rep : constant Name_Id := N + 405; -- GNAT + Name_Enum_Val : constant Name_Id := N + 406; -- GNAT + Name_Epsilon : constant Name_Id := N + 407; -- Ada 83 + Name_Exponent : constant Name_Id := N + 408; + Name_External_Tag : constant Name_Id := N + 409; + Name_Fast_Math : constant Name_Id := N + 410; -- GNAT + Name_First : constant Name_Id := N + 411; + Name_First_Bit : constant Name_Id := N + 412; + Name_Fixed_Value : constant Name_Id := N + 413; -- GNAT + Name_Fore : constant Name_Id := N + 414; + Name_Has_Access_Values : constant Name_Id := N + 415; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + 416; -- GNAT + Name_Has_Tagged_Values : constant Name_Id := N + 417; -- GNAT + Name_Identity : constant Name_Id := N + 418; + Name_Img : constant Name_Id := N + 419; -- GNAT + Name_Integer_Value : constant Name_Id := N + 420; -- GNAT + Name_Invalid_Value : constant Name_Id := N + 421; -- GNAT + Name_Large : constant Name_Id := N + 422; -- Ada 83 + Name_Last : constant Name_Id := N + 423; + Name_Last_Bit : constant Name_Id := N + 424; + Name_Leading_Part : constant Name_Id := N + 425; + Name_Length : constant Name_Id := N + 426; + Name_Machine_Emax : constant Name_Id := N + 427; + Name_Machine_Emin : constant Name_Id := N + 428; + Name_Machine_Mantissa : constant Name_Id := N + 429; + Name_Machine_Overflows : constant Name_Id := N + 430; + Name_Machine_Radix : constant Name_Id := N + 431; + Name_Machine_Rounding : constant Name_Id := N + 432; -- Ada 05 + Name_Machine_Rounds : constant Name_Id := N + 433; + Name_Machine_Size : constant Name_Id := N + 434; -- GNAT + Name_Mantissa : constant Name_Id := N + 435; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 436; + Name_Maximum_Alignment : constant Name_Id := N + 437; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 438; -- GNAT + Name_Mod : constant Name_Id := N + 439; -- Ada 05 + Name_Model_Emin : constant Name_Id := N + 440; + Name_Model_Epsilon : constant Name_Id := N + 441; + Name_Model_Mantissa : constant Name_Id := N + 442; + Name_Model_Small : constant Name_Id := N + 443; + Name_Modulus : constant Name_Id := N + 444; + Name_Null_Parameter : constant Name_Id := N + 445; -- GNAT + Name_Object_Size : constant Name_Id := N + 446; -- GNAT + Name_Old : constant Name_Id := N + 447; -- GNAT + Name_Partition_ID : constant Name_Id := N + 448; + Name_Passed_By_Reference : constant Name_Id := N + 449; -- GNAT + Name_Pool_Address : constant Name_Id := N + 450; + Name_Pos : constant Name_Id := N + 451; + Name_Position : constant Name_Id := N + 452; + Name_Priority : constant Name_Id := N + 453; -- Ada 05 + Name_Range : constant Name_Id := N + 454; + Name_Range_Length : constant Name_Id := N + 455; -- GNAT + Name_Result : constant Name_Id := N + 456; -- GNAT + Name_Round : constant Name_Id := N + 457; + Name_Safe_Emax : constant Name_Id := N + 458; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 459; + Name_Safe_Large : constant Name_Id := N + 460; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 461; + Name_Safe_Small : constant Name_Id := N + 462; -- Ada 83 + Name_Scale : constant Name_Id := N + 463; + Name_Scaling : constant Name_Id := N + 464; + Name_Signed_Zeros : constant Name_Id := N + 465; + Name_Size : constant Name_Id := N + 466; + Name_Small : constant Name_Id := N + 467; + Name_Storage_Size : constant Name_Id := N + 468; + Name_Storage_Unit : constant Name_Id := N + 469; -- GNAT + Name_Stream_Size : constant Name_Id := N + 470; -- Ada 05 + Name_Tag : constant Name_Id := N + 471; + Name_Target_Name : constant Name_Id := N + 472; -- GNAT + Name_Terminated : constant Name_Id := N + 473; + Name_To_Address : constant Name_Id := N + 474; -- GNAT + Name_Type_Class : constant Name_Id := N + 475; -- GNAT + Name_UET_Address : constant Name_Id := N + 476; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 477; + Name_Unchecked_Access : constant Name_Id := N + 478; + Name_Unconstrained_Array : constant Name_Id := N + 479; + Name_Universal_Literal_String : constant Name_Id := N + 480; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 481; -- GNAT + Name_VADS_Size : constant Name_Id := N + 482; -- GNAT + Name_Val : constant Name_Id := N + 483; + Name_Valid : constant Name_Id := N + 484; + Name_Value_Size : constant Name_Id := N + 485; -- GNAT + Name_Version : constant Name_Id := N + 486; + Name_Wchar_T_Size : constant Name_Id := N + 487; -- GNAT + Name_Wide_Wide_Width : constant Name_Id := N + 488; -- Ada 05 + Name_Wide_Width : constant Name_Id := N + 489; + Name_Width : constant Name_Id := N + 490; + Name_Word_Size : constant Name_Id := N + 491; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value and that -- have non-universal arguments. - First_Renamable_Function_Attribute : constant Name_Id := N + 491; - Name_Adjacent : constant Name_Id := N + 491; - Name_Ceiling : constant Name_Id := N + 492; - Name_Copy_Sign : constant Name_Id := N + 493; - Name_Floor : constant Name_Id := N + 494; - Name_Fraction : constant Name_Id := N + 495; - Name_From_Any : constant Name_Id := N + 496; -- GNAT - Name_Image : constant Name_Id := N + 497; - Name_Input : constant Name_Id := N + 498; - Name_Machine : constant Name_Id := N + 499; - Name_Max : constant Name_Id := N + 500; - Name_Min : constant Name_Id := N + 501; - Name_Model : constant Name_Id := N + 502; - Name_Pred : constant Name_Id := N + 503; - Name_Remainder : constant Name_Id := N + 504; - Name_Rounding : constant Name_Id := N + 505; - Name_Succ : constant Name_Id := N + 506; - Name_To_Any : constant Name_Id := N + 507; -- GNAT - Name_Truncation : constant Name_Id := N + 508; - Name_TypeCode : constant Name_Id := N + 509; -- GNAT - Name_Value : constant Name_Id := N + 510; - Name_Wide_Image : constant Name_Id := N + 511; - Name_Wide_Wide_Image : constant Name_Id := N + 512; - Name_Wide_Value : constant Name_Id := N + 513; - Name_Wide_Wide_Value : constant Name_Id := N + 514; - Last_Renamable_Function_Attribute : constant Name_Id := N + 514; + First_Renamable_Function_Attribute : constant Name_Id := N + 492; + Name_Adjacent : constant Name_Id := N + 492; + Name_Ceiling : constant Name_Id := N + 493; + Name_Copy_Sign : constant Name_Id := N + 494; + Name_Floor : constant Name_Id := N + 495; + Name_Fraction : constant Name_Id := N + 496; + Name_From_Any : constant Name_Id := N + 497; -- GNAT + Name_Image : constant Name_Id := N + 498; + Name_Input : constant Name_Id := N + 499; + Name_Machine : constant Name_Id := N + 500; + Name_Max : constant Name_Id := N + 501; + Name_Min : constant Name_Id := N + 502; + Name_Model : constant Name_Id := N + 503; + Name_Pred : constant Name_Id := N + 504; + Name_Remainder : constant Name_Id := N + 505; + Name_Rounding : constant Name_Id := N + 506; + Name_Succ : constant Name_Id := N + 507; + Name_To_Any : constant Name_Id := N + 508; -- GNAT + Name_Truncation : constant Name_Id := N + 509; + Name_TypeCode : constant Name_Id := N + 510; -- GNAT + Name_Value : constant Name_Id := N + 511; + Name_Wide_Image : constant Name_Id := N + 512; + Name_Wide_Wide_Image : constant Name_Id := N + 513; + Name_Wide_Value : constant Name_Id := N + 514; + Name_Wide_Wide_Value : constant Name_Id := N + 515; + Last_Renamable_Function_Attribute : constant Name_Id := N + 515; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 515; - Name_Output : constant Name_Id := N + 515; - Name_Read : constant Name_Id := N + 516; - Name_Write : constant Name_Id := N + 517; - Last_Procedure_Attribute : constant Name_Id := N + 517; + First_Procedure_Attribute : constant Name_Id := N + 516; + Name_Output : constant Name_Id := N + 516; + Name_Read : constant Name_Id := N + 517; + Name_Write : constant Name_Id := N + 518; + Last_Procedure_Attribute : constant Name_Id := N + 518; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 518; - Name_Elab_Body : constant Name_Id := N + 518; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 519; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 520; + First_Entity_Attribute_Name : constant Name_Id := N + 519; + Name_Elab_Body : constant Name_Id := N + 519; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 520; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 521; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 521; - Name_Base : constant Name_Id := N + 521; - Name_Class : constant Name_Id := N + 522; - Name_Stub_Type : constant Name_Id := N + 523; - Last_Type_Attribute_Name : constant Name_Id := N + 523; - Last_Entity_Attribute_Name : constant Name_Id := N + 523; - Last_Attribute_Name : constant Name_Id := N + 523; + First_Type_Attribute_Name : constant Name_Id := N + 522; + Name_Base : constant Name_Id := N + 522; + Name_Class : constant Name_Id := N + 523; + Name_Stub_Type : constant Name_Id := N + 524; + Last_Type_Attribute_Name : constant Name_Id := N + 524; + Last_Entity_Attribute_Name : constant Name_Id := N + 524; + Last_Attribute_Name : constant Name_Id := N + 524; -- Names of recognized locking policy identifiers @@ -851,10 +852,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 524; - Name_Ceiling_Locking : constant Name_Id := N + 524; - Name_Inheritance_Locking : constant Name_Id := N + 525; - Last_Locking_Policy_Name : constant Name_Id := N + 525; + First_Locking_Policy_Name : constant Name_Id := N + 525; + Name_Ceiling_Locking : constant Name_Id := N + 525; + Name_Inheritance_Locking : constant Name_Id := N + 526; + Last_Locking_Policy_Name : constant Name_Id := N + 526; -- Names of recognized queuing policy identifiers @@ -862,10 +863,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 526; - Name_FIFO_Queuing : constant Name_Id := N + 526; - Name_Priority_Queuing : constant Name_Id := N + 527; - Last_Queuing_Policy_Name : constant Name_Id := N + 527; + First_Queuing_Policy_Name : constant Name_Id := N + 527; + Name_FIFO_Queuing : constant Name_Id := N + 527; + Name_Priority_Queuing : constant Name_Id := N + 528; + Last_Queuing_Policy_Name : constant Name_Id := N + 528; -- Names of recognized task dispatching policy identifiers @@ -873,285 +874,285 @@ package Snames is -- name (e.g. F for FIFO_Within_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 528; - Name_EDF_Across_Priorities : constant Name_Id := N + 528; - Name_FIFO_Within_Priorities : constant Name_Id := N + 529; - Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + 530; - Name_Round_Robin_Within_Priorities : constant Name_Id := N + 531; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 531; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 529; + Name_EDF_Across_Priorities : constant Name_Id := N + 529; + Name_FIFO_Within_Priorities : constant Name_Id := N + 530; + Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + 531; + Name_Round_Robin_Within_Priorities : constant Name_Id := N + 532; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 532; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 532; - Name_Access_Check : constant Name_Id := N + 532; - Name_Accessibility_Check : constant Name_Id := N + 533; - Name_Alignment_Check : constant Name_Id := N + 534; -- GNAT - Name_Discriminant_Check : constant Name_Id := N + 535; - Name_Division_Check : constant Name_Id := N + 536; - Name_Elaboration_Check : constant Name_Id := N + 537; - Name_Index_Check : constant Name_Id := N + 538; - Name_Length_Check : constant Name_Id := N + 539; - Name_Overflow_Check : constant Name_Id := N + 540; - Name_Range_Check : constant Name_Id := N + 541; - Name_Storage_Check : constant Name_Id := N + 542; - Name_Tag_Check : constant Name_Id := N + 543; - Name_Validity_Check : constant Name_Id := N + 544; -- GNAT - Name_All_Checks : constant Name_Id := N + 545; - Last_Check_Name : constant Name_Id := N + 545; + First_Check_Name : constant Name_Id := N + 533; + Name_Access_Check : constant Name_Id := N + 533; + Name_Accessibility_Check : constant Name_Id := N + 534; + Name_Alignment_Check : constant Name_Id := N + 535; -- GNAT + Name_Discriminant_Check : constant Name_Id := N + 536; + Name_Division_Check : constant Name_Id := N + 537; + Name_Elaboration_Check : constant Name_Id := N + 538; + Name_Index_Check : constant Name_Id := N + 539; + Name_Length_Check : constant Name_Id := N + 540; + Name_Overflow_Check : constant Name_Id := N + 541; + Name_Range_Check : constant Name_Id := N + 542; + Name_Storage_Check : constant Name_Id := N + 543; + Name_Tag_Check : constant Name_Id := N + 544; + Name_Validity_Check : constant Name_Id := N + 545; -- GNAT + Name_All_Checks : constant Name_Id := N + 546; + Last_Check_Name : constant Name_Id := N + 546; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Mod, Range). - Name_Abort : constant Name_Id := N + 546; - Name_Abs : constant Name_Id := N + 547; - Name_Accept : constant Name_Id := N + 548; - Name_And : constant Name_Id := N + 549; - Name_All : constant Name_Id := N + 550; - Name_Array : constant Name_Id := N + 551; - Name_At : constant Name_Id := N + 552; - Name_Begin : constant Name_Id := N + 553; - Name_Body : constant Name_Id := N + 554; - Name_Case : constant Name_Id := N + 555; - Name_Constant : constant Name_Id := N + 556; - Name_Declare : constant Name_Id := N + 557; - Name_Delay : constant Name_Id := N + 558; - Name_Do : constant Name_Id := N + 559; - Name_Else : constant Name_Id := N + 560; - Name_Elsif : constant Name_Id := N + 561; - Name_End : constant Name_Id := N + 562; - Name_Entry : constant Name_Id := N + 563; - Name_Exception : constant Name_Id := N + 564; - Name_Exit : constant Name_Id := N + 565; - Name_For : constant Name_Id := N + 566; - Name_Function : constant Name_Id := N + 567; - Name_Generic : constant Name_Id := N + 568; - Name_Goto : constant Name_Id := N + 569; - Name_If : constant Name_Id := N + 570; - Name_In : constant Name_Id := N + 571; - Name_Is : constant Name_Id := N + 572; - Name_Limited : constant Name_Id := N + 573; - Name_Loop : constant Name_Id := N + 574; - Name_New : constant Name_Id := N + 575; - Name_Not : constant Name_Id := N + 576; - Name_Null : constant Name_Id := N + 577; - Name_Of : constant Name_Id := N + 578; - Name_Or : constant Name_Id := N + 579; - Name_Others : constant Name_Id := N + 580; - Name_Out : constant Name_Id := N + 581; - Name_Package : constant Name_Id := N + 582; - Name_Pragma : constant Name_Id := N + 583; - Name_Private : constant Name_Id := N + 584; - Name_Procedure : constant Name_Id := N + 585; - Name_Raise : constant Name_Id := N + 586; - Name_Record : constant Name_Id := N + 587; - Name_Rem : constant Name_Id := N + 588; - Name_Renames : constant Name_Id := N + 589; - Name_Return : constant Name_Id := N + 590; - Name_Reverse : constant Name_Id := N + 591; - Name_Select : constant Name_Id := N + 592; - Name_Separate : constant Name_Id := N + 593; - Name_Subtype : constant Name_Id := N + 594; - Name_Task : constant Name_Id := N + 595; - Name_Terminate : constant Name_Id := N + 596; - Name_Then : constant Name_Id := N + 597; - Name_Type : constant Name_Id := N + 598; - Name_Use : constant Name_Id := N + 599; - Name_When : constant Name_Id := N + 600; - Name_While : constant Name_Id := N + 601; - Name_With : constant Name_Id := N + 602; - Name_Xor : constant Name_Id := N + 603; + Name_Abort : constant Name_Id := N + 547; + Name_Abs : constant Name_Id := N + 548; + Name_Accept : constant Name_Id := N + 549; + Name_And : constant Name_Id := N + 550; + Name_All : constant Name_Id := N + 551; + Name_Array : constant Name_Id := N + 552; + Name_At : constant Name_Id := N + 553; + Name_Begin : constant Name_Id := N + 554; + Name_Body : constant Name_Id := N + 555; + Name_Case : constant Name_Id := N + 556; + Name_Constant : constant Name_Id := N + 557; + Name_Declare : constant Name_Id := N + 558; + Name_Delay : constant Name_Id := N + 559; + Name_Do : constant Name_Id := N + 560; + Name_Else : constant Name_Id := N + 561; + Name_Elsif : constant Name_Id := N + 562; + Name_End : constant Name_Id := N + 563; + Name_Entry : constant Name_Id := N + 564; + Name_Exception : constant Name_Id := N + 565; + Name_Exit : constant Name_Id := N + 566; + Name_For : constant Name_Id := N + 567; + Name_Function : constant Name_Id := N + 568; + Name_Generic : constant Name_Id := N + 569; + Name_Goto : constant Name_Id := N + 570; + Name_If : constant Name_Id := N + 571; + Name_In : constant Name_Id := N + 572; + Name_Is : constant Name_Id := N + 573; + Name_Limited : constant Name_Id := N + 574; + Name_Loop : constant Name_Id := N + 575; + Name_New : constant Name_Id := N + 576; + Name_Not : constant Name_Id := N + 577; + Name_Null : constant Name_Id := N + 578; + Name_Of : constant Name_Id := N + 579; + Name_Or : constant Name_Id := N + 580; + Name_Others : constant Name_Id := N + 581; + Name_Out : constant Name_Id := N + 582; + Name_Package : constant Name_Id := N + 583; + Name_Pragma : constant Name_Id := N + 584; + Name_Private : constant Name_Id := N + 585; + Name_Procedure : constant Name_Id := N + 586; + Name_Raise : constant Name_Id := N + 587; + Name_Record : constant Name_Id := N + 588; + Name_Rem : constant Name_Id := N + 589; + Name_Renames : constant Name_Id := N + 590; + Name_Return : constant Name_Id := N + 591; + Name_Reverse : constant Name_Id := N + 592; + Name_Select : constant Name_Id := N + 593; + Name_Separate : constant Name_Id := N + 594; + Name_Subtype : constant Name_Id := N + 595; + Name_Task : constant Name_Id := N + 596; + Name_Terminate : constant Name_Id := N + 597; + Name_Then : constant Name_Id := N + 598; + Name_Type : constant Name_Id := N + 599; + Name_Use : constant Name_Id := N + 600; + Name_When : constant Name_Id := N + 601; + Name_While : constant Name_Id := N + 602; + Name_With : constant Name_Id := N + 603; + Name_Xor : constant Name_Id := N + 604; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. So is To_Address, which is a GNAT attribute. - First_Intrinsic_Name : constant Name_Id := N + 604; - Name_Divide : constant Name_Id := N + 604; - Name_Enclosing_Entity : constant Name_Id := N + 605; - Name_Exception_Information : constant Name_Id := N + 606; - Name_Exception_Message : constant Name_Id := N + 607; - Name_Exception_Name : constant Name_Id := N + 608; - Name_File : constant Name_Id := N + 609; - Name_Generic_Dispatching_Constructor : constant Name_Id := N + 610; - Name_Import_Address : constant Name_Id := N + 611; - Name_Import_Largest_Value : constant Name_Id := N + 612; - Name_Import_Value : constant Name_Id := N + 613; - Name_Is_Negative : constant Name_Id := N + 614; - Name_Line : constant Name_Id := N + 615; - Name_Rotate_Left : constant Name_Id := N + 616; - Name_Rotate_Right : constant Name_Id := N + 617; - Name_Shift_Left : constant Name_Id := N + 618; - Name_Shift_Right : constant Name_Id := N + 619; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 620; - Name_Source_Location : constant Name_Id := N + 621; - Name_Unchecked_Conversion : constant Name_Id := N + 622; - Name_Unchecked_Deallocation : constant Name_Id := N + 623; - Name_To_Pointer : constant Name_Id := N + 624; - Last_Intrinsic_Name : constant Name_Id := N + 624; + First_Intrinsic_Name : constant Name_Id := N + 605; + Name_Divide : constant Name_Id := N + 605; + Name_Enclosing_Entity : constant Name_Id := N + 606; + Name_Exception_Information : constant Name_Id := N + 607; + Name_Exception_Message : constant Name_Id := N + 608; + Name_Exception_Name : constant Name_Id := N + 609; + Name_File : constant Name_Id := N + 610; + Name_Generic_Dispatching_Constructor : constant Name_Id := N + 611; + Name_Import_Address : constant Name_Id := N + 612; + Name_Import_Largest_Value : constant Name_Id := N + 613; + Name_Import_Value : constant Name_Id := N + 614; + Name_Is_Negative : constant Name_Id := N + 615; + Name_Line : constant Name_Id := N + 616; + Name_Rotate_Left : constant Name_Id := N + 617; + Name_Rotate_Right : constant Name_Id := N + 618; + Name_Shift_Left : constant Name_Id := N + 619; + Name_Shift_Right : constant Name_Id := N + 620; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 621; + Name_Source_Location : constant Name_Id := N + 622; + Name_Unchecked_Conversion : constant Name_Id := N + 623; + Name_Unchecked_Deallocation : constant Name_Id := N + 624; + Name_To_Pointer : constant Name_Id := N + 625; + Last_Intrinsic_Name : constant Name_Id := N + 625; -- Names used in processing intrinsic calls - Name_Free : constant Name_Id := N + 625; + Name_Free : constant Name_Id := N + 626; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 626; - Name_Abstract : constant Name_Id := N + 626; - Name_Aliased : constant Name_Id := N + 627; - Name_Protected : constant Name_Id := N + 628; - Name_Until : constant Name_Id := N + 629; - Name_Requeue : constant Name_Id := N + 630; - Name_Tagged : constant Name_Id := N + 631; - Last_95_Reserved_Word : constant Name_Id := N + 631; + First_95_Reserved_Word : constant Name_Id := N + 627; + Name_Abstract : constant Name_Id := N + 627; + Name_Aliased : constant Name_Id := N + 628; + Name_Protected : constant Name_Id := N + 629; + Name_Until : constant Name_Id := N + 630; + Name_Requeue : constant Name_Id := N + 631; + Name_Tagged : constant Name_Id := N + 632; + Last_95_Reserved_Word : constant Name_Id := N + 632; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 632; + Name_Raise_Exception : constant Name_Id := N + 633; -- Additional reserved words and identifiers used in GNAT Project Files -- Note that Name_External is already previously declared - Name_Ada_Roots : constant Name_Id := N + 633; - Name_Aggregate : constant Name_Id := N + 634; - Name_Archive_Builder : constant Name_Id := N + 635; - Name_Archive_Builder_Append_Option : constant Name_Id := N + 636; - Name_Archive_Indexer : constant Name_Id := N + 637; - Name_Archive_Suffix : constant Name_Id := N + 638; - Name_Binder : constant Name_Id := N + 639; - Name_Binder_Prefix : constant Name_Id := N + 640; - Name_Body_Suffix : constant Name_Id := N + 641; - Name_Builder : constant Name_Id := N + 642; - Name_Builder_Switches : constant Name_Id := N + 643; - Name_Compiler : constant Name_Id := N + 644; - Name_Compiler_Kind : constant Name_Id := N + 645; - Name_Config_Body_File_Name : constant Name_Id := N + 646; - Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 647; - Name_Config_File_Switches : constant Name_Id := N + 648; - Name_Config_File_Unique : constant Name_Id := N + 649; - Name_Config_Spec_File_Name : constant Name_Id := N + 650; - Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 651; - Name_Configuration : constant Name_Id := N + 652; - Name_Cross_Reference : constant Name_Id := N + 653; - Name_Default_Language : constant Name_Id := N + 654; - Name_Default_Switches : constant Name_Id := N + 655; - Name_Dependency_Driver : constant Name_Id := N + 656; - Name_Dependency_File_Kind : constant Name_Id := N + 657; - Name_Dependency_Switches : constant Name_Id := N + 658; - Name_Driver : constant Name_Id := N + 659; - Name_Excluded_Source_Dirs : constant Name_Id := N + 660; - Name_Excluded_Source_Files : constant Name_Id := N + 661; - Name_Excluded_Source_List_File : constant Name_Id := N + 662; - Name_Exec_Dir : constant Name_Id := N + 663; - Name_Executable : constant Name_Id := N + 664; - Name_Executable_Suffix : constant Name_Id := N + 665; - Name_Extends : constant Name_Id := N + 666; - Name_Externally_Built : constant Name_Id := N + 667; - Name_Finder : constant Name_Id := N + 668; - Name_Global_Compilation_Switches : constant Name_Id := N + 669; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 670; - Name_Global_Config_File : constant Name_Id := N + 671; - Name_Gnatls : constant Name_Id := N + 672; - Name_Gnatstub : constant Name_Id := N + 673; - Name_Implementation : constant Name_Id := N + 674; - Name_Implementation_Exceptions : constant Name_Id := N + 675; - Name_Implementation_Suffix : constant Name_Id := N + 676; - Name_Include_Switches : constant Name_Id := N + 677; - Name_Include_Path : constant Name_Id := N + 678; - Name_Include_Path_File : constant Name_Id := N + 679; - Name_Inherit_Source_Path : constant Name_Id := N + 680; - Name_Language_Kind : constant Name_Id := N + 681; - Name_Language_Processing : constant Name_Id := N + 682; - Name_Languages : constant Name_Id := N + 683; - Name_Library : constant Name_Id := N + 684; - Name_Library_Ali_Dir : constant Name_Id := N + 685; - Name_Library_Auto_Init : constant Name_Id := N + 686; - Name_Library_Auto_Init_Supported : constant Name_Id := N + 687; - Name_Library_Builder : constant Name_Id := N + 688; - Name_Library_Dir : constant Name_Id := N + 689; - Name_Library_GCC : constant Name_Id := N + 690; - Name_Library_Interface : constant Name_Id := N + 691; - Name_Library_Kind : constant Name_Id := N + 692; - Name_Library_Name : constant Name_Id := N + 693; - Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 694; - Name_Library_Options : constant Name_Id := N + 695; - Name_Library_Partial_Linker : constant Name_Id := N + 696; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 697; - Name_Library_Src_Dir : constant Name_Id := N + 698; - Name_Library_Support : constant Name_Id := N + 699; - Name_Library_Symbol_File : constant Name_Id := N + 700; - Name_Library_Symbol_Policy : constant Name_Id := N + 701; - Name_Library_Version : constant Name_Id := N + 702; - Name_Library_Version_Switches : constant Name_Id := N + 703; - Name_Linker : constant Name_Id := N + 704; - Name_Linker_Executable_Option : constant Name_Id := N + 705; - Name_Linker_Lib_Dir_Option : constant Name_Id := N + 706; - Name_Linker_Lib_Name_Option : constant Name_Id := N + 707; - Name_Local_Config_File : constant Name_Id := N + 708; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 709; - Name_Locally_Removed_Files : constant Name_Id := N + 710; - Name_Map_File_Option : constant Name_Id := N + 711; - Name_Mapping_File_Switches : constant Name_Id := N + 712; - Name_Mapping_Spec_Suffix : constant Name_Id := N + 713; - Name_Mapping_Body_Suffix : constant Name_Id := N + 714; - Name_Metrics : constant Name_Id := N + 715; - Name_Naming : constant Name_Id := N + 716; - Name_Object_Generated : constant Name_Id := N + 717; - Name_Objects_Linked : constant Name_Id := N + 718; - Name_Objects_Path : constant Name_Id := N + 719; - Name_Objects_Path_File : constant Name_Id := N + 720; - Name_Object_Dir : constant Name_Id := N + 721; - Name_Path_Syntax : constant Name_Id := N + 722; - Name_Pic_Option : constant Name_Id := N + 723; - Name_Pretty_Printer : constant Name_Id := N + 724; - Name_Prefix : constant Name_Id := N + 725; - Name_Project : constant Name_Id := N + 726; - Name_Roots : constant Name_Id := N + 727; - Name_Required_Switches : constant Name_Id := N + 728; - Name_Run_Path_Option : constant Name_Id := N + 729; - Name_Runtime_Project : constant Name_Id := N + 730; - Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 731; - Name_Shared_Library_Prefix : constant Name_Id := N + 732; - Name_Shared_Library_Suffix : constant Name_Id := N + 733; - Name_Separate_Suffix : constant Name_Id := N + 734; - Name_Source_Dirs : constant Name_Id := N + 735; - Name_Source_Files : constant Name_Id := N + 736; - Name_Source_List_File : constant Name_Id := N + 737; - Name_Spec : constant Name_Id := N + 738; - Name_Spec_Suffix : constant Name_Id := N + 739; - Name_Specification : constant Name_Id := N + 740; - Name_Specification_Exceptions : constant Name_Id := N + 741; - Name_Specification_Suffix : constant Name_Id := N + 742; - Name_Stack : constant Name_Id := N + 743; - Name_Switches : constant Name_Id := N + 744; - Name_Symbolic_Link_Supported : constant Name_Id := N + 745; - Name_Sync : constant Name_Id := N + 746; - Name_Synchronize : constant Name_Id := N + 747; - Name_Toolchain_Description : constant Name_Id := N + 748; - Name_Toolchain_Version : constant Name_Id := N + 749; - Name_Runtime_Library_Dir : constant Name_Id := N + 750; + Name_Ada_Roots : constant Name_Id := N + 634; + Name_Aggregate : constant Name_Id := N + 635; + Name_Archive_Builder : constant Name_Id := N + 636; + Name_Archive_Builder_Append_Option : constant Name_Id := N + 637; + Name_Archive_Indexer : constant Name_Id := N + 638; + Name_Archive_Suffix : constant Name_Id := N + 639; + Name_Binder : constant Name_Id := N + 640; + Name_Binder_Prefix : constant Name_Id := N + 641; + Name_Body_Suffix : constant Name_Id := N + 642; + Name_Builder : constant Name_Id := N + 643; + Name_Builder_Switches : constant Name_Id := N + 644; + Name_Compiler : constant Name_Id := N + 645; + Name_Compiler_Kind : constant Name_Id := N + 646; + Name_Config_Body_File_Name : constant Name_Id := N + 647; + Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 648; + Name_Config_File_Switches : constant Name_Id := N + 649; + Name_Config_File_Unique : constant Name_Id := N + 650; + Name_Config_Spec_File_Name : constant Name_Id := N + 651; + Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 652; + Name_Configuration : constant Name_Id := N + 653; + Name_Cross_Reference : constant Name_Id := N + 654; + Name_Default_Language : constant Name_Id := N + 655; + Name_Default_Switches : constant Name_Id := N + 656; + Name_Dependency_Driver : constant Name_Id := N + 657; + Name_Dependency_File_Kind : constant Name_Id := N + 658; + Name_Dependency_Switches : constant Name_Id := N + 659; + Name_Driver : constant Name_Id := N + 660; + Name_Excluded_Source_Dirs : constant Name_Id := N + 661; + Name_Excluded_Source_Files : constant Name_Id := N + 662; + Name_Excluded_Source_List_File : constant Name_Id := N + 663; + Name_Exec_Dir : constant Name_Id := N + 664; + Name_Executable : constant Name_Id := N + 665; + Name_Executable_Suffix : constant Name_Id := N + 666; + Name_Extends : constant Name_Id := N + 667; + Name_Externally_Built : constant Name_Id := N + 668; + Name_Finder : constant Name_Id := N + 669; + Name_Global_Compilation_Switches : constant Name_Id := N + 670; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 671; + Name_Global_Config_File : constant Name_Id := N + 672; + Name_Gnatls : constant Name_Id := N + 673; + Name_Gnatstub : constant Name_Id := N + 674; + Name_Implementation : constant Name_Id := N + 675; + Name_Implementation_Exceptions : constant Name_Id := N + 676; + Name_Implementation_Suffix : constant Name_Id := N + 677; + Name_Include_Switches : constant Name_Id := N + 678; + Name_Include_Path : constant Name_Id := N + 679; + Name_Include_Path_File : constant Name_Id := N + 680; + Name_Inherit_Source_Path : constant Name_Id := N + 681; + Name_Language_Kind : constant Name_Id := N + 682; + Name_Language_Processing : constant Name_Id := N + 683; + Name_Languages : constant Name_Id := N + 684; + Name_Library : constant Name_Id := N + 685; + Name_Library_Ali_Dir : constant Name_Id := N + 686; + Name_Library_Auto_Init : constant Name_Id := N + 687; + Name_Library_Auto_Init_Supported : constant Name_Id := N + 688; + Name_Library_Builder : constant Name_Id := N + 689; + Name_Library_Dir : constant Name_Id := N + 690; + Name_Library_GCC : constant Name_Id := N + 691; + Name_Library_Interface : constant Name_Id := N + 692; + Name_Library_Kind : constant Name_Id := N + 693; + Name_Library_Name : constant Name_Id := N + 694; + Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 695; + Name_Library_Options : constant Name_Id := N + 696; + Name_Library_Partial_Linker : constant Name_Id := N + 697; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 698; + Name_Library_Src_Dir : constant Name_Id := N + 699; + Name_Library_Support : constant Name_Id := N + 700; + Name_Library_Symbol_File : constant Name_Id := N + 701; + Name_Library_Symbol_Policy : constant Name_Id := N + 702; + Name_Library_Version : constant Name_Id := N + 703; + Name_Library_Version_Switches : constant Name_Id := N + 704; + Name_Linker : constant Name_Id := N + 705; + Name_Linker_Executable_Option : constant Name_Id := N + 706; + Name_Linker_Lib_Dir_Option : constant Name_Id := N + 707; + Name_Linker_Lib_Name_Option : constant Name_Id := N + 708; + Name_Local_Config_File : constant Name_Id := N + 709; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 710; + Name_Locally_Removed_Files : constant Name_Id := N + 711; + Name_Map_File_Option : constant Name_Id := N + 712; + Name_Mapping_File_Switches : constant Name_Id := N + 713; + Name_Mapping_Spec_Suffix : constant Name_Id := N + 714; + Name_Mapping_Body_Suffix : constant Name_Id := N + 715; + Name_Metrics : constant Name_Id := N + 716; + Name_Naming : constant Name_Id := N + 717; + Name_Object_Generated : constant Name_Id := N + 718; + Name_Objects_Linked : constant Name_Id := N + 719; + Name_Objects_Path : constant Name_Id := N + 720; + Name_Objects_Path_File : constant Name_Id := N + 721; + Name_Object_Dir : constant Name_Id := N + 722; + Name_Path_Syntax : constant Name_Id := N + 723; + Name_Pic_Option : constant Name_Id := N + 724; + Name_Pretty_Printer : constant Name_Id := N + 725; + Name_Prefix : constant Name_Id := N + 726; + Name_Project : constant Name_Id := N + 727; + Name_Roots : constant Name_Id := N + 728; + Name_Required_Switches : constant Name_Id := N + 729; + Name_Run_Path_Option : constant Name_Id := N + 730; + Name_Runtime_Project : constant Name_Id := N + 731; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 732; + Name_Shared_Library_Prefix : constant Name_Id := N + 733; + Name_Shared_Library_Suffix : constant Name_Id := N + 734; + Name_Separate_Suffix : constant Name_Id := N + 735; + Name_Source_Dirs : constant Name_Id := N + 736; + Name_Source_Files : constant Name_Id := N + 737; + Name_Source_List_File : constant Name_Id := N + 738; + Name_Spec : constant Name_Id := N + 739; + Name_Spec_Suffix : constant Name_Id := N + 740; + Name_Specification : constant Name_Id := N + 741; + Name_Specification_Exceptions : constant Name_Id := N + 742; + Name_Specification_Suffix : constant Name_Id := N + 743; + Name_Stack : constant Name_Id := N + 744; + Name_Switches : constant Name_Id := N + 745; + Name_Symbolic_Link_Supported : constant Name_Id := N + 746; + Name_Sync : constant Name_Id := N + 747; + Name_Synchronize : constant Name_Id := N + 748; + Name_Toolchain_Description : constant Name_Id := N + 749; + Name_Toolchain_Version : constant Name_Id := N + 750; + Name_Runtime_Library_Dir : constant Name_Id := N + 751; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 751; + Name_Unaligned_Valid : constant Name_Id := N + 752; -- Ada 2005 reserved words - First_2005_Reserved_Word : constant Name_Id := N + 752; - Name_Interface : constant Name_Id := N + 752; - Name_Overriding : constant Name_Id := N + 753; - Name_Synchronized : constant Name_Id := N + 754; - Last_2005_Reserved_Word : constant Name_Id := N + 754; + First_2005_Reserved_Word : constant Name_Id := N + 753; + Name_Interface : constant Name_Id := N + 753; + Name_Overriding : constant Name_Id := N + 754; + Name_Synchronized : constant Name_Id := N + 755; + Last_2005_Reserved_Word : constant Name_Id := N + 755; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 754; + Last_Predefined_Name : constant Name_Id := N + 755; --------------------------------------- -- Subtypes Defining Name Categories -- @@ -1394,6 +1395,7 @@ package Snames is Pragma_Ada_05, Pragma_Ada_2005, Pragma_Assertion_Policy, + Pragma_Assume_No_Invalid_Values, Pragma_C_Pass_By_Copy, Pragma_Check_Name, Pragma_Check_Policy, diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 8f1367f7184..627950f5c9f 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -229,170 +229,171 @@ extern unsigned char Get_Pragma_Id (int); #define Pragma_Ada_05 2 #define Pragma_Ada_2005 3 #define Pragma_Assertion_Policy 4 -#define Pragma_C_Pass_By_Copy 5 -#define Pragma_Check_Name 6 -#define Pragma_Check_Policy 7 -#define Pragma_Compile_Time_Error 8 -#define Pragma_Compile_Time_Warning 9 -#define Pragma_Compiler_Unit 10 -#define Pragma_Component_Alignment 11 -#define Pragma_Convention_Identifier 12 -#define Pragma_Debug_Policy 13 -#define Pragma_Detect_Blocking 14 -#define Pragma_Discard_Names 15 -#define Pragma_Elaboration_Checks 16 -#define Pragma_Eliminate 17 -#define Pragma_Extend_System 18 -#define Pragma_Extensions_Allowed 19 -#define Pragma_External_Name_Casing 20 -#define Pragma_Favor_Top_Level 21 -#define Pragma_Float_Representation 22 -#define Pragma_Implicit_Packing 23 -#define Pragma_Initialize_Scalars 24 -#define Pragma_Interrupt_State 25 -#define Pragma_License 26 -#define Pragma_Locking_Policy 27 -#define Pragma_Long_Float 28 -#define Pragma_No_Run_Time 29 -#define Pragma_No_Strict_Aliasing 30 -#define Pragma_Normalize_Scalars 31 -#define Pragma_Optimize_Alignment 32 -#define Pragma_Persistent_BSS 33 -#define Pragma_Polling 34 -#define Pragma_Priority_Specific_Dispatching 35 -#define Pragma_Profile 36 -#define Pragma_Profile_Warnings 37 -#define Pragma_Propagate_Exceptions 38 -#define Pragma_Queuing_Policy 39 -#define Pragma_Ravenscar 40 -#define Pragma_Restricted_Run_Time 41 -#define Pragma_Restrictions 42 -#define Pragma_Restriction_Warnings 43 -#define Pragma_Reviewable 44 -#define Pragma_Source_File_Name 45 -#define Pragma_Source_File_Name_Project 46 -#define Pragma_Style_Checks 47 -#define Pragma_Suppress 48 -#define Pragma_Suppress_Exception_Locations 49 -#define Pragma_Task_Dispatching_Policy 50 -#define Pragma_Universal_Data 51 -#define Pragma_Unsuppress 52 -#define Pragma_Use_VADS_Size 53 -#define Pragma_Validity_Checks 54 -#define Pragma_Warnings 55 -#define Pragma_Wide_Character_Encoding 56 -#define Pragma_Abort_Defer 57 -#define Pragma_All_Calls_Remote 58 -#define Pragma_Annotate 59 -#define Pragma_Assert 60 -#define Pragma_Asynchronous 61 -#define Pragma_Atomic 62 -#define Pragma_Atomic_Components 63 -#define Pragma_Attach_Handler 64 -#define Pragma_Check 65 -#define Pragma_CIL_Constructor 66 -#define Pragma_Comment 67 -#define Pragma_Common_Object 68 -#define Pragma_Complete_Representation 69 -#define Pragma_Complex_Representation 70 -#define Pragma_Controlled 71 -#define Pragma_Convention 72 -#define Pragma_CPP_Class 73 -#define Pragma_CPP_Constructor 74 -#define Pragma_CPP_Virtual 75 -#define Pragma_CPP_Vtable 76 -#define Pragma_Debug 77 -#define Pragma_Elaborate 78 -#define Pragma_Elaborate_All 79 -#define Pragma_Elaborate_Body 80 -#define Pragma_Export 81 -#define Pragma_Export_Exception 82 -#define Pragma_Export_Function 83 -#define Pragma_Export_Object 84 -#define Pragma_Export_Procedure 85 -#define Pragma_Export_Value 86 -#define Pragma_Export_Valued_Procedure 87 -#define Pragma_External 88 -#define Pragma_Finalize_Storage_Only 89 -#define Pragma_Ident 90 -#define Pragma_Implemented_By_Entry 91 -#define Pragma_Import 92 -#define Pragma_Import_Exception 93 -#define Pragma_Import_Function 94 -#define Pragma_Import_Object 95 -#define Pragma_Import_Procedure 96 -#define Pragma_Import_Valued_Procedure 97 -#define Pragma_Inline 98 -#define Pragma_Inline_Always 99 -#define Pragma_Inline_Generic 100 -#define Pragma_Inspection_Point 101 -#define Pragma_Interface_Name 102 -#define Pragma_Interrupt_Handler 103 -#define Pragma_Interrupt_Priority 104 -#define Pragma_Java_Constructor 105 -#define Pragma_Java_Interface 106 -#define Pragma_Keep_Names 107 -#define Pragma_Link_With 108 -#define Pragma_Linker_Alias 109 -#define Pragma_Linker_Constructor 110 -#define Pragma_Linker_Destructor 111 -#define Pragma_Linker_Options 112 -#define Pragma_Linker_Section 113 -#define Pragma_List 114 -#define Pragma_Machine_Attribute 115 -#define Pragma_Main 116 -#define Pragma_Main_Storage 117 -#define Pragma_Memory_Size 118 -#define Pragma_No_Body 119 -#define Pragma_No_Return 120 -#define Pragma_Obsolescent 121 -#define Pragma_Optimize 122 -#define Pragma_Pack 123 -#define Pragma_Page 124 -#define Pragma_Passive 125 -#define Pragma_Postcondition 126 -#define Pragma_Precondition 127 -#define Pragma_Preelaborable_Initialization 128 -#define Pragma_Preelaborate 129 -#define Pragma_Preelaborate_05 130 -#define Pragma_Psect_Object 131 -#define Pragma_Pure 132 -#define Pragma_Pure_05 133 -#define Pragma_Pure_Function 134 -#define Pragma_Relative_Deadline 135 -#define Pragma_Remote_Call_Interface 136 -#define Pragma_Remote_Types 137 -#define Pragma_Share_Generic 138 -#define Pragma_Shared 139 -#define Pragma_Shared_Passive 140 -#define Pragma_Source_Reference 141 -#define Pragma_Static_Elaboration_Desired 142 -#define Pragma_Stream_Convert 143 -#define Pragma_Subtitle 144 -#define Pragma_Suppress_All 145 -#define Pragma_Suppress_Debug_Info 146 -#define Pragma_Suppress_Initialization 147 -#define Pragma_System_Name 148 -#define Pragma_Task_Info 149 -#define Pragma_Task_Name 150 -#define Pragma_Task_Storage 151 -#define Pragma_Time_Slice 152 -#define Pragma_Title 153 -#define Pragma_Unchecked_Union 154 -#define Pragma_Unimplemented_Unit 155 -#define Pragma_Universal_Aliasing 156 -#define Pragma_Unmodified 157 -#define Pragma_Unreferenced 158 -#define Pragma_Unreferenced_Objects 159 -#define Pragma_Unreserve_All_Interrupts 160 -#define Pragma_Volatile 161 -#define Pragma_Volatile_Components 162 -#define Pragma_Weak_External 163 -#define Pragma_AST_Entry 164 -#define Pragma_Fast_Math 165 -#define Pragma_Interface 166 -#define Pragma_Priority 167 -#define Pragma_Storage_Size 168 -#define Pragma_Storage_Unit 169 +#define Pragma_Assume_No_Invalid_Values 5 +#define Pragma_C_Pass_By_Copy 6 +#define Pragma_Check_Name 7 +#define Pragma_Check_Policy 8 +#define Pragma_Compile_Time_Error 9 +#define Pragma_Compile_Time_Warning 10 +#define Pragma_Compiler_Unit 11 +#define Pragma_Component_Alignment 12 +#define Pragma_Convention_Identifier 13 +#define Pragma_Debug_Policy 14 +#define Pragma_Detect_Blocking 15 +#define Pragma_Discard_Names 16 +#define Pragma_Elaboration_Checks 17 +#define Pragma_Eliminate 18 +#define Pragma_Extend_System 19 +#define Pragma_Extensions_Allowed 20 +#define Pragma_External_Name_Casing 21 +#define Pragma_Favor_Top_Level 22 +#define Pragma_Float_Representation 23 +#define Pragma_Implicit_Packing 24 +#define Pragma_Initialize_Scalars 25 +#define Pragma_Interrupt_State 26 +#define Pragma_License 27 +#define Pragma_Locking_Policy 28 +#define Pragma_Long_Float 29 +#define Pragma_No_Run_Time 30 +#define Pragma_No_Strict_Aliasing 31 +#define Pragma_Normalize_Scalars 32 +#define Pragma_Optimize_Alignment 33 +#define Pragma_Persistent_BSS 34 +#define Pragma_Polling 35 +#define Pragma_Priority_Specific_Dispatching 36 +#define Pragma_Profile 37 +#define Pragma_Profile_Warnings 38 +#define Pragma_Propagate_Exceptions 39 +#define Pragma_Queuing_Policy 40 +#define Pragma_Ravenscar 41 +#define Pragma_Restricted_Run_Time 42 +#define Pragma_Restrictions 43 +#define Pragma_Restriction_Warnings 44 +#define Pragma_Reviewable 45 +#define Pragma_Source_File_Name 46 +#define Pragma_Source_File_Name_Project 47 +#define Pragma_Style_Checks 48 +#define Pragma_Suppress 49 +#define Pragma_Suppress_Exception_Locations 50 +#define Pragma_Task_Dispatching_Policy 51 +#define Pragma_Universal_Data 52 +#define Pragma_Unsuppress 53 +#define Pragma_Use_VADS_Size 54 +#define Pragma_Validity_Checks 55 +#define Pragma_Warnings 56 +#define Pragma_Wide_Character_Encoding 57 +#define Pragma_Abort_Defer 58 +#define Pragma_All_Calls_Remote 59 +#define Pragma_Annotate 60 +#define Pragma_Assert 61 +#define Pragma_Asynchronous 62 +#define Pragma_Atomic 63 +#define Pragma_Atomic_Components 64 +#define Pragma_Attach_Handler 65 +#define Pragma_Check 66 +#define Pragma_CIL_Constructor 67 +#define Pragma_Comment 68 +#define Pragma_Common_Object 69 +#define Pragma_Complete_Representation 70 +#define Pragma_Complex_Representation 71 +#define Pragma_Controlled 72 +#define Pragma_Convention 73 +#define Pragma_CPP_Class 74 +#define Pragma_CPP_Constructor 75 +#define Pragma_CPP_Virtual 76 +#define Pragma_CPP_Vtable 77 +#define Pragma_Debug 78 +#define Pragma_Elaborate 79 +#define Pragma_Elaborate_All 80 +#define Pragma_Elaborate_Body 81 +#define Pragma_Export 82 +#define Pragma_Export_Exception 83 +#define Pragma_Export_Function 84 +#define Pragma_Export_Object 85 +#define Pragma_Export_Procedure 86 +#define Pragma_Export_Value 87 +#define Pragma_Export_Valued_Procedure 88 +#define Pragma_External 89 +#define Pragma_Finalize_Storage_Only 90 +#define Pragma_Ident 91 +#define Pragma_Implemented_By_Entry 92 +#define Pragma_Import 93 +#define Pragma_Import_Exception 94 +#define Pragma_Import_Function 95 +#define Pragma_Import_Object 96 +#define Pragma_Import_Procedure 97 +#define Pragma_Import_Valued_Procedure 98 +#define Pragma_Inline 99 +#define Pragma_Inline_Always 100 +#define Pragma_Inline_Generic 101 +#define Pragma_Inspection_Point 102 +#define Pragma_Interface_Name 103 +#define Pragma_Interrupt_Handler 104 +#define Pragma_Interrupt_Priority 105 +#define Pragma_Java_Constructor 106 +#define Pragma_Java_Interface 107 +#define Pragma_Keep_Names 108 +#define Pragma_Link_With 109 +#define Pragma_Linker_Alias 110 +#define Pragma_Linker_Constructor 111 +#define Pragma_Linker_Destructor 112 +#define Pragma_Linker_Options 113 +#define Pragma_Linker_Section 114 +#define Pragma_List 115 +#define Pragma_Machine_Attribute 116 +#define Pragma_Main 117 +#define Pragma_Main_Storage 118 +#define Pragma_Memory_Size 119 +#define Pragma_No_Body 120 +#define Pragma_No_Return 121 +#define Pragma_Obsolescent 122 +#define Pragma_Optimize 123 +#define Pragma_Pack 124 +#define Pragma_Page 125 +#define Pragma_Passive 126 +#define Pragma_Postcondition 127 +#define Pragma_Precondition 128 +#define Pragma_Preelaborable_Initialization 129 +#define Pragma_Preelaborate 130 +#define Pragma_Preelaborate_05 131 +#define Pragma_Psect_Object 132 +#define Pragma_Pure 133 +#define Pragma_Pure_05 134 +#define Pragma_Pure_Function 135 +#define Pragma_Relative_Deadline 136 +#define Pragma_Remote_Call_Interface 137 +#define Pragma_Remote_Types 138 +#define Pragma_Share_Generic 139 +#define Pragma_Shared 140 +#define Pragma_Shared_Passive 141 +#define Pragma_Source_Reference 142 +#define Pragma_Static_Elaboration_Desired 143 +#define Pragma_Stream_Convert 144 +#define Pragma_Subtitle 145 +#define Pragma_Suppress_All 146 +#define Pragma_Suppress_Debug_Info 147 +#define Pragma_Suppress_Initialization 148 +#define Pragma_System_Name 149 +#define Pragma_Task_Info 150 +#define Pragma_Task_Name 151 +#define Pragma_Task_Storage 152 +#define Pragma_Time_Slice 153 +#define Pragma_Title 154 +#define Pragma_Unchecked_Union 155 +#define Pragma_Unimplemented_Unit 156 +#define Pragma_Universal_Aliasing 157 +#define Pragma_Unmodified 158 +#define Pragma_Unreferenced 159 +#define Pragma_Unreferenced_Objects 160 +#define Pragma_Unreserve_All_Interrupts 161 +#define Pragma_Volatile 162 +#define Pragma_Volatile_Components 163 +#define Pragma_Weak_External 164 +#define Pragma_AST_Entry 165 +#define Pragma_Fast_Math 166 +#define Pragma_Interface 167 +#define Pragma_Priority 168 +#define Pragma_Storage_Size 169 +#define Pragma_Storage_Unit 170 /* End of snames.h (C version of Snames package spec) */ diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads index d9b8ae9babb..07e57023ff4 100644 --- a/gcc/ada/style.ads +++ b/gcc/ada/style.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -187,6 +187,11 @@ package Style is -- Called after scanning a conditional expression that has at least one -- level of parentheses around the entire expression. + procedure Missing_Overriding (N : Node_Id; E : Entity_Id) + renames Style_C_Inst.Missing_Overriding; + -- Called where N is the declaration or body of an overriding operation of + -- a tagged type, and does not have an overriding_indicator. + function Mode_In_Check return Boolean renames Style_Inst.Mode_In_Check; -- Determines whether style checking is active and the Mode_In_Check is diff --git a/gcc/ada/styleg-c.adb b/gcc/ada/styleg-c.adb index 003a75140d5..5734471ecfd 100644 --- a/gcc/ada/styleg-c.adb +++ b/gcc/ada/styleg-c.adb @@ -230,6 +230,23 @@ package body Styleg.C is end if; end Check_Identifier; + ------------------------ + -- Missing_Overriding -- + ------------------------ + + procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is + begin + if Style_Check_Missing_Overriding and then Comes_From_Source (N) then + if Nkind (N) = N_Subprogram_Body then + Error_Msg_N + ("(style) missing OVERRIDING indicator in body of&", E); + else + Error_Msg_N + ("(style) missing OVERRIDING indicator in declaration of&", E); + end if; + end if; + end Missing_Overriding; + ----------------------------------- -- Subprogram_Not_In_Alpha_Order -- ----------------------------------- diff --git a/gcc/ada/styleg-c.ads b/gcc/ada/styleg-c.ads index 082f90e7fd3..b3fc1f61fce 100644 --- a/gcc/ada/styleg-c.ads +++ b/gcc/ada/styleg-c.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -53,6 +53,10 @@ package Styleg.C is -- spelling is to be checked against the Chars spelling in identifier node -- Def (which may be either an N_Identifier, or N_Defining_Identifier node) + procedure Missing_Overriding (N : Node_Id; E : Entity_Id); + -- Called where N is the declaration or body of an overriding operation, + -- and the node does not have an overriding_indicator. + procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id); -- Called if Name is the name of a subprogram body in a package body -- that is not in alphabetical order. diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 34688df9c32..764d9af80e9 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -49,6 +49,7 @@ package body Stylesw is Style_Check_Layout := False; Style_Check_Max_Line_Length := False; Style_Check_Max_Nesting_Level := False; + Style_Check_Missing_Overriding := False; Style_Check_Mode_In := False; Style_Check_Order_Subprograms := False; Style_Check_Pragma_Casing := False; @@ -123,6 +124,7 @@ package body Stylesw is Add ('l', Style_Check_Layout); Add ('n', Style_Check_Standard); Add ('o', Style_Check_Order_Subprograms); + Add ('O', Style_Check_Missing_Overriding); Add ('p', Style_Check_Pragma_Casing); Add ('r', Style_Check_References); Add ('s', Style_Check_Specs); @@ -370,6 +372,9 @@ package body Stylesw is when 'o' => Style_Check_Order_Subprograms := True; + when 'O' => + Style_Check_Missing_Overriding := True; + when 'p' => Style_Check_Pragma_Casing := True; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 87552d35bc6..4ee70741097 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -156,8 +156,8 @@ package Stylesw is -- with the IF keyword. Style_Check_Max_Line_Length : Boolean := False; - -- This can be set True by using the -gnatg or -gnatym/M switches. If - -- it is True, it activates checking for a maximum line length of + -- This can be set True by using the -gnatg or -gnatym/M switches. + -- If it is True, it activates checking for a maximum line length of -- Style_Max_Line_Length characters. Style_Check_Max_Nesting_Level : Boolean := False; @@ -165,6 +165,11 @@ package Stylesw is -- (a value of zero resets it to False). If True, it activates checking -- the maximum nesting level against Style_Max_Nesting_Level. + Style_Check_Missing_Overriding : Boolean := False; + -- This can be set True by using the -gnatyO switch. If it is True, then + -- "[not] overriding" is required in subprogram declarations and bodies + -- where appropriate. + Style_Check_Mode_In : Boolean := False; -- This can be set True by using -gnatyI. If True, it activates checking -- that mode IN is not used on its own (since it is the default). diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 63a1a6d83aa..98f70f9912a 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -212,6 +212,12 @@ package body Switch.C is Ptr := Ptr + 1; Brief_Output := True; + -- Processing for B switch + + when 'B' => + Ptr := Ptr + 1; + Assume_No_Invalid_Values := True; + -- Processing for c switch when 'c' => diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index a8f24cd71e5..9028fb58589 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -35,9 +35,14 @@ #ifdef __vxworks #include "ioLib.h" +#include "dosFsLib.h" +#ifndef __RTP__ +# include "nfsLib.h" +#endif #include "selectLib.h" #include "vxWorks.h" #endif + #ifdef IN_RTS #define POSIX #include "tconfig.h" @@ -53,6 +58,7 @@ #endif #include <time.h> +#include <errno.h> #if defined (sun) && defined (__SVR4) && !defined (__vxworks) /* The declaration is present in <time.h> but conditionalized @@ -893,3 +899,23 @@ __gnat_get_task_options (void) } #endif + +int +__gnat_is_file_not_found_error (int errno_val) { + switch (errno_val) { + case ENOENT: +#ifdef __vxworks + /* In the case of VxWorks, we also have to take into account various + * filesystem-specific variants of this error. + */ + case S_dosFsLib_FILE_NOT_FOUND: +#ifndef __RTP__ + case S_nfsLib_NFSERR_NOENT: +#endif +#endif + return 1; + + default: + return 0; + } +} diff --git a/gcc/ada/system-linux-alpha.ads b/gcc/ada/system-linux-alpha.ads index 85bdcaf263a..f8aa7d692fd 100644 --- a/gcc/ada/system-linux-alpha.ads +++ b/gcc/ada/system-linux-alpha.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/alpha Version) -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-linux-s390.ads b/gcc/ada/system-linux-s390.ads index 2a1e617f0cd..d3fa5ea11f0 100644 --- a/gcc/ada/system-linux-s390.ads +++ b/gcc/ada/system-linux-s390.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/s390 Version) -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-linux-s390x.ads b/gcc/ada/system-linux-s390x.ads index 826782220ed..e7eba138533 100644 --- a/gcc/ada/system-linux-s390x.ads +++ b/gcc/ada/system-linux-s390x.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/s390x Version) -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-linux-sh4.ads b/gcc/ada/system-linux-sh4.ads index 8bbbb22b45c..d82ccade304 100644 --- a/gcc/ada/system-linux-sh4.ads +++ b/gcc/ada/system-linux-sh4.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/sh4 Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-linux-sparc.ads b/gcc/ada/system-linux-sparc.ads index 321f8df4454..ff8f263456b 100644 --- a/gcc/ada/system-linux-sparc.ads +++ b/gcc/ada/system-linux-sparc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU/Linux-SPARC Version) -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads index 6ba59a3bd3e..2d4082520ac 100644 --- a/gcc/ada/system-vms-ia64.ads +++ b/gcc/ada/system-vms-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-vms.ads b/gcc/ada/system-vms.ads index 7f95154fa39..386a85a7b5d 100644 --- a/gcc/ada/system-vms.ads +++ b/gcc/ada/system-vms.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS DEC Threads Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads index 4830378f2fc..8078da953fd 100644 --- a/gcc/ada/system-vms_64.ads +++ b/gcc/ada/system-vms_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index ae1ba441b21..7652a3f8465 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -82,8 +82,9 @@ package Tbuild is pragma Inline (Make_Implicit_Exception_Handler); -- This is just like Make_Exception_Handler, except that it also sets the -- Local_Raise_Statements field to No_Elist, ensuring that it is properly - -- initialized. This should always be used when creating exception handlers - -- as part of the expansion. + -- initialized. This should always be used when creating implicit exception + -- handlers during expansion (i.e. handlers that do not correspond to user + -- source program exception handlers). function Make_Implicit_If_Statement (Node : Node_Id; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 74780107da3..b2fe13a0993 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -137,6 +137,11 @@ begin Write_Switch_Char ("b"); Write_Line ("Generate brief messages to stderr even if verbose mode set"); + -- Line for -gnatB switch + + Write_Switch_Char ("B"); + Write_Line ("Assume no bad (invalid) values except in 'Valid attribute"); + -- Line for -gnatc switch Write_Switch_Char ("c"); @@ -457,10 +462,10 @@ begin Write_Line (" .X* turn off warnings for non-local exception"); Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); - Write_Line (" z* turn on warnings for convention/size/align " & - "mismatch on unchecked conversion"); - Write_Line (" Z turn off warnings for convention/size/align " & - "mismatch on unchecked conversion"); + Write_Line (" z* turn on warnings for suspicious " & + "unchecked conversion"); + Write_Line (" Z turn off warnings for suspicious " & + "unchecked conversion"); Write_Line (" * indicates default in above list"); -- Line for -gnatW switch diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 46764ddb50e..b302791e144 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -774,6 +774,17 @@ package VMS_Data is -- -- Use full source locations references in the report file. + S_Diagnosis : aliased constant S := "/DIAGNOSIS_LIMIT=#" & + "-m#"; + -- /DIAGNOSIS_LIMIT=500 (D) + -- /ERROR_LIMIT=nnn + -- + -- NNN is a decimal integer in the range of 1 to 1000 and limits the + -- number of diagnostic messages to be generated into Stdoutto that + -- number. Once that number has been reached, gnatcheck stops + -- to print out diagnoses into Stderr. If NNN is equal to 0, this means + -- that there is no limit on the number of diagnoses in Stdout + S_Check_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & @@ -867,6 +878,7 @@ package VMS_Data is Check_Switches : aliased constant Switches := (S_Check_Add 'Access, S_Check_All 'Access, + S_Diagnosis 'Access, S_Check_Ext 'Access, S_Check_Files 'Access, S_Check_Follow 'Access, |