diff options
| author | rus <rus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-11-09 20:58:24 +0000 |
|---|---|---|
| committer | rus <rus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-11-09 20:58:24 +0000 |
| commit | 7f4db7c80779ecbc57d1146654daf0acfe18de66 (patch) | |
| tree | 3af522a3b5e149c3fd498ecb1255994daae2129a /gcc/ada | |
| parent | 611349f0ec42a37591db2cd02974a11a48d10edb (diff) | |
| download | gcc-7f4db7c80779ecbc57d1146654daf0acfe18de66.tar.gz | |
merge from trunkprofile-stdlib
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/profile-stdlib@154052 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
101 files changed, 4801 insertions, 2675 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6520a7f4681..8c98429a2f3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,478 @@ +2009-11-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (gnat_type_for_mode): Handle vector modes. + +2009-11-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (lvalue_required_p) <N_Unchecked_Conversion>: + New case. + +2009-10-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (MAX_FIXED_MODE_SIZE): Delete. + (create_field_decl): Update description. In a packed record, round + the size up to a byte boundary only if the field's type has BLKmode. + * gcc-interface/gigi.h (create_field_decl): Update description. + +2009-10-30 Emmanuel Briot <briot@adacore.com> + + * make.adb (Start_Compile_If_Possible): Compute location of resulting + ALI file in this procedure instead of after the compilation itself, + since the current directory might have changed in between when using + -j<n>. + + * osint.ads: Addded missing alignment clause. + + * adaint.c, adaint.h, osint.adb (__gnat_reset_attributes, + __gnat_size_of_file_attributes): Rename reset_attributes and + size_of_file_attributes. + +2009-10-30 Javier Miranda <miranda@adacore.com> + + * sem_scil.adb (Adjust_SCIL_Node): Add missing management of sequences + of statements when searching for SCIL nodes. + +2009-10-30 Tristan Gingold <gingold@adacore.com> + + * gnatlink.adb, link.c: By default use shared libgcc on darwin. + +2009-10-30 Emmanuel Briot <briot@adacore.com> + + * make.adb, osint.adb (Add_Lib_Search_Dir): Do not add if dir is + already in the list. + This saves system calls when looking for ALI files + (Scan_Make_Args): The parameter to gnatmake's -D is now converted to an + absolute PATH (so that the above improvement properly occurs if both + -D<dir> and -aO<dir> are specified). + +2009-10-30 Thomas Quinot <quinot@adacore.com> + + * a-direct.adb: Minor reformatting + +2009-10-30 Emmanuel Briot <briot@adacore.com> + + * make.adb, adaint.c, adaint.h, osint.adb, osint.ads, bcheck.adb + (*_attr): new subprograms. + (File_Length, File_Time_Stamp, Is_Writable_File): new subprograms + (Read_Library_Info_From_Full, Full_Library_Info_Name, + Full_Source_Name): Now benefit from a previous cache of the file + attributes, to further save on system calls. + (Smart_Find_File): now also cache the file attributes. This makes the + package File_Stamp_Hash_Table useless, and it was removed. + (Compile_Sources): create subprograms for the various steps of the main + loop, for readibility and to avoid sharing variables between the + various steps. + +2009-10-30 Emmanuel Briot <briot@adacore.com> + + * make.adb, osint.adb, osint.ads (Library_File_Stamp): Removed, since + unused. + (Read_Library_Info_From_Full): New subprogram. + +2009-10-30 Robert Dewar <dewar@adacore.com> + + * a-tideio.adb: Minor reformatting + * a-wtdeio.adb, a-ztdeio.adb: Update comments, code clean up. + + * a-reatim.adb, a-tideau.adb, a-ngelfu.adb, a-ztdeau.adb, a-ngrear.adb, + a-wtedit.adb, a-ststio.adb, a-ztedit.adb: Minor code reorganization + (use conditional expressions). + +2009-10-30 Ed Schonberg <schonberg@adacore.com> + + * gnat_ugn.texi: Additional info on gnatw.i and gnatw.I + + * sem_case.adb: Improved error message. + +2009-10-30 Emmanuel Briot <briot@adacore.com> + + * a-direct.adb, gnatcmd.adb, gnatname.adb, makeutl.adb, opt.ads, + osint.adb, prj-ext.adb, switch-m.adb (Follow_Links_For_Dirs): Now + defaults to False, and controlled by -eL. + * a-direct.adb: Add comments. + * osint.adb (File_Stamp): Avoid unneeded duplicate system call + +2009-10-30 Robert Dewar <dewar@adacore.com> + + * sem_res.adb (Resolve_Type_Conversion): Avoid false positive when + converting non-static subtype to "identical" static subtype. + +2009-10-30 Ed Schonberg <schonberg@adacore.com> + + * usage.adb: Add -gnatw.i switch. + +2009-10-30 Vincent Celier <celier@adacore.com> + + * xsnamest.adb: Update comments with regards to the template files + snames.*.tmpl + +2009-10-30 Bob Duff <duff@adacore.com> + + * s-fileio.adb (Errno_Message): Suppress VMS-specific warning. + +2009-10-30 Ed Schonberg <schonberg@adacore.com> + + * sem_case.adb (Check_Choices): Add explanatory message when there are + missing alternatives when the required range of alternatives is given + by the base type of the case expression or discriminant in a variant + part. + + * opt.ads: New flag Warn_On_Overlap, to enable warnings on potentially + dangerous overlap between actuals in a call, activated by -gnatw.i + * sem_warn.adb (Set_Dot_Warning_Switch): set flag. + (Warn_On_Overlapping_Actuals): use new flag. + + * gnat_ugn.texi: Document -gnatw.i, warning on overlapping actuals + +2009-10-30 Robert Dewar <dewar@adacore.com> + + * exp_aggr.adb, exp_ch9.adb: Minor reformatting + +2009-10-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (make_type_from_size) <INTEGER_TYPE>: Do not + create integer types with precision 0. + +2009-10-29 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/41870 + * gcc-interface/decl.c (array_type_has_nonaliased_component): Swap + parameters and rewrite comments. For a derived type, return the + setting of its parent type. + (gnat_to_gnu_entity): Do an alias set copy for derived types if they + are composite. Adjust calls to above function. + +2009-10-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Attribute_to_gnu) <Attr_Object_Size>: Do not + return the RM size for padded types. + +2009-10-28 Robert Dewar <dewar@adacore.com> + + * sem_type.adb: Minor reformatting + +2009-10-28 Arnaud Charlet <charlet@adacore.com> + + * exp_ch9.adb (Build_Task_Proc_Specification): Generate a different + suffix for task type bodies. + +2009-10-28 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Convert_Aggr_In_Allocator): Do not look for a + finalization list if the designated type requires no control actions, + to prevent a useless semantic dependence on ada.tags. + +2009-10-28 Bob Duff <duff@adacore.com> + + * s-fileio.adb: Give more information in exception messages. + +2009-10-28 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Document new -gnatyt requirement for space after right + paren if next token starts with digit or letter. + * styleg.adb (Check_Right_Paren): New rule for space after if next + character is a letter or digit. + +2009-10-28 Thomas Quinot <quinot@adacore.com> + + * s-crtl.ads (System.CRTL.strerror): New function. + +2009-10-28 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb: Add guard to recover some type errors. + +2009-10-28 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Add_To_Or_Remove_From_List): New name of procedure + Add_If_Not_In_List to account to the fact that a directory may be + removed from the list. Only remove directory if Removed is True. + +2009-10-28 Gary Dismukes <dismukes@adacore.com> + + * a-textio.ads, a-textio.ads: Put back function EOF_Char in private + part. Put back body of function EOF_Char. + * a-tienau.adb: Remove with of Interfaces.C_Streams and change EOF back + to EOF_Char. + +2009-10-28 Emmanuel Briot <briot@adacore.com> + + * prj-tree.adb (Free): Fix memory leak. + +2009-10-28 Thomas Quinot <quinot@adacore.com> + + * s-fileio.adb: Minor reformatting + +2009-10-28 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2009-10-28 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb, exp_ch9.adb, prj-nmsc.adb, tbuild.adb, ali.adb, + types.ads: Minor reformatting + +2009-10-28 Tristan Gingold <gingold@adacore.com> + + * init.c: Fix __gnat_error_handler for Darwin10 (Snow Leopard) + +2009-10-28 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Perform Integer promotion for + the operand of the unary minus and ABS operators. + + * sem_type.adb (Covers): A concurrent type and its corresponding record + type are compatible. + * exp_attr.adb (Expand_N_Attribute_Reference): Do not rewrite a 'Access + attribute reference for the current instance of a protected type while + analyzing an access discriminant constraint in a component definition. + Such a reference is handled in the corresponding record's init proc, + while initializing the constrained component. + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): When creating the + corresponding record type, propagate components' + Has_Per_Object_Constraint flag. + * exp_ch3.adb (Build_Init_Procedure.Build_Init_Statements): + For a concurrent type, set up concurrent aspects before initializing + components with a per object constrain, because they may be controlled, + and their initialization may call entries or protected subprograms of + the enclosing concurrent object. + +2009-10-28 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb (Add_If_Not_In_List): New subprogram, for better sharing + of code. + (Find_Source_Dirs): resolve links if Opt.Follow_Links_For_Dirs when + processing the directories specified explicitly in the project file. + +2009-10-28 Robert Dewar <dewar@adacore.com> + + * a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb, + a-textio.ads, a-textio.adb: Reorganize (moving specs from private part + to body). + (Initialize_Standard_Files): New procedure. + * a-tienau.adb: Minor change to make EOF directly visible + * a-tirsfi.ads, a-wrstfi.adb, a-wrstfi.ads, a-zrstfi.adb, + a-zrstfi.ads, a-tirsfi.adb: New unit, initial version. + * gnat_rm.texi: Add documentation for + Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files. + * Makefile.rtl: Add entries for + Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files + +2009-10-28 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.ads: Minor reformatting + * sem_ch3.adb: Minor reformatting + * sem_aggr.adb: Minor reformatting. + * sem_attr.adb: Minor reformatting + * tbuild.adb, tbuild.ads, par-ch4.adb, exp_ch4.adb (Tbuild.New_Op_Node): + New subprogram. + Minor code reorganization/factoring. + +2009-10-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (purpose_member_field): New static function. + (annotate_rep): Use it instead of purpose_member. + +2009-10-27 Eric Botcazou <ebotcazou@adacore.com> + + * raise-gcc (db_region_for): Use _Unwind_GetIPInfo instead of + _Unwind_GetIP if HAVE_GETIPINFO is defined. + (db_action_for): Likewise. + +2009-10-27 Robert Dewar <dewar@adacore.com> + + * s-fileio.adb, s-fileio.ads, sem_util.adb, sem_warn.adb, + sem_warn.ads: Minor reformatting + +2009-10-27 Robert Dewar <dewar@adacore.com> + + * sem_warn.adb, sem_util.adb, sem_util.ads: Minor reformatting. Add + comments. + +2009-10-27 Robert Dewar <dewar@adacore.com> + + * s-os_lib.ads, s-os_lib.adb, prj-err.adb, makeutl.adb: Minor + reformatting. + +2009-10-27 Ed Schonberg <schonberg@adacore.com> + + * sem.util.ads, sem_util.adb (Denotes_Same_Object, + Denotes_Same_Prefix): New functions to detect overlap between actuals + that are not by-copy in a call, when one of them is in-out. + * sem_warn.ads, sem_warn.adb (Warn_On_Overlapping_Actuals): New + procedure, called on a subprogram call to warn when an in-out actual + that is not by-copy overlaps with another actual, thus leadind to + potentially dangerous aliasing in the body of the called subprogram. + Currently the warning is under control of the -gnatX switch. + * sem_res.adb (resolve_call): call Warn_On_Overlapping_Actuals. + +2009-10-27 Thomas Quinot <quinot@adacore.com> + + * sem_ch12.adb (Install_Formal_Packages): Do not omit installation of + visible entities when the formal package doesn't have a box. + + * checks.adb: Minor reformatting. + +2009-10-27 Vincent Celier <celier@adacore.com> + + * prj-part.adb (Parse): Catch exception Types.Unrecoverable_Error and + set Project to Empty_Node. + +2009-10-27 Robert Dewar <dewar@adacore.com> + + * gnatbind.adb: Minor reformatting + +2009-10-27 Arnaud Charlet <charlet@adacore.com> + + * exp_aggr.adb: Fix comment. + +2009-10-27 Emmanuel Briot <briot@adacore.com> + + * prj-err.adb (Error_Msg): take into account continuation lines when + computing whether we have a warning. + +2009-10-27 Vasiliy Fofanov <fofanov@adacore.com> + + * make.adb, s-os_lib.adb, s-os_lib.ads (Create_Temp_Output_File): New + routine that is designed to create temp file descriptor specifically + for redirecting an output stream. + +2009-10-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: When + processing the parent type, build the COMPONENT_REF for a discriminant + with the proper type. + +2009-10-24 Eric Botcazou <ebotcazou@adacore.com> + + * init.c (__gnat_adjust_context_for_raise): Mention _Unwind_GetIPInfo. + * gcc-interface/Makefile.in (GNATLIBCFLAGS_FOR_C): Add HAVE_GETIPINFO. + Pass GNATLIBCFLAGS_FOR_C to recursive invocations. + +2009-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interfaces/decl.c (build_subst_list): Convert the expression of + the constraint to the type of the discriminant. + +2009-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interfaces/decl.c (gnat_to_gnu_entity): Do not create a new + TYPE_DECL when a type is padded if there is already one and reset + TYPE_STUB_DECL in this case. + +2009-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interfaces/utils.c (create_subprog_decl): Do not redefine + main_identifier_node. + +2009-10-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (convert): When converting to a padded type + with an inner type of self-referential size, pad the expression before + doing the unchecked conversion. + +2009-10-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.c (build_binary_op) <ARRAY_RANGE_REF>: Make + sure the element type is consistent. + +2009-10-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (addressable_p): Handle bitwise operations. + +2009-10-16 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (TYPE_FAT_POINTER_P): Swap with... + (TYPE_IS_FAT_POINTER_P): ...this. + (TYPE_THIN_POINTER_P): Rename into... + (TYPE_IS_THIN_POINTER_P): ...this. + (TYPE_FAT_OR_THIN_POINTER_P): Rename into... + (TYPE_IS_FAT_OR_THIN_POINTER_P): ...this. + (TYPE_IS_PADDING_P): Change definition, move old one to... + (TYPE_PADDING_P): ...this. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust for above changes. + (get_unpadded_type): Likewise. + (gnat_to_gnu_component_type): Likewise. + (gnat_to_gnu_param): Likewise. + (relate_alias_sets): Likewise. + (make_packable_type): Likewise. + (maybe_pad_type): Likewise. + (gnat_to_gnu_field): Likewise. + (is_variable_size): Likewise. + (annotate_object): Likewise. + (validate_size): Likewise. + (set_rm_size): Likewise. + (make_type_from_size): Likewise. + (rm_size): Likewise. + * gcc-interface/misc.c (gnat_print_type): Likewise. + (gnat_get_alias_set): Likewise. + * gcc-interface/trans.c (Identifier_to_gnu): Likewise. + (Attribute_to_gnu): Likewise. + (call_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (add_decl_expr): Likewise. + (convert_with_check): Likewise. + (addressable_p): Likewise. + (maybe_implicit_deref): Likewise. + (protect_multiple_eval): Likewise. + (gnat_stabilize_reference_1): Likewise. + * gcc-interface/utils.c (gnat_pushdecl): Likewise. + (finish_record_type): Likewise. + (rest_of_record_type_compilation): Likewise. + (create_type_decl): Likewise. + (gnat_types_compatible_p): Likewise. + (build_template): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (build_unc_object_type_from_ptr): Likewise. + (update_pointer_to): Likewise. + (convert_to_fat_pointer): Likewise. + (convert_to_fat_pointer): Likewise. + (convert): Likewise. + (remove_conversions): Likewise. + (maybe_unconstrained_array): Likewise. + (unchecked_convert): Likewise. + (handle_vector_type_attribute): Likewise. + * gcc-interface/utils2.c (build_binary_op): Likewise. + (build_unary_op): Likewise. + (build_allocator): Likewise. + +2009-10-16 Eric Botcazou <ebotcazou@adacore.com> + + * exp_dbug.ads: Adjust type names in comments. + * gcc-interface/decl.c (maybe_pad_type): Remove NAME_TRAILER parameter, + add new IS_COMPONENT_TYPE parameter. Adjust. Remove dead code. + (gnat_to_gnu_entity): Adjust for above change. + (gnat_to_gnu_component_type): Likewise. + (gnat_to_gnu_field): Likewise. + * gcc-interface/trans.c (call_to_gnu): Likewise. Do not unnecessarily + call max_size. + * gcc-interface/utils.c (finish_record_type): Remove obsolete code. + * gcc-interface/gigi.h (maybe_pad_type): Adjust prototype. + +2009-10-16 Joel Sherrill <joel.sherrill@oarcorp.com> + + * s-osinte-rtems.ads: Add mutex type to pthread_mutexattr_t + * s-stchop-rtems.adb: Correct binding to rtems_stack_checker_is_blown. + +2009-10-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * env.c [__alpha__ && __osf__] (AES_SOURCE): Define. + +2009-10-10 Samuel Tardieu <sam@rfc1149.net> + + * sem_eval.adb: Give a more precise error message. + +2009-10-06 Samuel Tardieu <sam@rfc1149.net> + + PR ada/41383 + * a-rttiev.adb (Time_Of_Event): Return Time_First for unset event. + +2009-10-06 Samuel Tardieu <sam@rfc1149.net> + + PR ada/38333 + * sem_prag.adb (Process_Import_Or_Interface): Forbid an abstract + subprogram to be completed with a "pragma Import". + 2009-10-02 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 5f06d1cf2e8..4f26f1569b5 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -258,6 +258,7 @@ GNATRTL_NONTASKING_OBJS= \ a-timoau$(objext) \ a-timoio$(objext) \ a-tiocst$(objext) \ + a-tirsfi$(objext) \ a-titest$(objext) \ a-tiunio$(objext) \ a-unccon$(objext) \ @@ -265,6 +266,7 @@ GNATRTL_NONTASKING_OBJS= \ a-wichun$(objext) \ a-widcha$(objext) \ a-witeio$(objext) \ + a-wrstfi$(objext) \ a-wtcoau$(objext) \ a-wtcoio$(objext) \ a-wtcstr$(objext) \ @@ -286,6 +288,7 @@ GNATRTL_NONTASKING_OBJS= \ a-wwunio$(objext) \ a-zchara$(objext) \ a-zchuni$(objext) \ + a-zrstfi$(objext) \ a-ztcoau$(objext) \ a-ztcoio$(objext) \ a-ztcstr$(objext) \ diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index f0182c68e7a..1013b1514db 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -210,6 +210,9 @@ package body Ada.Directories is else declare + -- We need to resolve links because of A.16(47), since we must not + -- return alternative names for files. + Norm : constant String := Normalize_Pathname (Name); Last_DS : constant Natural := Strings.Fixed.Index @@ -441,6 +444,8 @@ package body Ada.Directories is Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); declare + -- We need to resolve links because of A.16(47), since we must not + -- return alternative names for files Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len)); begin @@ -781,6 +786,8 @@ package body Ada.Directories is -- Use System.OS_Lib.Normalize_Pathname declare + -- We need to resolve links because of A.16(47), since we must not + -- return alternative names for files Value : constant String := Normalize_Pathname (Name); subtype Result is String (1 .. Value'Length); begin diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index ef9aadd4306..55d14e7db53 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -729,21 +729,12 @@ package body Ada.Numerics.Generic_Elementary_Functions is Raw_Atan : Float_Type'Base; begin - if abs Y > abs X then - Z := abs (X / Y); - else - Z := abs (Y / X); - end if; - - if Z < Sqrt_Epsilon then - Raw_Atan := Z; + Z := (if abs Y > abs X then abs (X / Y) else abs (Y / X)); - elsif Z = 1.0 then - Raw_Atan := Pi / 4.0; - - else - Raw_Atan := Float_Type'Base (Aux.Atan (Double (Z))); - end if; + Raw_Atan := + (if Z < Sqrt_Epsilon then Z + elsif Z = 1.0 then Pi / 4.0 + else Float_Type'Base (Aux.Atan (Double (Z)))); if abs Y > abs X then Raw_Atan := Half_Pi - Raw_Atan; diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb index b0cf3e1fd72..5c8a0092477 100644 --- a/gcc/ada/a-ngrear.adb +++ b/gcc/ada/a-ngrear.adb @@ -433,11 +433,7 @@ package body Ada.Numerics.Generic_Real_Arrays is end if; for J in 1 .. N loop - if Piv (J) /= J then - Det := -Det * LU (J, J); - else - Det := Det * LU (J, J); - end if; + Det := (if Piv (J) /= J then -Det * LU (J, J) else Det * LU (J, J)); end loop; return Det; diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index 2ca4472a5ea..c3cbec69ddc 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, AdaCore -- +-- Copyright (C) 1995-2009, AdaCore -- -- -- -- 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- -- @@ -189,19 +189,12 @@ package body Ada.Real_Time is -- Special-case for Time_First, whose absolute value is anomalous, -- courtesy of two's complement. - if T = Time_First then - T_Val := abs (Time_Last); - else - T_Val := abs (T); - end if; + T_Val := (if T = Time_First then abs (Time_Last) else abs (T)); -- Extract the integer part of T, truncating towards zero - if T_Val < 0.5 then - SC := 0; - else - SC := Seconds_Count (Time_Span'(T_Val - 0.5)); - end if; + SC := + (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5))); if T < 0.0 then SC := -SC; diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb index 2068c786850..55687ec8f6b 100644 --- a/gcc/ada/a-rttiev.adb +++ b/gcc/ada/a-rttiev.adb @@ -332,7 +332,13 @@ package body Ada.Real_Time.Timing_Events is function Time_Of_Event (Event : Timing_Event) return Time is begin - return Event.Timeout; + -- RM D.15(18/2): Time_First must be returned if the event is not set + + if Event.Handler = null then + return Time_First; + else + return Event.Timeout; + end if; end Time_Of_Event; -------------- diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb index cf2f4ea2ee2..79ee6cdfd5a 100644 --- a/gcc/ada/a-ststio.adb +++ b/gcc/ada/a-ststio.adb @@ -241,11 +241,7 @@ package body Ada.Streams.Stream_IO is -- (and furthermore there are situations (such as the case of writing -- a sequential Posix FIFO file) where the lseek would cause problems. - if Mode = Out_File then - File.Last_Op := Op_Write; - else - File.Last_Op := Op_Read; - end if; + File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read); end Open; ---------- diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index b3a98fcb3ec..ceacfe5b127 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -57,15 +57,30 @@ package body Ada.Text_IO is WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files ----------------------- -- Local Subprograms -- ----------------------- - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - function Get_Upper_Half_Char (C : Character; File : File_Type) return Character; @@ -82,18 +97,48 @@ package body Ada.Text_IO is -- This routine is identical to Get_Upper_Half_Char, except that the reads -- are done in Get_Immediate mode (i.e. without waiting for a line return). + function Getc (File : File_Type) return int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + function Has_Upper_Half_Character (Item : String) return Boolean; -- Returns True if any of the characters is in the range 16#80#-16#FF# + function Nextc (File : File_Type) return int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). + procedure Put_Encoded (File : File_Type; Char : Character); -- Called to output a character Char to the given File, when the encoding -- method for the file is other than brackets, and Char is upper half. + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + procedure Set_WCEM (File : in out File_Type); -- Called by Open and Create to set the wide character encoding method for -- the file, processing a WCEM form parameter if one is present. File is -- IN OUT because it may be closed in case of an error. + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + ------------------- -- AFCB_Allocate -- ------------------- @@ -965,6 +1010,52 @@ package body Ada.Text_IO is return False; end Has_Upper_Half_Character; + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + ------------- -- Is_Open -- ------------- @@ -2198,20 +2289,8 @@ package body Ada.Text_IO is end if; end Write; - -- Use "preallocated" strings to avoid calling "new" during the - -- elaboration of the run time. This is needed in the tasking case to - -- avoid calling Task_Lock too early. A filename is expected to end with a - -- null character in the runtime, here the null characters are added just - -- to have a correct filename length. - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - begin - ------------------------------- - -- Initialize Standard Files -- - ------------------------------- + -- Initialize Standard Files for J in WC_Encoding_Method loop if WC_Encoding = WC_Encoding_Letters (J) then @@ -2219,51 +2298,10 @@ begin end if; end loop; - -- Note: the names in these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC test insist! - -- We use names that are bound to fail in open etc. - - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Is_Text_File := True; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Is_Text_File := True; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Is_Text_File := True; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; + Initialize_Standard_Files; FIO.Chain_File (AP (Standard_In)); FIO.Chain_File (AP (Standard_Out)); FIO.Chain_File (AP (Standard_Err)); - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Ada.Text_IO; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads index 9277ccbbae5..d22b2f9c635 100644 --- a/gcc/ada/a-textio.ads +++ b/gcc/ada/a-textio.ads @@ -41,6 +41,7 @@ with Ada.IO_Exceptions; with Ada.Streams; + with System; with System.File_Control_Block; with System.WCh_Con; @@ -443,9 +444,6 @@ private -- The Standard Files -- ------------------------ - Null_Str : aliased constant String := ""; - -- Used as name and form of standard files - Standard_In_AFCB : aliased Text_AFCB; Standard_Out_AFCB : aliased Text_AFCB; Standard_Err_AFCB : aliased Text_AFCB; @@ -460,47 +458,15 @@ private Current_Err : aliased File_Type := Standard_Err; -- Current files - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- These subprograms are in the private part of the spec so that they can - -- be shared by the routines in the body of Ada.Text_IO.Wide_Text_IO. - - -- Note: we use Integer in these declarations instead of the more accurate - -- Interfaces.C_Streams.int, because we do not want to drag in the spec of - -- this interfaces package with the spec of Ada.Text_IO, and we know that - -- in fact these types are identical - function EOF_Char return Integer; -- Returns the system-specific character indicating the end of a text file. -- This is exported for use by child packages such as Enumeration_Aux to - -- eliminate their needing to depend directly on Interfaces.C_Streams. - - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. - - function Nextc (File : File_Type) return Integer; - -- Returns next character from file without skipping past it (i.e. it - -- is a combination of Getc followed by an Ungetc). - - procedure Putc (ch : Integer; File : File_Type); - -- Outputs the given character to the file, which has already been - -- checked for being in output status. Device_Error is raised if the - -- character cannot be written. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current - -- line is not terminated, then a line terminator is written using - -- New_Line. Note that there is no Terminate_Page routine, because - -- the page mark at the end of the file is implied if necessary. - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- and end of file character (EOF) is ignored. + -- eliminate their needing to depend directly on Interfaces.C_Streams, + -- which is not available in certain target environments (such as AAMP). + + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Text_IO.Reset_Standard_Files. end Ada.Text_IO; diff --git a/gcc/ada/a-tideau.adb b/gcc/ada/a-tideau.adb index 298507a5c2c..2790bed68d7 100644 --- a/gcc/ada/a-tideau.adb +++ b/gcc/ada/a-tideau.adb @@ -242,11 +242,8 @@ package body Ada.Text_IO.Decimal_Aux is Ptr : Natural := 0; begin - if Exp = 0 then - Fore := To'Length - 1 - Aft; - else - Fore := To'Length - 2 - Aft - Exp; - end if; + Fore := + (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); if Fore < 1 then raise Layout_Error; diff --git a/gcc/ada/a-tideio.adb b/gcc/ada/a-tideio.adb index 9db04784b95..5dceb128f90 100644 --- a/gcc/ada/a-tideio.adb +++ b/gcc/ada/a-tideio.adb @@ -51,7 +51,6 @@ package body Ada.Text_IO.Decimal_IO is begin if Num'Size > Integer'Size then Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale)); - else Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale)); end if; diff --git a/gcc/ada/a-tirsfi.adb b/gcc/ada/a-tirsfi.adb new file mode 100755 index 00000000000..791c066bab3 --- /dev/null +++ b/gcc/ada/a-tirsfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-------------------------------------- +-- Ada.Text_IO.Reset_Standard_Files -- +-------------------------------------- + +procedure Ada.Text_IO.Reset_Standard_Files is +begin + Ada.Text_IO.Initialize_Standard_Files; +end Ada.Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-tirsfi.ads b/gcc/ada/a-tirsfi.ads new file mode 100755 index 00000000000..b3d4ab0afb9 --- /dev/null +++ b/gcc/ada/a-tirsfi.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a reset routine that resets the standard files used +-- by Text_IO. This is useful in systems such as VxWorks where Ada.Text_IO is +-- elaborated at the program start, but a system restart may alter the status +-- of these files, resulting in incorrect operation of Text_IO (in particular +-- if the standard input file is changed to be interactive, then Get_Line may +-- hang looking for an extra character after the end of the line. + +procedure Ada.Text_IO.Reset_Standard_Files; +-- Reset standard Text_IO files as described above diff --git a/gcc/ada/a-wichun.adb b/gcc/ada/a-wichun.adb index 65df45119cc..65df45119cc 100755..100644 --- a/gcc/ada/a-wichun.adb +++ b/gcc/ada/a-wichun.adb diff --git a/gcc/ada/a-wichun.ads b/gcc/ada/a-wichun.ads index af614538067..af614538067 100755..100644 --- a/gcc/ada/a-wichun.ads +++ b/gcc/ada/a-wichun.ads diff --git a/gcc/ada/a-widcha.ads b/gcc/ada/a-widcha.ads index a5dde73f43c..a5dde73f43c 100755..100644 --- a/gcc/ada/a-widcha.ads +++ b/gcc/ada/a-widcha.ads diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index e877405820f..efd5021849d 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -57,26 +57,62 @@ package body Ada.Wide_Text_IO is WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files ----------------------- -- Local Subprograms -- ----------------------- - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - function Get_Wide_Char_Immed (C : Character; File : File_Type) return Wide_Character; -- This routine is identical to Get_Wide_Char, except that the reads are -- done in Get_Immediate mode (i.e. without waiting for a line return). + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + procedure Set_WCEM (File : in out File_Type); -- Called by Open and Create to set the wide character encoding method for -- the file, processing a WCEM form parameter if one is present. File is -- IN OUT because it may be closed in case of an error. + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + ------------------- -- AFCB_Allocate -- ------------------- @@ -843,6 +879,52 @@ package body Ada.Wide_Text_IO is return ch; end Getc_Immed; + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + ------------- -- Is_Open -- ------------- @@ -856,9 +938,9 @@ package body Ada.Wide_Text_IO is -- Line -- ---------- - -- Note: we assume that it is impossible in practice for the line - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. + -- Note: we assume that it is impossible in practice for the line to exceed + -- the value of Count'Last, i.e. no check is required for overflow raising + -- layout error. function Line (File : File_Type) return Positive_Count is begin @@ -1840,20 +1922,8 @@ package body Ada.Wide_Text_IO is set_text_mode (fileno (File.Stream)); end Write; - -- Use "preallocated" strings to avoid calling "new" during the - -- elaboration of the run time. This is needed in the tasking case to - -- avoid calling Task_Lock too early. A filename is expected to end with - -- a null character in the runtime, here the null characters are added - -- just to have a correct filename length. - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - begin - ------------------------------- - -- Initialize Standard Files -- - ------------------------------- + -- Initialize Standard Files for J in WC_Encoding_Method loop if WC_Encoding = WC_Encoding_Letters (J) then @@ -1861,51 +1931,10 @@ begin end if; end loop; - -- Note: the names in these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC test insist! - -- We use names that are bound to fail in open etc. - - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Is_Text_File := True; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Is_Text_File := True; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Is_Text_File := True; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; + Initialize_Standard_Files; FIO.Chain_File (AP (Standard_In)); FIO.Chain_File (AP (Standard_Out)); FIO.Chain_File (AP (Standard_Err)); - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads index 0af805eb980..2cf02b69b05 100644 --- a/gcc/ada/a-witeio.ads +++ b/gcc/ada/a-witeio.ads @@ -42,6 +42,9 @@ with Ada.IO_Exceptions; with Ada.Streams; + +with Interfaces.C_Streams; + with System; with System.File_Control_Block; with System.WCh_Con; @@ -441,9 +444,6 @@ private -- The Standard Files -- ------------------------ - Null_Str : aliased constant String := ""; - -- Used as name and form of standard files - Standard_Err_AFCB : aliased Wide_Text_AFCB; Standard_In_AFCB : aliased Wide_Text_AFCB; Standard_Out_AFCB : aliased Wide_Text_AFCB; @@ -458,26 +458,24 @@ private Current_Err : aliased File_Type := Standard_Err; -- Current files + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Wide_Text_IO.Reset_Standard_Files. + ----------------------- -- Local Subprograms -- ----------------------- -- These subprograms are in the private part of the spec so that they can - -- be shared by the routines in the body of Ada.Text_IO.Wide_Text_IO. - - -- Note: we use Integer in these declarations instead of the more accurate - -- Interfaces.C_Streams.int, because we do not want to drag in the spec of - -- this interfaces package with the spec of Ada.Text_IO, and we know that - -- in fact these types are identical + -- be shared by the children of Ada.Wide_Text_IO. - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. + function Getc (File : File_Type) return Interfaces.C_Streams.int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. - procedure Get_Character - (File : File_Type; - Item : out Character); + procedure Get_Character (File : File_Type; Item : out Character); -- This is essentially a copy of the normal Get routine from Text_IO. It -- obtains a single character from the input file File, and places it in -- Item. This character may be the leading character of a Wide_Character @@ -491,25 +489,8 @@ private -- read and is passed in C. The wide character value is returned as the -- result, and the file pointer is bumped past the character. - function Nextc (File : File_Type) return Integer; - -- Returns next character from file without skipping past it (i.e. it - -- is a combination of Getc followed by an Ungetc). - - procedure Putc (ch : Integer; File : File_Type); - -- Outputs the given character to the file, which has already been - -- checked for being in output status. Device_Error is raised if the - -- character cannot be written. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current - -- line is not terminated, then a line terminator is written using - -- New_Line. Note that there is no Terminate_Page routine, because - -- the page mark at the end of the file is implied if necessary. - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- and end of file character (EOF) is ignored. + function Nextc (File : File_Type) return Interfaces.C_Streams.int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-wrstfi.adb b/gcc/ada/a-wrstfi.adb new file mode 100644 index 00000000000..6b3f656b670 --- /dev/null +++ b/gcc/ada/a-wrstfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------- +-- Ada.Wide_Text_IO.Reset_Standard_Files -- +------------------------------------------- + +procedure Ada.Wide_Text_IO.Reset_Standard_Files is +begin + Ada.Wide_Text_IO.Initialize_Standard_Files; +end Ada.Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-wrstfi.ads b/gcc/ada/a-wrstfi.ads new file mode 100644 index 00000000000..5d6548eadc5 --- /dev/null +++ b/gcc/ada/a-wrstfi.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a reset routine that resets the standard files used +-- by Ada.Wide_Text_IO. This is useful in systems such as VxWorks where +-- Ada.Wide_Text_IO is elaborated at the program start, but a system restart +-- may alter the status of these files, resulting in incorrect operation of +-- Wide_Text_IO (in particular if the standard input file is changed to be +-- interactive, then Get_Line may hang looking for an extra character after +-- the end of the line. + +procedure Ada.Wide_Text_IO.Reset_Standard_Files; +-- Reset standard Wide_Text_IO files as described above diff --git a/gcc/ada/a-wtdeio.adb b/gcc/ada/a-wtdeio.adb index 8d42e85d54e..598b72a941e 100644 --- a/gcc/ada/a-wtdeio.adb +++ b/gcc/ada/a-wtdeio.adb @@ -54,16 +54,10 @@ package body Ada.Wide_Text_IO.Decimal_IO is is begin if Num'Size > Integer'Size then - Item := Num (Aux.Get_LLD (TFT (File), Width, Scale)); - -- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); - -- above is what we should write, but gets assert error ??? - + Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); else - Item := Num (Aux.Get_Dec (TFT (File), Width, Scale)); - -- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); - -- above is what we should write, but gets assert error ??? + Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); end if; - exception when Constraint_Error => raise Data_Error; end Get; diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb index dbe09a9df15..cc41dc1cd86 100644 --- a/gcc/ada/a-wtedit.adb +++ b/gcc/ada/a-wtedit.adb @@ -477,21 +477,17 @@ package body Ada.Wide_Text_IO.Editing is raise Layout_Error; end if; - if Pic.Radix_Position = Invalid_Position then - Position := Answer'Last; - else - Position := Pic.Radix_Position - 1; - end if; + Position := + (if Pic.Radix_Position = Invalid_Position then Answer'Last + else Pic.Radix_Position - 1); for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop - while Answer (Position) /= '9' and then Answer (Position) /= Pic.Floater loop if Answer (Position) = '_' then Answer (Position) := Separator_Character; - elsif Answer (Position) = 'b' then Answer (Position) := ' '; end if; @@ -790,25 +786,22 @@ package body Ada.Wide_Text_IO.Editing is -- No trailing digits, but now J may need to stick in a currency -- symbol or sign. - if Pic.Start_Currency = Invalid_Position then - Position := Answer'Last + 1; - else - Position := Pic.Start_Currency; - end if; + Position := + (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 + else Pic.Start_Currency); end if; for J in Position .. Answer'Last loop - if Pic.Start_Currency /= Invalid_Position and then Answer (Pic.Start_Currency) = '#' then Currency_Pos := 1; end if; - -- Note: There are some weird cases J can imagine with 'b' or '#' - -- in currency strings where the following code will cause - -- glitches. The trick is to tell when the character in the - -- answer should be checked, and when to look at the original - -- string. Some other time. RIE 11/26/96 ??? + -- Note: There are some weird cases J can imagine with 'b' or '#' in + -- currency strings where the following code will cause glitches. The + -- trick is to tell when the character in the answer should be + -- checked, and when to look at the original string. Some other time. + -- RIE 11/26/96 ??? case Answer (J) is when '*' => @@ -942,8 +935,9 @@ package body Ada.Wide_Text_IO.Editing is -- 1) Expand $, replace '.' with Radix_Point - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); + return + Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); else -- 2) No currency expansion, replace '.' with Radix_Point diff --git a/gcc/ada/a-zrstfi.adb b/gcc/ada/a-zrstfi.adb new file mode 100755 index 00000000000..e0a7f64b662 --- /dev/null +++ b/gcc/ada/a-zrstfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------------ +-- Ada.Wide_Wide_Text_IO.Reset_Standard_Files -- +------------------------------------------------ + +procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files is +begin + Ada.Wide_Wide_Text_IO.Initialize_Standard_Files; +end Ada.Wide_Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-zrstfi.ads b/gcc/ada/a-zrstfi.ads new file mode 100755 index 00000000000..80f2b1f2cdf --- /dev/null +++ b/gcc/ada/a-zrstfi.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a reset routine that resets the standard files used +-- by Ada.Wide_Wide_Text_IO. This is useful in systems such as VxWorks where +-- Ada.Wide_Wide_Text_IO is elaborated at the program start, but a system +-- restart may alter the status of these files, resulting in incorrect +-- operation of Wide_Wide_Text_IO (in particular if the standard input file +-- is changed to be interactive, then Get_Line may hang looking for an extra +-- character after the end of the line. + +procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files; +-- Reset standard Wide_Wide_Text_IO files as described above diff --git a/gcc/ada/a-ztdeau.adb b/gcc/ada/a-ztdeau.adb index b9feb4c1723..38450fcb011 100644 --- a/gcc/ada/a-ztdeau.adb +++ b/gcc/ada/a-ztdeau.adb @@ -244,11 +244,8 @@ package body Ada.Wide_Wide_Text_IO.Decimal_Aux is Ptr : Natural := 0; begin - if Exp = 0 then - Fore := To'Length - 1 - Aft; - else - Fore := To'Length - 2 - Aft - Exp; - end if; + Fore := + (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); if Fore < 1 then raise Layout_Error; diff --git a/gcc/ada/a-ztdeio.adb b/gcc/ada/a-ztdeio.adb index cc61e8cbff9..52f8820a787 100644 --- a/gcc/ada/a-ztdeio.adb +++ b/gcc/ada/a-ztdeio.adb @@ -54,16 +54,10 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is is begin if Num'Size > Integer'Size then - Item := Num (Aux.Get_LLD (TFT (File), Width, Scale)); - -- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); - -- above is what we should write, but gets assert error ??? - + Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); else - Item := Num (Aux.Get_Dec (TFT (File), Width, Scale)); - -- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); - -- above is what we should write, but gets assert error ??? + Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); end if; - exception when Constraint_Error => raise Data_Error; end Get; diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb index 555e66491ef..9b5036a4d08 100644 --- a/gcc/ada/a-ztedit.adb +++ b/gcc/ada/a-ztedit.adb @@ -478,21 +478,17 @@ package body Ada.Wide_Wide_Text_IO.Editing is raise Layout_Error; end if; - if Pic.Radix_Position = Invalid_Position then - Position := Answer'Last; - else - Position := Pic.Radix_Position - 1; - end if; + Position := + (if Pic.Radix_Position = Invalid_Position then Answer'Last + else Pic.Radix_Position - 1); for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop - while Answer (Position) /= '9' and then Answer (Position) /= Pic.Floater loop if Answer (Position) = '_' then Answer (Position) := Separator_Character; - elsif Answer (Position) = 'b' then Answer (Position) := ' '; end if; @@ -791,15 +787,12 @@ package body Ada.Wide_Wide_Text_IO.Editing is -- No trailing digits, but now J may need to stick in a currency -- symbol or sign. - if Pic.Start_Currency = Invalid_Position then - Position := Answer'Last + 1; - else - Position := Pic.Start_Currency; - end if; + Position := + (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 + else Pic.Start_Currency); end if; for J in Position .. Answer'Last loop - if Pic.Start_Currency /= Invalid_Position and then Answer (Pic.Start_Currency) = '#' then Currency_Pos := 1; diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb index 64ad87215db..8be8a91d9e2 100644 --- a/gcc/ada/a-ztexio.adb +++ b/gcc/ada/a-ztexio.adb @@ -57,26 +57,62 @@ package body Ada.Wide_Wide_Text_IO is WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files ----------------------- -- Local Subprograms -- ----------------------- - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - function Get_Wide_Wide_Char_Immed (C : Character; File : File_Type) return Wide_Wide_Character; -- This routine is identical to Get_Wide_Wide_Char, except that the reads -- are done in Get_Immediate mode (i.e. without waiting for a line return). + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + procedure Set_WCEM (File : in out File_Type); -- Called by Open and Create to set the wide character encoding method for -- the file, processing a WCEM form parameter if one is present. File is -- IN OUT because it may be closed in case of an error. + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + ------------------- -- AFCB_Allocate -- ------------------- @@ -843,6 +879,52 @@ package body Ada.Wide_Wide_Text_IO is return ch; end Getc_Immed; + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + ------------- -- Is_Open -- ------------- @@ -1840,20 +1922,8 @@ package body Ada.Wide_Wide_Text_IO is set_text_mode (fileno (File.Stream)); end Write; - -- Use "preallocated" strings to avoid calling "new" during the - -- elaboration of the run time. This is needed in the tasking case to - -- avoid calling Task_Lock too early. A filename is expected to end with - -- a null character in the runtime, here the null characters are added - -- just to have a correct filename length. - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - begin - ------------------------------- - -- Initialize Standard Files -- - ------------------------------- + -- Initialize Standard Files for J in WC_Encoding_Method loop if WC_Encoding = WC_Encoding_Letters (J) then @@ -1861,51 +1931,10 @@ begin end if; end loop; - -- Note: the names in these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC test insist! - -- We use names that are bound to fail in open etc. - - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Is_Text_File := True; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Is_Text_File := True; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Is_Text_File := True; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; + Initialize_Standard_Files; FIO.Chain_File (AP (Standard_In)); FIO.Chain_File (AP (Standard_Out)); FIO.Chain_File (AP (Standard_Err)); - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads index 81ab9924775..6c75acd1936 100644 --- a/gcc/ada/a-ztexio.ads +++ b/gcc/ada/a-ztexio.ads @@ -42,6 +42,9 @@ with Ada.IO_Exceptions; with Ada.Streams; + +with Interfaces.C_Streams; + with System; with System.File_Control_Block; with System.WCh_Con; @@ -357,13 +360,13 @@ private PM : constant := Character'Pos (ASCII.FF); -- Used as page mark, except at end of file where it is implied - ------------------------------------- + ------------------------------------------ -- Wide_Wide_Text_IO File Control Block -- - ------------------------------------- + ------------------------------------------ Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; - -- This gets modified during initialization (see body) using - -- the default value established in the call to Set_Globals. + -- This gets modified during initialization (see body) using the default + -- value established in the call to Set_Globals. package FCB renames System.File_Control_Block; @@ -443,9 +446,6 @@ private -- The Standard Files -- ------------------------ - Null_Str : aliased constant String := ""; - -- Used as name and form of standard files - Standard_Err_AFCB : aliased Wide_Wide_Text_AFCB; Standard_In_AFCB : aliased Wide_Wide_Text_AFCB; Standard_Out_AFCB : aliased Wide_Wide_Text_AFCB; @@ -460,31 +460,28 @@ private Current_Err : aliased File_Type := Standard_Err; -- Current files + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Wide_Wide_Text_IO.Reset_Standard_Files. + ----------------------- -- Local Subprograms -- ----------------------- -- These subprograms are in the private part of the spec so that they can - -- be shared by the routines in the body of Ada.Text_IO.Wide_Wide_Text_IO. - - -- Note: we use Integer in these declarations instead of the more accurate - -- Interfaces.C_Streams.int, because we do not want to drag in the spec of - -- this interfaces package with the spec of Ada.Text_IO, and we know that - -- in fact these types are identical + -- be shared by the children of Ada.Text_IO.Wide_Wide_Text_IO. - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. + function Getc (File : File_Type) return Interfaces.C_Streams.int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. - procedure Get_Character - (File : File_Type; - Item : out Character); - -- This is essentially a copy of the normal Get routine from Text_IO. It + procedure Get_Character (File : File_Type; Item : out Character); + -- This is essentially copy of Wide_Wide_Text_IO.Get. It obtains a single -- obtains a single character from the input file File, and places it in - -- Item. This character may be the leading character of a - -- Wide_Wide_Character sequence, but that is up to the caller to deal - -- with. + -- Item. This result may be the leading character of a Wide_Wide_Character + -- sequence, but that is up to the caller to deal with. function Get_Wide_Wide_Char (C : Character; @@ -494,25 +491,8 @@ private -- read and is passed in C. The wide character value is returned as the -- result, and the file pointer is bumped past the character. - function Nextc (File : File_Type) return Integer; - -- Returns next character from file without skipping past it (i.e. it - -- is a combination of Getc followed by an Ungetc). - - procedure Putc (ch : Integer; File : File_Type); - -- Outputs the given character to the file, which has already been - -- checked for being in output status. Device_Error is raised if the - -- character cannot be written. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current - -- line is not terminated, then a line terminator is written using - -- New_Line. Note that there is no Terminate_Page routine, because - -- the page mark at the end of the file is implied if necessary. - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- and end of file character (EOF) is ignored. + function Nextc (File : File_Type) return Interfaces.C_Streams.int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index c3405daaf44..5bce387d2bb 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -324,6 +324,12 @@ const int __gnat_vmsp = 0; #endif +/* Used for Ada bindings */ +const int __gnat_size_of_file_attributes = sizeof (struct file_attributes); + +/* Reset the file attributes as if no system call had been performed */ +void __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr); + /* The __gnat_max_path_len variable is used to export the maximum length of a path name to Ada code. max_path_len is also provided for compatibility with older GNAT versions, please do not use @@ -371,6 +377,24 @@ to_ptr32 (char **ptr64) #define MAYBE_TO_PTR32(argv) argv #endif +void +__gnat_reset_attributes + (struct file_attributes* attr) +{ + attr->exists = -1; + + attr->writable = -1; + attr->readable = -1; + attr->executable = -1; + + attr->regular = -1; + attr->symbolic_link = -1; + attr->directory = -1; + + attr->timestamp = (OS_Time)-2; + attr->file_length = -1; +} + OS_Time __gnat_current_time (void) @@ -923,6 +947,28 @@ __gnat_create_output_file (char *path) } int +__gnat_create_output_file_new (char *path) +{ + int fd; +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM, + "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk", + "shr=del,get,put,upd"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); + } +#else + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +int __gnat_open_append (char *path, int fmode) { int fd; @@ -1014,42 +1060,89 @@ __gnat_open_new_temp (char *path, int fmode) return fd < 0 ? -1 : fd; } -/* Return the number of bytes in the specified file. */ +/**************************************************************** + ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information + ** as possible from it, storing the result in a cache for later reuse + ****************************************************************/ -long -__gnat_file_length (int fd) +void +__gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) { - int ret; GNAT_STRUCT_STAT statbuf; + int ret; - ret = GNAT_FSTAT (fd, &statbuf); - if (ret || !S_ISREG (statbuf.st_mode)) - return 0; + if (fd != -1) + ret = GNAT_FSTAT (fd, &statbuf); + else + ret = __gnat_stat (name, &statbuf); + + attr->regular = (!ret && S_ISREG (statbuf.st_mode)); + attr->directory = (!ret && S_ISDIR (statbuf.st_mode)); + + if (!attr->regular) + attr->file_length = 0; + else + /* st_size may be 32 bits, or 64 bits which is converted to long. We + don't return a useful value for files larger than 2 gigabytes in + either case. */ + attr->file_length = statbuf.st_size; /* all systems */ + +#ifndef __MINGW32__ + /* on Windows requires extra system call, see comment in __gnat_file_exists_attr */ + attr->exists = !ret; +#endif - /* st_size may be 32 bits, or 64 bits which is converted to long. We - don't return a useful value for files larger than 2 gigabytes in - either case. */ +#if !defined (_WIN32) || defined (RTX) + /* on Windows requires extra system call, see __gnat_is_readable_file_attr */ + attr->readable = (!ret && (statbuf.st_mode & S_IRUSR)); + attr->writable = (!ret && (statbuf.st_mode & S_IWUSR)); + attr->executable = (!ret && (statbuf.st_mode & S_IXUSR)); +#endif + +#if !defined (__EMX__) && !defined (MSDOS) && (!defined (_WIN32) || defined (RTX)) + /* on Windows requires extra system call, see __gnat_file_time_name_attr */ + if (ret != 0) { + attr->timestamp = (OS_Time)-1; + } else { +#ifdef VMS + /* VMS has file versioning. */ + attr->timestamp = (OS_Time)statbuf.st_ctime; +#else + attr->timestamp = (OS_Time)statbuf.st_mtime; +#endif + } +#endif - return (statbuf.st_size); } -/* Return the number of bytes in the specified named file. */ +/**************************************************************** + ** Return the number of bytes in the specified file + ****************************************************************/ long -__gnat_named_file_length (char *name) +__gnat_file_length_attr (int fd, char* name, struct file_attributes* attr) { - int ret; - GNAT_STRUCT_STAT statbuf; + if (attr->file_length == -1) { + __gnat_stat_to_attr (fd, name, attr); + } - ret = __gnat_stat (name, &statbuf); - if (ret || !S_ISREG (statbuf.st_mode)) - return 0; + return attr->file_length; +} - /* st_size may be 32 bits, or 64 bits which is converted to long. We - don't return a useful value for files larger than 2 gigabytes in - either case. */ +long +__gnat_file_length (int fd) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_length_attr (fd, NULL, &attr); +} - return (statbuf.st_size); +long +__gnat_named_file_length (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_length_attr (-1, name, &attr); } /* Create a temporary filename and put it in string pointed to by @@ -1244,137 +1337,136 @@ win32_filetime (HANDLE h) /* Return a GNAT time stamp given a file name. */ OS_Time -__gnat_file_time_name (char *name) +__gnat_file_time_name_attr (char* name, struct file_attributes* attr) { - + if (attr->timestamp == (OS_Time)-2) { #if defined (__EMX__) || defined (MSDOS) - int fd = open (name, O_RDONLY | O_BINARY); - time_t ret = __gnat_file_time_fd (fd); - close (fd); - return (OS_Time)ret; + int fd = open (name, O_RDONLY | O_BINARY); + time_t ret = __gnat_file_time_fd (fd); + close (fd); + attr->timestamp = (OS_Time)ret; #elif defined (_WIN32) && !defined (RTX) - time_t ret = -1; - TCHAR wname[GNAT_MAX_PATH_LEN]; - - S2WSC (wname, name, GNAT_MAX_PATH_LEN); + time_t ret = -1; + TCHAR wname[GNAT_MAX_PATH_LEN]; + S2WSC (wname, name, GNAT_MAX_PATH_LEN); - HANDLE h = CreateFile - (wname, GENERIC_READ, FILE_SHARE_READ, 0, - OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); + HANDLE h = CreateFile + (wname, GENERIC_READ, FILE_SHARE_READ, 0, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); - if (h != INVALID_HANDLE_VALUE) - { - ret = win32_filetime (h); - CloseHandle (h); - } - return (OS_Time) ret; -#else - GNAT_STRUCT_STAT statbuf; - if (__gnat_stat (name, &statbuf) != 0) { - return (OS_Time)-1; - } else { -#ifdef VMS - /* VMS has file versioning. */ - return (OS_Time)statbuf.st_ctime; + if (h != INVALID_HANDLE_VALUE) { + ret = win32_filetime (h); + CloseHandle (h); + } + attr->timestamp = (OS_Time) ret; #else - return (OS_Time)statbuf.st_mtime; + __gnat_stat_to_attr (-1, name, attr); #endif } -#endif + return attr->timestamp; +} + +OS_Time +__gnat_file_time_name (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_time_name_attr (name, &attr); } /* Return a GNAT time stamp given a file descriptor. */ OS_Time -__gnat_file_time_fd (int fd) +__gnat_file_time_fd_attr (int fd, struct file_attributes* attr) { - /* The following workaround code is due to the fact that under EMX and - DJGPP fstat attempts to convert time values to GMT rather than keep the - actual OS timestamp of the file. By using the OS2/DOS functions directly - the GNAT timestamp are independent of this behavior, which is desired to - facilitate the distribution of GNAT compiled libraries. */ + if (attr->timestamp == (OS_Time)-2) { + /* The following workaround code is due to the fact that under EMX and + DJGPP fstat attempts to convert time values to GMT rather than keep the + actual OS timestamp of the file. By using the OS2/DOS functions directly + the GNAT timestamp are independent of this behavior, which is desired to + facilitate the distribution of GNAT compiled libraries. */ #if defined (__EMX__) || defined (MSDOS) #ifdef __EMX__ - FILESTATUS fs; - int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs, - sizeof (FILESTATUS)); + FILESTATUS fs; + int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs, + sizeof (FILESTATUS)); - unsigned file_year = fs.fdateLastWrite.year; - unsigned file_month = fs.fdateLastWrite.month; - unsigned file_day = fs.fdateLastWrite.day; - unsigned file_hour = fs.ftimeLastWrite.hours; - unsigned file_min = fs.ftimeLastWrite.minutes; - unsigned file_tsec = fs.ftimeLastWrite.twosecs; + unsigned file_year = fs.fdateLastWrite.year; + unsigned file_month = fs.fdateLastWrite.month; + unsigned file_day = fs.fdateLastWrite.day; + unsigned file_hour = fs.ftimeLastWrite.hours; + unsigned file_min = fs.ftimeLastWrite.minutes; + unsigned file_tsec = fs.ftimeLastWrite.twosecs; #else - struct ftime fs; - int ret = getftime (fd, &fs); + struct ftime fs; + int ret = getftime (fd, &fs); - unsigned file_year = fs.ft_year; - unsigned file_month = fs.ft_month; - unsigned file_day = fs.ft_day; - unsigned file_hour = fs.ft_hour; - unsigned file_min = fs.ft_min; - unsigned file_tsec = fs.ft_tsec; + unsigned file_year = fs.ft_year; + unsigned file_month = fs.ft_month; + unsigned file_day = fs.ft_day; + unsigned file_hour = fs.ft_hour; + unsigned file_min = fs.ft_min; + unsigned file_tsec = fs.ft_tsec; #endif - /* Calculate the seconds since epoch from the time components. First count - the whole days passed. The value for years returned by the DOS and OS2 - functions count years from 1980, so to compensate for the UNIX epoch which - begins in 1970 start with 10 years worth of days and add days for each - four year period since then. */ + /* Calculate the seconds since epoch from the time components. First count + the whole days passed. The value for years returned by the DOS and OS2 + functions count years from 1980, so to compensate for the UNIX epoch which + begins in 1970 start with 10 years worth of days and add days for each + four year period since then. */ - time_t tot_secs; - int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; - int days_passed = 3652 + (file_year / 4) * 1461; - int years_since_leap = file_year % 4; + time_t tot_secs; + int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; + int days_passed = 3652 + (file_year / 4) * 1461; + int years_since_leap = file_year % 4; - if (years_since_leap == 1) - days_passed += 366; - else if (years_since_leap == 2) - days_passed += 731; - else if (years_since_leap == 3) - days_passed += 1096; + if (years_since_leap == 1) + days_passed += 366; + else if (years_since_leap == 2) + days_passed += 731; + else if (years_since_leap == 3) + days_passed += 1096; - if (file_year > 20) - days_passed -= 1; + if (file_year > 20) + days_passed -= 1; - days_passed += cum_days[file_month - 1]; - if (years_since_leap == 0 && file_year != 20 && file_month > 2) - days_passed++; + days_passed += cum_days[file_month - 1]; + if (years_since_leap == 0 && file_year != 20 && file_month > 2) + days_passed++; - days_passed += file_day - 1; + days_passed += file_day - 1; - /* OK - have whole days. Multiply -- then add in other parts. */ + /* OK - have whole days. Multiply -- then add in other parts. */ - tot_secs = days_passed * 86400; - tot_secs += file_hour * 3600; - tot_secs += file_min * 60; - tot_secs += file_tsec * 2; - return (OS_Time) tot_secs; + tot_secs = days_passed * 86400; + tot_secs += file_hour * 3600; + tot_secs += file_min * 60; + tot_secs += file_tsec * 2; + attr->timestamp = (OS_Time) tot_secs; #elif defined (_WIN32) && !defined (RTX) - HANDLE h = (HANDLE) _get_osfhandle (fd); - time_t ret = win32_filetime (h); - return (OS_Time) ret; + HANDLE h = (HANDLE) _get_osfhandle (fd); + time_t ret = win32_filetime (h); + attr->timestamp = (OS_Time) ret; #else - GNAT_STRUCT_STAT statbuf; - - if (GNAT_FSTAT (fd, &statbuf) != 0) { - return (OS_Time) -1; - } else { -#ifdef VMS - /* VMS has file versioning. */ - return (OS_Time) statbuf.st_ctime; -#else - return (OS_Time) statbuf.st_mtime; -#endif - } + __gnat_stat_to_attr (fd, NULL, attr); #endif + } + + return attr->timestamp; +} + +OS_Time +__gnat_file_time_fd (int fd) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_time_fd_attr (fd, &attr); } /* Set the file time stamp. */ @@ -1700,24 +1792,41 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf) #endif } +/************************************************************************* + ** Check whether a file exists + *************************************************************************/ + int -__gnat_file_exists (char *name) +__gnat_file_exists_attr (char* name, struct file_attributes* attr) { + if (attr->exists == -1) { #ifdef __MINGW32__ - /* On Windows do not use __gnat_stat() because a bug in Microsoft - _stat() routine. When the system time-zone is set with a negative - offset the _stat() routine fails on specific files like CON: */ - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; + /* On Windows do not use __gnat_stat() because of a bug in Microsoft + _stat() routine. When the system time-zone is set with a negative + offset the _stat() routine fails on specific files like CON: */ + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + attr->exists = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; #else - GNAT_STRUCT_STAT statbuf; - - return !__gnat_stat (name, &statbuf); + __gnat_stat_to_attr (-1, name, attr); #endif + } + + return attr->exists; +} + +int +__gnat_file_exists (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_exists_attr (name, &attr); } +/********************************************************************** + ** Whether name is an absolute path + **********************************************************************/ + int __gnat_is_absolute_path (char *name, int length) { @@ -1754,23 +1863,39 @@ __gnat_is_absolute_path (char *name, int length) } int +__gnat_is_regular_file_attr (char* name, struct file_attributes* attr) +{ + if (attr->regular == -1) { + __gnat_stat_to_attr (-1, name, attr); + } + + return attr->regular; +} + +int __gnat_is_regular_file (char *name) { - int ret; - GNAT_STRUCT_STAT statbuf; + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_regular_file_attr (name, &attr); +} - ret = __gnat_stat (name, &statbuf); - return (!ret && S_ISREG (statbuf.st_mode)); +int +__gnat_is_directory_attr (char* name, struct file_attributes* attr) +{ + if (attr->directory == -1) { + __gnat_stat_to_attr (-1, name, attr); + } + + return attr->directory; } int __gnat_is_directory (char *name) { - int ret; - GNAT_STRUCT_STAT statbuf; - - ret = __gnat_stat (name, &statbuf); - return (!ret && S_ISDIR (statbuf.st_mode)); + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_directory_attr (name, &attr); } #if defined (_WIN32) && !defined (RTX) @@ -1964,95 +2089,111 @@ __gnat_can_use_acl (TCHAR *wname) #endif /* defined (_WIN32) && !defined (RTX) */ int -__gnat_is_readable_file (char *name) +__gnat_is_readable_file_attr (char* name, struct file_attributes* attr) { + if (attr->readable == -1) { #if defined (_WIN32) && !defined (RTX) - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - GENERIC_MAPPING GenericMapping; - - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - - if (__gnat_can_use_acl (wname)) - { - ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); - GenericMapping.GenericRead = GENERIC_READ; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; - return __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); - } - else - return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericRead = GENERIC_READ; + attr->readable = __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); + } + else + attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; #else - int ret; - int mode; - GNAT_STRUCT_STAT statbuf; - - ret = GNAT_STAT (name, &statbuf); - mode = statbuf.st_mode & S_IRUSR; - return (!ret && mode); + __gnat_stat_to_attr (-1, name, attr); #endif + } + + return attr->readable; } int -__gnat_is_writable_file (char *name) +__gnat_is_readable_file (char *name) { + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_readable_file_attr (name, &attr); +} + +int +__gnat_is_writable_file_attr (char* name, struct file_attributes* attr) +{ + if (attr->writable == -1) { #if defined (_WIN32) && !defined (RTX) - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - GENERIC_MAPPING GenericMapping; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - if (__gnat_can_use_acl (wname)) - { - ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); - GenericMapping.GenericWrite = GENERIC_WRITE; + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericWrite = GENERIC_WRITE; - return __gnat_check_OWNER_ACL - (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping) - && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); - } - else - return !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); + attr->writable = __gnat_check_OWNER_ACL + (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping) + && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); + } + else + attr->writable = !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); #else - int ret; - int mode; - GNAT_STRUCT_STAT statbuf; - - ret = GNAT_STAT (name, &statbuf); - mode = statbuf.st_mode & S_IWUSR; - return (!ret && mode); + __gnat_stat_to_attr (-1, name, attr); #endif + } + + return attr->writable; } int -__gnat_is_executable_file (char *name) +__gnat_is_writable_file (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_writable_file_attr (name, &attr); +} + +int +__gnat_is_executable_file_attr (char* name, struct file_attributes* attr) { + if (attr->executable == -1) { #if defined (_WIN32) && !defined (RTX) - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - GENERIC_MAPPING GenericMapping; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - if (__gnat_can_use_acl (wname)) - { - ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); - GenericMapping.GenericExecute = GENERIC_EXECUTE; + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericExecute = GENERIC_EXECUTE; - return __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); - } - else - return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES - && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4); + attr->executable = __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); + } + else + attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES + && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4); #else - int ret; - int mode; - GNAT_STRUCT_STAT statbuf; - - ret = GNAT_STAT (name, &statbuf); - mode = statbuf.st_mode & S_IXUSR; - return (!ret && mode); + __gnat_stat_to_attr (-1, name, attr); #endif + } + + return attr->executable; +} + +int +__gnat_is_executable_file (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_executable_file_attr (name, &attr); } void @@ -2171,21 +2312,31 @@ __gnat_set_non_readable (char *name) } int -__gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED) +__gnat_is_symbolic_link_attr (char* name, struct file_attributes* attr) { + if (attr->symbolic_link == -1) { #if defined (__vxworks) || defined (__nucleus__) - return 0; + attr->symbolic_link = 0; #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__) - int ret; - GNAT_STRUCT_STAT statbuf; - - ret = GNAT_LSTAT (name, &statbuf); - return (!ret && S_ISLNK (statbuf.st_mode)); - + int ret; + GNAT_STRUCT_STAT statbuf; + ret = GNAT_LSTAT (name, &statbuf); + attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode)); #else - return 0; + attr->symbolic_link = 0; #endif + } + return attr->symbolic_link; +} + +int +__gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_symbolic_link_attr (name, &attr); + } #if defined (sun) && defined (__SVR4) diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 79a1e4eb4bd..76a181a001c 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -68,6 +68,30 @@ typedef long long OS_Time; typedef long OS_Time; #endif +/* A lazy cache for the attributes of a file. On some systems, a single call to + stat() will give all this information, so it is better than doing a system + call every time. On other systems this require several system calls. +*/ + +struct file_attributes { + short exists; + + short writable; + short readable; + short executable; + + short symbolic_link; + short regular; + short directory; + + OS_Time timestamp; + long file_length; +}; +/* WARNING: changing the size here might require changing the constant + * File_Attributes_Size in osint.ads (which should be big enough to + * fit the above struct on any system) + */ + extern int __gnat_max_path_len; extern OS_Time __gnat_current_time (void); extern void __gnat_current_time_string (char *); @@ -121,15 +145,28 @@ extern OS_Time __gnat_file_time_fd (int); extern void __gnat_set_file_time_name (char *, time_t); -extern int __gnat_dup (int); -extern int __gnat_dup2 (int, int); -extern int __gnat_file_exists (char *); -extern int __gnat_is_regular_file (char *); -extern int __gnat_is_absolute_path (char *,int); -extern int __gnat_is_directory (char *); +extern int __gnat_dup (int); +extern int __gnat_dup2 (int, int); +extern int __gnat_file_exists (char *); +extern int __gnat_is_regular_file (char *); +extern int __gnat_is_absolute_path (char *,int); +extern int __gnat_is_directory (char *); extern int __gnat_is_writable_file (char *); extern int __gnat_is_readable_file (char *name); -extern int __gnat_is_executable_file (char *name); +extern int __gnat_is_executable_file (char *name); + +extern void __gnat_reset_attributes (struct file_attributes* attr); +extern long __gnat_file_length_attr (int, char *, struct file_attributes *); +extern OS_Time __gnat_file_time_name_attr (char *, struct file_attributes *); +extern OS_Time __gnat_file_time_fd_attr (int, struct file_attributes *); +extern int __gnat_file_exists_attr (char *, struct file_attributes *); +extern int __gnat_is_regular_file_attr (char *, struct file_attributes *); +extern int __gnat_is_directory_attr (char *, struct file_attributes *); +extern int __gnat_is_readable_file_attr (char *, struct file_attributes *); +extern int __gnat_is_writable_file_attr (char *, struct file_attributes *); +extern int __gnat_is_executable_file_attr (char *, struct file_attributes *); +extern int __gnat_is_symbolic_link_attr (char *, struct file_attributes *); + extern void __gnat_set_non_writable (char *name); extern void __gnat_set_writable (char *name); extern void __gnat_set_executable (char *name); diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index b2357eae970..20438cf66e6 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -190,7 +190,7 @@ package body ALI is function Get_Name (Ignore_Spaces : Boolean := False; - Ignore_Special : Boolean := False)return Name_Id; + Ignore_Special : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 8119a6d7a43..18739e878ed 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -190,7 +190,7 @@ package body Bcheck is else ALI_Path_Id := - Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library); + Osint.Full_Lib_File_Name (ALIs.Table (A).Afile); if Osint.Is_Readonly_Library (ALI_Path_Id) then if Tolerate_Consistency_Errors then Error_Msg ("?{ should be recompiled"); diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d1a2b460c90..ff511665b73 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -28,6 +28,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Ch2; use Exp_Ch2; +with Exp_Ch4; use Exp_Ch4; with Exp_Ch11; use Exp_Ch11; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; @@ -844,7 +845,10 @@ package body Checks is begin -- Skip check if back end does overflow checks, or the overflow flag - -- is not set anyway, or we are not doing code expansion. + -- is not set anyway, or we are not doing code expansion, or the + -- parent node is a type conversion whose operand is an arithmetic + -- operation on signed integers on which the expander can promote + -- later the operands to type Integer (see Expand_N_Type_Conversion). -- Special case CLI target, where arithmetic overflow checks can be -- performed for integer and long_integer @@ -852,6 +856,9 @@ package body Checks is if Backend_Overflow_Checks_On_Target or else not Do_Overflow_Check (N) or else not Expander_Active + or else (Present (Parent (N)) + and then Nkind (Parent (N)) = N_Type_Conversion + and then Integer_Promotion_Possible (Parent (N))) or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) then diff --git a/gcc/ada/env.c b/gcc/ada/env.c index ac6e835df9f..d9486977433 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -29,8 +29,11 @@ * * ****************************************************************************/ -/* Tru64 UNIX <stdlib.h> declares unsetenv() only if _BSD. */ +/* Tru64 UNIX V4.0F <stdlib.h> declares unsetenv() only if AES_SOURCE (which + is plain broken, this should be _AES_SOURCE instead as everywhere else; + Tru64 UNIX V5.1B declares it only if _BSD. */ #if defined (__alpha__) && defined (__osf__) +#define AES_SOURCE #define _BSD #endif diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 913e46df374..0e29af2c64e 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -509,7 +509,7 @@ package body Exp_Aggr is -- 10. No controlled actions need to be generated for components - -- 11. The backend is a No_VM backend and the array has aliased components + -- 11. For a VM back end, the array should have no aliased components function Backend_Processing_Possible (N : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (N); @@ -3298,8 +3298,14 @@ package body Exp_Aggr is N_Discriminant_Specification then Flist := Empty; - else + + elsif Needs_Finalization (Typ) then Flist := Find_Final_List (Access_Type); + + -- Otherwise there are no controlled actions to be performed. + + else + Flist := Empty; end if; if Is_Array_Type (Typ) then diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d5cce9b43ee..48bd566b38b 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -654,10 +654,18 @@ package body Exp_Attr is Make_Build_In_Place_Call_In_Anonymous_Context (Pref); end if; - -- If prefix is a protected type name, this is a reference to - -- the current instance of the type. - - if Is_Protected_Self_Reference (Pref) then + -- If prefix is a protected type name, this is a reference to the + -- current instance of the type. For a component definition, nothing + -- to do (expansion will occur in the init proc). In other contexts, + -- rewrite into reference to current instance. + + if Is_Protected_Self_Reference (Pref) + and then not + (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, + N_Discriminant_Association) + and then Nkind (Parent (Parent (Parent (Parent (N))))) = + N_Component_Definition) + then Rewrite (Pref, Concurrent_Ref (Pref)); Analyze (Pref); end if; @@ -680,9 +688,9 @@ package body Exp_Attr is function Enclosing_Object (N : Node_Id) return Node_Id; -- If N denotes a compound name (selected component, indexed - -- component, or slice), returns the name of the outermost - -- such enclosing object. Otherwise returns N. If the object - -- is a renaming, then the renamed object is returned. + -- component, or slice), returns the name of the outermost such + -- enclosing object. Otherwise returns N. If the object is a + -- renaming, then the renamed object is returned. ---------------------- -- Enclosing_Object -- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 414e5670115..9a91e2aa9bb 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2733,70 +2733,11 @@ package body Exp_Ch3 is Next_Non_Pragma (Decl); end loop; - if Per_Object_Constraint_Components then - - -- Second pass: components with per-object constraints - - Decl := First_Non_Pragma (Component_Items (Comp_List)); - while Present (Decl) loop - Loc := Sloc (Decl); - Id := Defining_Identifier (Decl); - Typ := Etype (Id); - - if Has_Access_Constraint (Id) - and then No (Expression (Decl)) - then - if Has_Non_Null_Base_Init_Proc (Typ) then - Append_List_To (Statement_List, - Build_Initialization_Call (Loc, - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, Loc)), - Typ, - In_Init_Proc => True, - Enclos_Type => Rec_Type, - Discr_Map => Discr_Map)); - - Clean_Task_Names (Typ, Proc_Id); - - elsif Component_Needs_Simple_Initialization (Typ) then - Append_List_To (Statement_List, - Build_Assignment - (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); - end if; - end if; - - Next_Non_Pragma (Decl); - end loop; - end if; - - -- Process the variant part - - if Present (Variant_Part (Comp_List)) then - Alt_List := New_List; - Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); - while Present (Variant) loop - Loc := Sloc (Variant); - Append_To (Alt_List, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_Copy_List (Discrete_Choices (Variant)), - Statements => - Build_Init_Statements (Component_List (Variant)))); - Next_Non_Pragma (Variant); - end loop; - - -- The expression of the case statement which is a reference - -- to one of the discriminants is replaced by the appropriate - -- formal parameter of the initialization procedure. - - Append_To (Statement_List, - Make_Case_Statement (Loc, - Expression => - New_Reference_To (Discriminal ( - Entity (Name (Variant_Part (Comp_List)))), Loc), - Alternatives => Alt_List)); - end if; + -- Set up tasks and protected object support. This needs to be done + -- before any component with a per-object access discriminant + -- constraint, or any variant part (which may contain such + -- components) is initialized, because the initialization of these + -- components may reference the enclosing concurrent object. -- For a task record type, add the task create call and calls -- to bind any interrupt (signal) entries. @@ -2898,6 +2839,71 @@ package body Exp_Ch3 is end if; end if; + if Per_Object_Constraint_Components then + + -- Second pass: components with per-object constraints + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Loc := Sloc (Decl); + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Access_Constraint (Id) + and then No (Expression (Decl)) + then + if Has_Non_Null_Base_Init_Proc (Typ) then + Append_List_To (Statement_List, + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map)); + + Clean_Task_Names (Typ, Proc_Id); + + elsif Component_Needs_Simple_Initialization (Typ) then + Append_List_To (Statement_List, + Build_Assignment + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; + + -- Process the variant part + + if Present (Variant_Part (Comp_List)) then + Alt_List := New_List; + Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (Variant) loop + Loc := Sloc (Variant); + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => + Build_Init_Statements (Component_List (Variant)))); + Next_Non_Pragma (Variant); + end loop; + + -- The expression of the case statement which is a reference + -- to one of the discriminants is replaced by the appropriate + -- formal parameter of the initialization procedure. + + Append_To (Statement_List, + Make_Case_Statement (Loc, + Expression => + New_Reference_To (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Loc), + Alternatives => Alt_List)); + end if; + -- If no initializations when generated for component declarations -- corresponding to this Statement_List, append a null statement -- to the Statement_List to make it a valid Ada tree. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 6a65e10a167..6a7ea4fdb1b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -8042,88 +8042,41 @@ package body Exp_Ch4 is -- have to be sure not to generate junk overflow checks in the first -- place, since it would be trick to remove them here! - declare - Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); - - begin - -- Enable transformation if all conditions are met - - if - -- We only do this transformation for source constructs. We assume - -- that the expander knows what it is doing when it generates code. + if Integer_Promotion_Possible (N) then - Comes_From_Source (N) + -- All conditions met, go ahead with transformation - -- If the operand type is Short_Integer or Short_Short_Integer, - -- then we will promote to Integer, which is available on all - -- targets, and is sufficient to ensure no intermediate overflow. - -- Furthermore it is likely to be as efficient or more efficient - -- than using the smaller type for the computation so we do this - -- unconditionally. - - and then - (Root_Operand_Type = Base_Type (Standard_Short_Integer) - or else - Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) - - -- Test for interesting operation, which includes addition, - -- division, exponentiation, multiplication, subtraction, and - -- unary negation. + declare + Opnd : Node_Id; + L, R : Node_Id; - and then Nkind_In (Operand, N_Op_Add, - N_Op_Divide, - N_Op_Expon, - N_Op_Minus, - N_Op_Multiply, - N_Op_Subtract) - then - -- All conditions met, go ahead with transformation + begin + R := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Standard_Integer, Loc), + Expression => Relocate_Node (Right_Opnd (Operand))); - declare - Opnd : Node_Id; - L, R : Node_Id; + Opnd := New_Op_Node (Nkind (Operand), Loc); + Set_Right_Opnd (Opnd, R); - begin - R := + if Nkind (Operand) in N_Binary_Op then + L := Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Standard_Integer, Loc), - Expression => Relocate_Node (Right_Opnd (Operand))); - - if Nkind (Operand) = N_Op_Minus then - Opnd := Make_Op_Minus (Loc, Right_Opnd => R); + Expression => Relocate_Node (Left_Opnd (Operand))); - else - L := - Make_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Standard_Integer, Loc), - Expression => Relocate_Node (Left_Opnd (Operand))); - - case Nkind (Operand) is - when N_Op_Add => - Opnd := Make_Op_Add (Loc, L, R); - when N_Op_Divide => - Opnd := Make_Op_Divide (Loc, L, R); - when N_Op_Expon => - Opnd := Make_Op_Expon (Loc, L, R); - when N_Op_Multiply => - Opnd := Make_Op_Multiply (Loc, L, R); - when N_Op_Subtract => - Opnd := Make_Op_Subtract (Loc, L, R); - when others => - raise Program_Error; - end case; + Set_Left_Opnd (Opnd, L); + end if; - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => Relocate_Node (Subtype_Mark (N)), - Expression => Opnd)); + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => Relocate_Node (Subtype_Mark (N)), + Expression => Opnd)); - Analyze_And_Resolve (N, Target_Type); - return; - end if; - end; - end if; - end; + Analyze_And_Resolve (N, Target_Type); + return; + end; + end if; -- Do validity check if validity checking operands @@ -9187,6 +9140,51 @@ package body Exp_Ch4 is return; end Insert_Dereference_Action; + -------------------------------- + -- Integer_Promotion_Possible -- + -------------------------------- + + function Integer_Promotion_Possible (N : Node_Id) return Boolean is + Operand : constant Node_Id := Expression (N); + Operand_Type : constant Entity_Id := Etype (Operand); + Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); + + begin + pragma Assert (Nkind (N) = N_Type_Conversion); + + return + + -- We only do the transformation for source constructs. We assume + -- that the expander knows what it is doing when it generates code. + + Comes_From_Source (N) + + -- If the operand type is Short_Integer or Short_Short_Integer, + -- then we will promote to Integer, which is available on all + -- targets, and is sufficient to ensure no intermediate overflow. + -- Furthermore it is likely to be as efficient or more efficient + -- than using the smaller type for the computation so we do this + -- unconditionally. + + and then + (Root_Operand_Type = Base_Type (Standard_Short_Integer) + or else + Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) + + -- Test for interesting operation, which includes addition, + -- division, exponentiation, multiplication, subtraction, absolute + -- value and unary negation. Unary "+" is omitted since it is a + -- no-op and thus can't overflow. + + and then Nkind_In (Operand, N_Op_Abs, + N_Op_Add, + N_Op_Divide, + N_Op_Expon, + N_Op_Minus, + N_Op_Multiply, + N_Op_Subtract); + end Integer_Promotion_Possible; + ------------------------------ -- Make_Array_Comparison_Op -- ------------------------------ diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index d1ed208f1b3..fad8c15eea1 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -88,4 +88,11 @@ package Exp_Ch4 is -- to insert those bodies at the right place. Nod provides the Sloc -- value for generated code. + function Integer_Promotion_Possible (N : Node_Id) return Boolean; + -- Returns true if the node is a type conversion whose operand is an + -- arithmetic operation on signed integers, and the base type of the + -- signed integer type is smaller than Standard.Integer. In such case we + -- have special circuitry in Expand_N_Type_Conversion to promote both of + -- the operands to type Integer. + end Exp_Ch4; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index db22726bb64..7fe20b37cad 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -3983,9 +3983,21 @@ package body Exp_Ch9 is Spec_Id : Entity_Id; begin - Spec_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (T), 'B')); + -- Case of explicit task type, suffix TB + + if Comes_From_Source (T) then + Spec_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (T), "TB")); + + -- Case of anonymous task type, suffix B + + else + Spec_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (T), 'B')); + end if; + Set_Is_Internal (Spec_Id); -- Associate the procedure with the task, if this is the declaration @@ -7821,20 +7833,23 @@ package body Exp_Ch9 is declare Old_Comp : constant Node_Id := Component_Definition (Priv); - Pent : constant Entity_Id := Defining_Identifier (Priv); + Oent : constant Entity_Id := Defining_Identifier (Priv); New_Comp : Node_Id; + Nent : constant Entity_Id := + Make_Defining_Identifier (Sloc (Oent), + Chars => Chars (Oent)); begin if Present (Subtype_Indication (Old_Comp)) then New_Comp := - Make_Component_Definition (Sloc (Pent), + Make_Component_Definition (Sloc (Oent), Aliased_Present => False, Subtype_Indication => New_Copy_Tree (Subtype_Indication (Old_Comp), Discr_Map)); else New_Comp := - Make_Component_Definition (Sloc (Pent), + Make_Component_Definition (Sloc (Oent), Aliased_Present => False, Access_Definition => New_Copy_Tree (Access_Definition (Old_Comp), @@ -7843,10 +7858,12 @@ package body Exp_Ch9 is New_Priv := Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Pent), Chars (Pent)), + Defining_Identifier => Nent, Component_Definition => New_Comp, - Expression => Expression (Priv)); + Expression => Expression (Priv)); + + Set_Has_Per_Object_Constraint (Nent, + Has_Per_Object_Constraint (Oent)); Append_To (Cdecls, New_Priv); end; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 8e795e12c0f..61279d4eac5 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -173,8 +173,8 @@ package Exp_Ch9 is -- meaning is to get the Task_Id for the currently executing task. function Convert_Concurrent - (N : Node_Id; - Typ : Entity_Id) return Node_Id; + (N : Node_Id; + Typ : Entity_Id) return Node_Id; -- N is an expression of type Typ. If the type is not a concurrent type -- then it is returned unchanged. If it is a task or protected reference, -- Convert_Concurrent creates an unchecked conversion node from this diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 3c3144641d8..1d26bb3ef75 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -873,12 +873,12 @@ package Exp_Dbug is -- the element type for AT1 might have a type defined as if it had -- been written: -- - -- type at1___C_PAD is record null; end record; - -- for at1___C_PAD'Size use 16 * 8; + -- type at1___PAD is record null; end record; + -- for at1___PAD'Size use 16 * 8; -- -- and there would also be -- - -- type at1___C_PAD___XVS is record t1: Integer; end record; + -- type at1___PAD___XVS is record t1: Integer; end record; -- type t1 is ... -- -- Had the subtype Int been dynamic: @@ -888,7 +888,7 @@ package Exp_Dbug is -- Then the compiler would also generate a declaration whose effect -- would be -- - -- at1___C_PAD___XVZ: constant Integer := 32 + M * 8 + padding term; + -- at1___PAD___XVZ: constant Integer := 32 + M * 8 + padding term; -- -- Not all unconstrained types are so encoded; the XVS convention may be -- unnecessary for unconstrained types of fixed size. However, this diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 163274c4332..02887029b22 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1295,29 +1295,30 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ + ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1467,12 +1468,12 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ @@ -1691,31 +1692,32 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ + ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1723,34 +1725,35 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch6.adb \ + ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads \ + ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2006,25 +2009,26 @@ ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_pakd.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/layout.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_pakd.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/validsw.ads ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3022,12 +3026,12 @@ ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ @@ -3055,32 +3059,32 @@ ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ ada/checks.adb ada/csets.ads ada/debug.ads ada/debug_a.ads \ ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_attr.adb ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ ada/validsw.ads ada/widechar.ads @@ -3271,35 +3275,35 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \ - ada/sem_cat.adb ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch3.adb \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_smem.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/widechar.ads + ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ + ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3338,34 +3342,34 @@ ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/par_sco.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads \ - ada/sem_case.adb ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/par_sco.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3469,33 +3473,34 @@ ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_ch9.adb \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch9.ads \ + ada/sem_ch9.adb ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3699,12 +3704,12 @@ ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/debug_a.ads ada/debug_a.adb ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index cf717ac39cd..c9221fb5022 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -109,8 +109,11 @@ SOME_ADAFLAGS =-gnata FORCE_DEBUG_ADAFLAGS = -g GNATLIBFLAGS = -gnatpg -nostdinc GNATLIBCFLAGS = -g -O2 +# Pretend that _Unwind_GetIPInfo is available for the target by default. This +# should be autodetected during the configuration of libada and passed down to +# here, but we need something for --disable-libada and hope for the best. GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \ - -DIN_RTS + -DIN_RTS -DHAVE_GETIPINFO ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) MOST_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(SOME_ADAFLAGS) THREAD_KIND = native @@ -2422,6 +2425,7 @@ gnatlib-shared-default: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib @@ -2447,6 +2451,7 @@ gnatlib-shared-dual: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib-shared-default @@ -2455,6 +2460,7 @@ gnatlib-shared-dual: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib @@ -2464,6 +2470,7 @@ gnatlib-shared-dual-win32: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib-shared-win32 @@ -2472,6 +2479,7 @@ gnatlib-shared-dual-win32: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib @@ -2485,6 +2493,7 @@ gnatlib-shared-win32: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib @@ -2503,7 +2512,7 @@ gnatlib-shared-darwin: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) \ - -fno-common" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C) -fno-common" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib @@ -2531,6 +2540,7 @@ gnatlib-shared-vms: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ gnatlib @@ -2559,6 +2569,7 @@ gnatlib-shared: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ @@ -2572,6 +2583,7 @@ gnatlib-sjlj: EH_MECHANISM="" \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib @@ -2584,6 +2596,7 @@ gnatlib-zcx: EH_MECHANISM="-gcc" \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ MULTISUBDIR="$(MULTISUBDIR)" \ THREAD_KIND="$(THREAD_KIND)" \ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 94b18bde6b5..67a16ef0eb8 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -65,11 +65,11 @@ do { \ /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a record being used as a fat pointer (only true for RECORD_TYPE). */ -#define TYPE_IS_FAT_POINTER_P(NODE) \ +#define TYPE_FAT_POINTER_P(NODE) \ TYPE_LANG_FLAG_0 (RECORD_OR_UNION_CHECK (NODE)) -#define TYPE_FAT_POINTER_P(NODE) \ - (TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE)) +#define TYPE_IS_FAT_POINTER_P(NODE) \ + (TREE_CODE (NODE) == RECORD_TYPE && TYPE_FAT_POINTER_P (NODE)) /* For integral types and array types, nonzero if this is a packed array type used for bit-packed types. Such types should not be extended to a larger @@ -117,15 +117,15 @@ do { \ TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE)) /* True if NODE is a thin pointer. */ -#define TYPE_THIN_POINTER_P(NODE) \ +#define TYPE_IS_THIN_POINTER_P(NODE) \ (POINTER_TYPE_P (NODE) \ && TREE_CODE (TREE_TYPE (NODE)) == RECORD_TYPE \ && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (NODE))) /* True if TYPE is either a fat or thin pointer to an unconstrained array. */ -#define TYPE_FAT_OR_THIN_POINTER_P(NODE) \ - (TYPE_FAT_POINTER_P (NODE) || TYPE_THIN_POINTER_P (NODE)) +#define TYPE_IS_FAT_OR_THIN_POINTER_P(NODE) \ + (TYPE_IS_FAT_POINTER_P (NODE) || TYPE_IS_THIN_POINTER_P (NODE)) /* For INTEGER_TYPEs, nonzero if the type has a biased representation. */ #define TYPE_BIASED_REPRESENTATION_P(NODE) \ @@ -143,7 +143,6 @@ do { \ is a dummy type, made to correspond to a private or incomplete type. */ #define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE) -/* True if TYPE is such a dummy type. */ #define TYPE_IS_DUMMY_P(NODE) \ ((TREE_CODE (NODE) == VOID_TYPE || TREE_CODE (NODE) == RECORD_TYPE \ || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ @@ -160,7 +159,10 @@ do { \ /* For a RECORD_TYPE, nonzero if this was made just to supply needed padding or alignment. */ -#define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) +#define TYPE_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) + +#define TYPE_IS_PADDING_P(NODE) \ + (TREE_CODE (NODE) == RECORD_TYPE && TYPE_PADDING_P (NODE)) /* True if TYPE can alias any other types. */ #define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index f2f0f159abd..c4d5e26582a 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -135,7 +135,7 @@ static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool, bool *); static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool); static bool same_discriminant_p (Entity_Id, Entity_Id); -static bool array_type_has_nonaliased_component (Entity_Id, tree); +static bool array_type_has_nonaliased_component (tree, Entity_Id); static bool compile_time_known_address_p (Node_Id); static bool cannot_be_superflat_p (Node_Id); static void components_to_record (tree, Node_Id, tree, int, bool, tree *, @@ -633,7 +633,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity, - "PAD", false, definition, true); + false, false, definition, true); } /* If we are defining the object, see if it has a Size value and @@ -676,8 +676,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) despite having a nominal type with self-referential size, we can get the size directly from it. */ if (TREE_CODE (gnu_expr) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) - == RECORD_TYPE && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL @@ -838,7 +836,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type); if (gnu_size || align > 0) gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, - "PAD", false, definition, + false, false, definition, gnu_size ? true : false); /* If this is a renaming, avoid as much as possible to create a new @@ -852,8 +850,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If the renamed object had padding, strip off the reference to the inner object and reset our type. */ if ((TREE_CODE (gnu_expr) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) - == RECORD_TYPE && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) /* Strip useless conversions around the object. */ || (TREE_CODE (gnu_expr) == NOP_EXPR @@ -1017,16 +1013,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && !gnu_expr && TREE_CODE (gnu_type) == RECORD_TYPE && (TYPE_CONTAINS_TEMPLATE_P (gnu_type) - /* Beware that padding might have been introduced - via maybe_pad_type above. */ - || (TYPE_IS_PADDING_P (gnu_type) + /* Beware that padding might have been introduced above. */ + || (TYPE_PADDING_P (gnu_type) && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) { tree template_field - = TYPE_IS_PADDING_P (gnu_type) + = TYPE_PADDING_P (gnu_type) ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) : TYPE_FIELDS (gnu_type); @@ -1050,17 +1045,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (gnu_expr && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) + && !(TYPE_IS_PADDING_P (gnu_type) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) gnu_expr = convert (gnu_type, gnu_expr); /* If this is a pointer and it does not have an initializing expression, initialize it to NULL, unless the object is imported. */ if (definition - && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type)) + && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type)) && !Is_Imported (gnat_entity) && !gnu_expr) gnu_expr = integer_zero_node; @@ -1279,10 +1273,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (gnu_expr && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) + && !(TYPE_IS_PADDING_P (gnu_type) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) gnu_expr = convert (gnu_type, gnu_expr); /* If this name is external or there was a name specified, use it, @@ -1304,8 +1297,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && gnu_expr && TREE_CONSTANT (gnu_expr) && AGGREGATE_TYPE_P (gnu_type) && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) + && !(TYPE_IS_PADDING_P (gnu_type) && !host_integerp (TYPE_SIZE_UNIT (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1))) static_p = true; @@ -1687,7 +1679,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_field_type, gnu_type, 1, 0, 0, 0); finish_record_type (gnu_type, gnu_field, 0, false); - TYPE_IS_PADDING_P (gnu_type) = 1; + TYPE_PADDING_P (gnu_type) = 1; relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY); } @@ -1835,7 +1827,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Do not finalize this record type since the types of its fields are still incomplete at this point. */ finish_record_type (gnu_fat_type, tem, 0, true); - TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1; + TYPE_FAT_POINTER_P (gnu_fat_type) = 1; /* Build a reference to the template from a PLACEHOLDER_EXPR that is the fat pointer. This will be used to access the individual @@ -1971,7 +1963,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { tem = build_array_type (tem, gnu_index_types[index]); TYPE_MULTI_ARRAY_P (tem) = (index > 0); - if (array_type_has_nonaliased_component (gnat_entity, tem)) + if (array_type_has_nonaliased_component (tem, gnat_entity)) TYPE_NONALIASED_COMPONENT (tem) = 1; } @@ -2320,7 +2312,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { gnu_type = build_array_type (gnu_type, gnu_index_types[index]); TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); - if (array_type_has_nonaliased_component (gnat_entity, gnu_type)) + if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) TYPE_NONALIASED_COMPONENT (gnu_type) = 1; } @@ -2477,7 +2469,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_inner = gnu_type; while (TREE_CODE (gnu_inner) == RECORD_TYPE && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner) - || TYPE_IS_PADDING_P (gnu_inner))) + || TYPE_PADDING_P (gnu_inner))) gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner)); /* We need to attach the index type to the type we just made so @@ -2571,7 +2563,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), gnu_index_type); - if (array_type_has_nonaliased_component (gnat_entity, gnu_type)) + if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) TYPE_NONALIASED_COMPONENT (gnu_type) = 1; relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY); } @@ -2737,15 +2729,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) Present (gnat_field); gnat_field = Next_Stored_Discriminant (gnat_field)) if (Present (Corresponding_Discriminant (gnat_field))) - save_gnu_tree - (gnat_field, - build3 (COMPONENT_REF, - get_unpadded_type (Etype (gnat_field)), - gnu_get_parent, - gnat_to_gnu_field_decl (Corresponding_Discriminant - (gnat_field)), - NULL_TREE), - true); + { + tree gnu_field + = gnat_to_gnu_field_decl (Corresponding_Discriminant + (gnat_field)); + save_gnu_tree + (gnat_field, + build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + gnu_get_parent, gnu_field, NULL_TREE), + true); + } /* Then we build the parent subtype. If it has discriminants but the type itself has unknown discriminants, this means that it @@ -2986,8 +2979,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) copy_and_substitute_in_size (gnu_type, gnu_base_type, gnu_subst_list); - if (TREE_CODE (gnu_base_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_base_type)) + if (TYPE_IS_PADDING_P (gnu_base_type)) gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type)); else gnu_unpad_base_type = gnu_base_type; @@ -3097,7 +3089,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { gnu_size = DECL_SIZE (gnu_old_field); if (TREE_CODE (gnu_field_type) == RECORD_TYPE - && !TYPE_IS_FAT_POINTER_P (gnu_field_type) + && !TYPE_FAT_POINTER_P (gnu_field_type) && host_integerp (TYPE_SIZE (gnu_field_type), 1)) gnu_field_type = make_packable_type (gnu_field_type, true); @@ -3465,7 +3457,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Make sure we can place this into a register. */ TYPE_ALIGN (gnu_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); - TYPE_IS_FAT_POINTER_P (gnu_type) = 1; + TYPE_FAT_POINTER_P (gnu_type) = 1; /* Do not finalize this record type since the types of its fields are incomplete. */ @@ -3599,11 +3591,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if ((! in_main_unit || is_from_limited_with) && made_dummy) { tree gnu_old_type - = TYPE_FAT_POINTER_P (gnu_type) + = TYPE_IS_FAT_POINTER_P (gnu_type) ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); if (esize == POINTER_SIZE - && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type))) + && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type))) gnu_type = build_pointer_type (TYPE_OBJECT_RECORD_TYPE @@ -3915,8 +3907,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If the type is a padded type and the underlying type would not be passed by reference or this function has a foreign convention, return the underlying type. */ - else if (TREE_CODE (gnu_return_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_return_type) + else if (TYPE_IS_PADDING_P (gnu_return_type) && (!default_pass_by_ref (TREE_TYPE (TYPE_FIELDS (gnu_return_type))) || Has_Foreign_Convention (gnat_entity))) @@ -4054,7 +4045,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) between two calls, so they can't be CSE'ed. The latter case also handles by-ref parameters. */ if (POINTER_TYPE_P (gnu_param_type) - || TYPE_FAT_POINTER_P (gnu_param_type)) + || TYPE_IS_FAT_POINTER_P (gnu_param_type)) const_flag = false; } @@ -4417,7 +4408,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else if ((TREE_CODE (gnu_type) == RECORD_TYPE || TREE_CODE (gnu_type) == UNION_TYPE || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (gnu_type)) + && !TYPE_FAT_POINTER_P (gnu_type)) size = rm_size (gnu_type); else size = TYPE_SIZE (gnu_type); @@ -4446,10 +4437,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) us when we make the new TYPE_DECL below. */ if (gnu_size || align > 0) gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, - "PAD", true, definition, false); + false, !gnu_decl, definition, false); - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type)) + if (TYPE_IS_PADDING_P (gnu_type)) { gnu_entity_name = TYPE_NAME (gnu_type); if (TREE_CODE (gnu_entity_name) == TYPE_DECL) @@ -4566,7 +4556,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) !Comes_From_Source (gnat_entity), debug_info_p, gnat_entity); else - TREE_TYPE (gnu_decl) = gnu_type; + { + TREE_TYPE (gnu_decl) = gnu_type; + TYPE_STUB_DECL (gnu_type) = gnu_decl; + } } if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) @@ -4609,11 +4602,38 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) superset superset R ----------> D ----------> T + However, for composite types, conversions between derived types are + translated into VIEW_CONVERT_EXPRs so a sequence like: + + type Comp1 is new Comp; + type Comp2 is new Comp; + procedure Proc (C : Comp1); + + C : Comp2; + Proc (Comp1 (C)); + + is translated into: + + C : Comp2; + Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C)); + + and gimplified into: + + C : Comp2; + Comp1 *C.0; + C.0 = (Comp1 *) &C; + Proc (C.0); + + i.e. generates code involving type punning. Therefore, Comp1 needs + to conflict with Comp2 and an alias set copy is required. + The language rules ensure the parent type is already frozen here. */ if (Is_Derived_Type (gnat_entity)) { tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity)); - relate_alias_sets (gnu_type, gnu_parent_type, ALIAS_SET_SUPERSET); + relate_alias_sets (gnu_type, gnu_parent_type, + Is_Composite_Type (gnat_entity) + ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET); } /* Back-annotate the Alignment of the type if not already in the @@ -4705,8 +4725,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) tree gnu_low_bound, gnu_high_bound; /* If this is a padded type, we need to use the underlying type. */ - if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_scalar_type)) + if (TYPE_IS_PADDING_P (gnu_scalar_type)) gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); /* If this is a floating point type and we haven't set a floating @@ -4852,7 +4871,7 @@ get_unpadded_type (Entity_Id gnat_entity) { tree type = gnat_to_gnu_type (gnat_entity); - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + if (TYPE_IS_PADDING_P (type)) type = TREE_TYPE (TYPE_FIELDS (type)); return type; @@ -4985,7 +5004,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, && !Has_Aliased_Components (gnat_array) && !Strict_Alignment (Component_Type (gnat_array)) && TREE_CODE (gnu_type) == RECORD_TYPE - && !TYPE_IS_FAT_POINTER_P (gnu_type) + && !TYPE_FAT_POINTER_P (gnu_type) && host_integerp (TYPE_SIZE (gnu_type), 1)) gnu_type = make_packable_type (gnu_type, false); @@ -5037,7 +5056,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, orig_type = gnu_type; gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array, - "C_PAD", false, definition, true); + true, false, definition, true); /* If a padding record was made, declare it now since it will never be declared otherwise. This is necessary to ensure that its subtrees @@ -5089,8 +5108,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, /* If this is either a foreign function or if the underlying type won't be passed by reference, strip off possible padding type. */ - if (TREE_CODE (gnu_param_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_param_type)) + if (TYPE_IS_PADDING_P (gnu_param_type)) { tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); @@ -5162,7 +5180,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, } /* Fat pointers are passed as thin pointers for foreign conventions. */ - else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type)) + else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type)) gnu_param_type = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0); @@ -5263,21 +5281,38 @@ same_discriminant_p (Entity_Id discr1, Entity_Id discr2) Original_Record_Component (discr1) == Original_Record_Component (discr2); } -/* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has - a non-aliased component in the back-end sense. */ +/* Return true if the array type GNU_TYPE, which represents a dimension of + GNAT_TYPE, has a non-aliased component in the back-end sense. */ static bool -array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type) +array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type) { - /* If the type below this is a multi-array type, then - this does not have aliased components. */ + /* If the array type is not the innermost dimension of the GNAT type, + then it has a non-aliased component. */ if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) return true; + /* If the array type has an aliased component in the front-end sense, + then it also has an aliased component in the back-end sense. */ if (Has_Aliased_Components (gnat_type)) return false; + /* If this is a derived type, then it has a non-aliased component if + and only if its parent type also has one. */ + if (Is_Derived_Type (gnat_type)) + { + tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type)); + int index; + if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_parent_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type)))); + for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--) + gnu_parent_type = TREE_TYPE (gnu_parent_type); + return TYPE_NONALIASED_COMPONENT (gnu_parent_type); + } + + /* Otherwise, rely exclusively on properties of the element type. */ return type_for_nonaliased_component_p (TREE_TYPE (gnu_type)); } @@ -5463,7 +5498,7 @@ relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op) see the inner types. */ while (TREE_CODE (gnu_old_type) == RECORD_TYPE && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type) - || TYPE_IS_PADDING_P (gnu_old_type))) + || TYPE_PADDING_P (gnu_old_type))) gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type)); /* Unconstrained array types are deemed incomplete and would thus be given @@ -5929,7 +5964,7 @@ make_packable_type (tree type, bool in_record) TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type); TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); if (TREE_CODE (type) == RECORD_TYPE) - TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type); + TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type); /* If we are in a record and have a small size, set the alignment to try for an integral mode. Otherwise set it to try for a smaller @@ -5972,7 +6007,7 @@ make_packable_type (tree type, bool in_record) if ((TREE_CODE (new_field_type) == RECORD_TYPE || TREE_CODE (new_field_type) == UNION_TYPE || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (new_field_type) + && !TYPE_FAT_POINTER_P (new_field_type) && host_integerp (TYPE_SIZE (new_field_type), 1)) new_field_type = make_packable_type (new_field_type, true); @@ -5984,7 +6019,7 @@ make_packable_type (tree type, bool in_record) && (TREE_CODE (new_field_type) == RECORD_TYPE || TREE_CODE (new_field_type) == UNION_TYPE || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (new_field_type) + && !TYPE_FAT_POINTER_P (new_field_type) && !TYPE_CONTAINS_TEMPLATE_P (new_field_type) && TYPE_ADA_SIZE (new_field_type)) new_size = TYPE_ADA_SIZE (new_field_type); @@ -6013,8 +6048,7 @@ make_packable_type (tree type, bool in_record) /* If this is a padding record, we never want to make the size smaller than what was specified. For QUAL_UNION_TYPE, also copy the size. */ - if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - || TREE_CODE (type) == QUAL_UNION_TYPE) + if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE) { TYPE_SIZE (new_type) = TYPE_SIZE (type); TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); @@ -6046,25 +6080,20 @@ make_packable_type (tree type, bool in_record) /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type if needed. We have already verified that SIZE and TYPE are large enough. - - GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and - to issue a warning. - - IS_USER_TYPE is true if we must complete the original type. - - DEFINITION is true if this type is being defined. - - SAME_RM_SIZE is true if the RM size of the resulting type is to be set - to SIZE too; otherwise, it's set to the RM size of the original type. */ + GNAT_ENTITY is used to name the resulting record and to issue a warning. + IS_COMPONENT_TYPE is true if this is being done for the component type + of an array. IS_USER_TYPE is true if we must complete the original type. + DEFINITION is true if this type is being defined. SAME_RM_SIZE is true + if the RM size of the resulting type is to be set to SIZE too; otherwise, + it's set to the RM size of the original type. */ tree maybe_pad_type (tree type, tree size, unsigned int align, - Entity_Id gnat_entity, const char *name_trailer, + Entity_Id gnat_entity, bool is_component_type, bool is_user_type, bool definition, bool same_rm_size) { tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type); tree orig_size = TYPE_SIZE (type); - unsigned int orig_align = align; tree record, field; /* If TYPE is a padded type, see if it agrees with any size and alignment @@ -6072,7 +6101,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, off the padding, since we will either be returning the inner type or repadding it. If no size or alignment is specified, use that of the original padded type. */ - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + if (TYPE_IS_PADDING_P (type)) { if ((!size || operand_equal_p (round_up (size, @@ -6121,18 +6150,15 @@ maybe_pad_type (tree type, tree size, unsigned int align, generate incorrect debugging information. So make a new record type and name. */ record = make_node (RECORD_TYPE); - TYPE_IS_PADDING_P (record) = 1; + TYPE_PADDING_P (record) = 1; if (Present (gnat_entity)) - TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer); + TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD"); TYPE_VOLATILE (record) = Present (gnat_entity) && Treat_As_Volatile (gnat_entity); TYPE_ALIGN (record) = align; - if (orig_align) - TYPE_USER_ALIGN (record) = align; - TYPE_SIZE (record) = size ? size : orig_size; TYPE_SIZE_UNIT (record) = convert (sizetype, @@ -6256,7 +6282,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node, gnat_entity, size_diffop (size, orig_size)); - else if (name_trailer[0] == 'C') + else if (is_component_type) post_error_ne_tree ("component of& padded{ by ^ bits}?", gnat_entity, gnat_entity, size_diffop (size, orig_size)); @@ -6447,7 +6473,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, from a component clause. */ if (TREE_CODE (gnu_field_type) == RECORD_TYPE - && !TYPE_IS_FAT_POINTER_P (gnu_field_type) + && !TYPE_FAT_POINTER_P (gnu_field_type) && host_integerp (TYPE_SIZE (gnu_field_type), 1) && (packed == 1 || (gnu_size @@ -6634,7 +6660,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, orig_field_type = gnu_field_type; gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field, - "PAD", false, definition, true); + false, false, definition, true); /* If a padding record was made, declare it now since it will never be declared otherwise. This is necessary to ensure that its subtrees @@ -6677,8 +6703,7 @@ is_variable_size (tree type) if (!TREE_CONSTANT (TYPE_SIZE (type))) return true; - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_IS_PADDING_P (type) + if (TYPE_IS_PADDING_P (type) && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) return true; @@ -7227,7 +7252,7 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) { if (by_ref) { - if (TYPE_FAT_POINTER_P (gnu_type)) + if (TYPE_IS_FAT_POINTER_P (gnu_type)) gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type); else gnu_type = TREE_TYPE (gnu_type); @@ -7250,6 +7275,23 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); } +/* Return first element of field list whose TREE_PURPOSE is ELEM or whose + DECL_ORIGINAL_FIELD of TREE_PURPOSE is ELEM. Return NULL_TREE if there + is no such element in the list. */ + +static tree +purpose_member_field (const_tree elem, tree list) +{ + while (list) + { + tree field = TREE_PURPOSE (list); + if (elem == field || elem == DECL_ORIGINAL_FIELD (field)) + return list; + list = TREE_CHAIN (list); + } + return NULL_TREE; +} + /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type, set Component_Bit_Offset and Esize of the components to the position and size used by Gigi. */ @@ -7273,11 +7315,12 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type) || (Ekind (gnat_field) == E_Discriminant && !Is_Unchecked_Union (Scope (gnat_field)))) { - tree parent_offset, t; - - t = purpose_member (gnat_to_gnu_field_decl (gnat_field), gnu_list); + tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field), + gnu_list); if (t) { + tree parent_offset; + if (type_annotate_only && Is_Tagged_Type (gnat_entity)) { /* In this mode the tag and parent components are not @@ -7394,12 +7437,16 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition) gnat_value = Next_Elmt (gnat_value)) /* Ignore access discriminants. */ if (!Is_Access_Type (Etype (Node (gnat_value)))) - gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim), - elaborate_expression - (Node (gnat_value), gnat_subtype, - get_entity_name (gnat_discrim), definition, - true, false), - gnu_list); + { + tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim); + gnu_list = tree_cons (gnu_field, + convert (TREE_TYPE (gnu_field), + elaborate_expression + (Node (gnat_value), gnat_subtype, + get_entity_name (gnat_discrim), + definition, true, false)), + gnu_list); + } return gnu_list; } @@ -7542,7 +7589,7 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, /* If this is an access type or a fat pointer, the minimum size is that given by the smallest integral mode that's valid for pointers. */ - if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type)) + if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type)) { enum machine_mode p_mode; @@ -7636,8 +7683,7 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) || (AGGREGATE_TYPE_P (gnu_type) && !(TREE_CODE (gnu_type) == ARRAY_TYPE && TYPE_PACKED_ARRAY_TYPE_P (gnu_type)) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) + && !(TYPE_IS_PADDING_P (gnu_type) && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE && TYPE_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type)))) && tree_int_cst_lt (size, old_size))) @@ -7660,7 +7706,7 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) else if ((TREE_CODE (gnu_type) == RECORD_TYPE || TREE_CODE (gnu_type) == UNION_TYPE || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (gnu_type)) + && !TYPE_FAT_POINTER_P (gnu_type)) SET_TYPE_ADA_SIZE (gnu_type, size); } @@ -7691,6 +7737,10 @@ make_type_from_size (tree type, tree size_tree, bool for_biased) biased_p = (TREE_CODE (type) == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type)); + /* Integer types with precision 0 are forbidden. */ + if (size == 0) + size = 1; + /* Only do something if the type is not a packed array type and doesn't already have the proper size. */ if (TYPE_PACKED_ARRAY_TYPE_P (type) @@ -7727,7 +7777,7 @@ make_type_from_size (tree type, tree size_tree, bool for_biased) case RECORD_TYPE: /* Do something if this is a fat pointer, in which case we may need to return the thin pointer. */ - if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) + if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) { enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0); if (!targetm.valid_pointer_mode (p_mode)) @@ -7742,7 +7792,7 @@ make_type_from_size (tree type, tree size_tree, bool for_biased) case POINTER_TYPE: /* Only do something if this is a thin pointer, in which case we may need to return the fat pointer. */ - if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) + if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) return build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); break; @@ -8393,7 +8443,7 @@ rm_size (tree gnu_type) if ((TREE_CODE (gnu_type) == RECORD_TYPE || TREE_CODE (gnu_type) == UNION_TYPE || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (gnu_type) + && !TYPE_FAT_POINTER_P (gnu_type) && TYPE_ADA_SIZE (gnu_type)) return TYPE_ADA_SIZE (gnu_type); diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index ea1a65d485b..82d193bfc5c 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -124,21 +124,16 @@ extern tree make_aligning_type (tree type, unsigned int align, tree size, /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type if needed. We have already verified that SIZE and TYPE are large enough. - - GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and - to issue a warning. - - IS_USER_TYPE is true if we must be sure we complete the original type. - - DEFINITION is true if this type is being defined. - - SAME_RM_SIZE is true if the RM_Size of the resulting type is to be - set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original - type. */ + GNAT_ENTITY is used to name the resulting record and to issue a warning. + IS_COMPONENT_TYPE is true if this is being done for the component type + of an array. IS_USER_TYPE is true if we must complete the original type. + DEFINITION is true if this type is being defined. SAME_RM_SIZE is true + if the RM size of the resulting type is to be set to SIZE too; otherwise, + it's set to the RM size of the original type. */ extern tree maybe_pad_type (tree type, tree size, unsigned int align, - Entity_Id gnat_entity, const char *name_trailer, + Entity_Id gnat_entity, bool is_component_type, bool is_user_type, bool definition, - bool same_rm_size); + bool same_rm_size); /* Given a GNU tree and a GNAT list of choices, generate an expression to test the value passed against the list of choices. */ @@ -648,12 +643,13 @@ extern void record_global_renaming_pointer (tree decl); /* Invalidate the global renaming pointers. */ extern void invalidate_global_renaming_pointers (void); -/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its - type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if - this field is in a record type with a "pragma pack". If SIZE is nonzero - it is the specified size for this field. If POS is nonzero, it is the bit - position. If ADDRESSABLE is nonzero, it means we are allowed to take - the address of this field for aliasing purposes. */ +/* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is + its type and RECORD_TYPE is the type of the enclosing record. PACKED is + 1 if the enclosing record is packed, -1 if it has Component_Alignment of + Storage_Unit. If SIZE is nonzero, it is the specified size of the field. + If POS is nonzero, it is the bit position. If ADDRESSABLE is nonzero, it + means we are allowed to take the address of the field; if it is negative, + we should not make a bitfield, which is used by make_aligning_type. */ extern tree create_field_decl (tree field_name, tree field_type, tree record_type, int packed, tree size, tree pos, int addressable); diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 67823789ab3..570bd111a95 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -527,7 +527,7 @@ gnat_print_type (FILE *file, tree node, int indent) break; case RECORD_TYPE: - if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node)) + if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node)) print_node (file, "unconstrained array", TYPE_UNCONSTRAINED_ARRAY (node), indent + 4); else @@ -600,8 +600,7 @@ static alias_set_type gnat_get_alias_set (tree type) { /* If this is a padding type, use the type of the first field. */ - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_IS_PADDING_P (type)) + if (TYPE_IS_PADDING_P (type)) return get_alias_set (TREE_TYPE (TYPE_FIELDS (type))); /* If the type is an unconstrained array, use the type of the diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index d94d1f45bfc..41be8bb77af 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -657,17 +657,16 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, error_gnat_node = Empty; } -/* Return a positive value if an lvalue is required for GNAT_NODE. - GNU_TYPE is the type that will be used for GNAT_NODE in the - translated GNU tree. CONSTANT indicates whether the underlying - object represented by GNAT_NODE is constant in the Ada sense, - ALIASED whether it is aliased (but the latter doesn't affect - the outcome if CONSTANT is not true). - - The function climbs up the GNAT tree starting from the node and - returns 1 upon encountering a node that effectively requires an - lvalue downstream. It returns int instead of bool to facilitate - usage in non purely binary logic contexts. */ +/* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE + is the type that will be used for GNAT_NODE in the translated GNU tree. + CONSTANT indicates whether the underlying object represented by GNAT_NODE + is constant in the Ada sense, ALIASED whether it is aliased (but the latter + doesn't affect the outcome if CONSTANT is not true). + + The function climbs up the GNAT tree starting from the node and returns 1 + upon encountering a node that effectively requires an lvalue downstream. + It returns int instead of bool to facilitate usage in non-purely binary + logic contexts. */ static int lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, @@ -754,6 +753,13 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, || (Is_Composite_Type (Underlying_Type (Etype (gnat_node))) && Is_Atomic (Entity (Name (gnat_parent))))); + case N_Unchecked_Type_Conversion: + /* Returning 0 is very likely correct but we get better code if we + go through the conversion. */ + return lvalue_required_p (gnat_parent, + get_unpadded_type (Etype (gnat_parent)), + constant, aliased); + default: return 0; } @@ -946,8 +952,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) { gnu_result_type = TREE_TYPE (gnu_result); - if (TREE_CODE (gnu_result_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_result_type)) + if (TYPE_IS_PADDING_P (gnu_result_type)) gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); } @@ -1256,7 +1261,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) /* If this is an unconstrained array, we know the object has been allocated with the template in front of the object. So compute the template address. */ - if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) gnu_ptr = convert (build_pointer_type (TYPE_OBJECT_RECORD_TYPE @@ -1318,29 +1323,28 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) } /* If we're looking for the size of a field, return the field size. - Otherwise, if the prefix is an object, or if 'Object_Size or - 'Max_Size_In_Storage_Elements has been specified, the result is the - GCC size of the type. Otherwise, the result is the RM size of the - type. */ + Otherwise, if the prefix is an object, or if we're looking for + 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the + GCC size of the type. Otherwise, it is the RM size of the type. */ if (TREE_CODE (gnu_prefix) == COMPONENT_REF) gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); else if (TREE_CODE (gnu_prefix) != TYPE_DECL || attribute == Attr_Object_Size || attribute == Attr_Max_Size_In_Storage_Elements) { - /* If this is a padded type, the GCC size isn't relevant to the - programmer. Normally, what we want is the RM size, which was set - from the specified size, but if it was not set, we want the size - of the relevant field. Using the MAX of those two produces the - right result in all case. Don't use the size of the field if it's - a self-referential type, since that's never what's wanted. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE + /* If the prefix is an object of a padded type, the GCC size isn't + relevant to the programmer. Normally what we want is the RM size, + which was set from the specified size, but if it was not set, we + want the size of the field. Using the MAX of those two produces + the right result in all cases. Don't use the size of the field + if it's self-referential, since that's never what's wanted. */ + if (TREE_CODE (gnu_prefix) != TYPE_DECL && TYPE_IS_PADDING_P (gnu_type) && TREE_CODE (gnu_expr) == COMPONENT_REF) { gnu_result = rm_size (gnu_type); - if (!(CONTAINS_PLACEHOLDER_P - (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) + if (!CONTAINS_PLACEHOLDER_P + (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))) gnu_result = size_binop (MAX_EXPR, gnu_result, DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); @@ -1353,7 +1357,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref))); - if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type) + if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type) && Present (gnat_actual_subtype)) { tree gnu_actual_obj_type @@ -1403,9 +1407,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) unsigned int align; if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) gnu_prefix = TREE_OPERAND (gnu_prefix, 0); gnu_type = TREE_TYPE (gnu_prefix); @@ -1742,9 +1744,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) case Attr_Component_Size: if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) gnu_prefix = TREE_OPERAND (gnu_prefix, 0); gnu_prefix = maybe_implicit_deref (gnu_prefix); @@ -2423,22 +2423,27 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) } } - /* If we are calling by supplying a pointer to a target, set up that - pointer as the first argument. Use GNU_TARGET if one was passed; - otherwise, make a target by building a variable of the maximum size - of the type. */ + /* If we are calling by supplying a pointer to a target, set up that pointer + as the first argument. Use GNU_TARGET if one was passed; otherwise, make + a target by building a variable and use the maximum size of the type if + it has self-referential size. */ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) { - tree gnu_real_ret_type + tree gnu_ret_type = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); if (!gnu_target) { - tree gnu_obj_type - = maybe_pad_type (gnu_real_ret_type, - max_size (TYPE_SIZE (gnu_real_ret_type), true), - 0, Etype (Name (gnat_node)), "PAD", false, - false, false); + tree gnu_obj_type; + + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_ret_type))) + gnu_obj_type + = maybe_pad_type (gnu_ret_type, + max_size (TYPE_SIZE (gnu_ret_type), true), + 0, Etype (Name (gnat_node)), false, false, + false, true); + else + gnu_obj_type = gnu_ret_type; /* ??? We may be about to create a static temporary if we happen to be at the global binding level. That's a regression from what @@ -2454,7 +2459,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_actual_list = tree_cons (NULL_TREE, build_unary_op (ADDR_EXPR, NULL_TREE, - unchecked_convert (gnu_real_ret_type, + unchecked_convert (gnu_ret_type, gnu_target, false)), NULL_TREE); @@ -2557,10 +2562,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) /* Otherwise remove unpadding from the object and reset the copy. */ else if (TREE_CODE (gnu_name) == COMPONENT_REF - && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))) gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); /* Otherwise convert to the nominal type of the object if it's @@ -2599,7 +2602,6 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) /* If this was a procedure call, we may not have removed any padding. So do it here for the part we will use as an input, if any. */ if (Ekind (gnat_formal) != E_Out_Parameter - && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual); @@ -2669,8 +2671,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_actual = gnu_name; /* If we have a padded type, be sure we've removed padding. */ - if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) && TREE_CODE (gnu_actual) != SAVE_EXPR) gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual); @@ -2703,8 +2704,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_actual = maybe_implicit_deref (gnu_actual); gnu_actual = maybe_unconstrained_array (gnu_actual); - if (TREE_CODE (gnu_formal_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_formal_type)) + if (TYPE_IS_PADDING_P (gnu_formal_type)) { gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); gnu_actual = convert (gnu_formal_type, gnu_actual); @@ -2896,8 +2896,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); /* If the result is a padded type, remove the padding. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), gnu_result); @@ -3856,8 +3855,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_array_object = maybe_unconstrained_array (gnu_array_object); /* If we got a padded type, remove it too. */ - if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object))) + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object))) gnu_array_object = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))), gnu_array_object); @@ -4713,12 +4711,10 @@ gnat_to_gnu (Node_Id gnat_node) type is self-referential since we want to allocate the fixed size in that case. */ if (TREE_CODE (gnu_ret_val) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))) + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))) gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type) @@ -5151,7 +5147,7 @@ gnat_to_gnu (Node_Id gnat_node) a fat pointer, then go back below to a thin pointer. The reason for this is that we need a fat pointer someplace in order to properly compute the size. */ - if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) + if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE, build_unary_op (INDIRECT_REF, NULL_TREE, gnu_ptr)); @@ -5160,7 +5156,7 @@ gnat_to_gnu (Node_Id gnat_node) have been allocated with the template in front of the object. So pass the template address, but get the total size. Do this by converting to a thin pointer. */ - if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) gnu_ptr = convert (build_pointer_type (TYPE_OBJECT_RECORD_TYPE @@ -5174,7 +5170,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_actual_obj_type = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node)); - if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) gnu_actual_obj_type = build_unc_object_type_from_ptr (gnu_ptr_type, gnu_actual_obj_type, @@ -5286,10 +5282,10 @@ gnat_to_gnu (Node_Id gnat_node) /* But if the result is a fat pointer type, we have no mechanism to do that, so we unconditionally warn in problematic cases. */ - else if (TYPE_FAT_POINTER_P (gnu_target_type)) + else if (TYPE_IS_FAT_POINTER_P (gnu_target_type)) { tree gnu_source_array_type - = TYPE_FAT_POINTER_P (gnu_source_type) + = TYPE_IS_FAT_POINTER_P (gnu_source_type) ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))) : NULL_TREE; tree gnu_target_array_type @@ -5297,7 +5293,7 @@ gnat_to_gnu (Node_Id gnat_node) if ((TYPE_DUMMY_P (gnu_target_array_type) || get_alias_set (gnu_target_array_type) != 0) - && (!TYPE_FAT_POINTER_P (gnu_source_type) + && (!TYPE_IS_FAT_POINTER_P (gnu_source_type) || (TYPE_DUMMY_P (gnu_source_array_type) != TYPE_DUMMY_P (gnu_target_array_type)) || (TYPE_DUMMY_P (gnu_source_array_type) @@ -5438,8 +5434,7 @@ gnat_to_gnu (Node_Id gnat_node) size: in that case it must be an object of unconstrained type with a default discriminant and we want to avoid copying too much data. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result)))))) gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), @@ -5459,8 +5454,7 @@ gnat_to_gnu (Node_Id gnat_node) && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE)) { /* Remove any padding. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), gnu_result); } @@ -5602,7 +5596,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) { /* If GNU_DECL has a padded type, convert it to the unpadded type so the assignment is done properly. */ - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + if (TYPE_IS_PADDING_P (type)) t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); else t = gnu_decl; @@ -6786,8 +6780,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype; /* FIXME: Should not have padding in the first place. */ - if (TREE_CODE (calc_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (calc_type)) + if (TYPE_IS_PADDING_P (calc_type)) calc_type = TREE_TYPE (TYPE_FIELDS (calc_type)); /* Compute the exact value calc_type'Pred (0.5) at compile time. */ @@ -6962,6 +6955,10 @@ addressable_p (tree gnu_expr, tree gnu_type) case CALL_EXPR: case PLUS_EXPR: case MINUS_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_NOT_EXPR: /* All rvalues are deemed addressable since taking their address will force a temporary to be created by the middle-end. */ return true; @@ -6984,7 +6981,7 @@ addressable_p (tree gnu_expr, tree gnu_type) || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))) /* The field of a padding record is always addressable. */ - || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) + || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); case ARRAY_REF: case ARRAY_RANGE_REF: @@ -7264,13 +7261,12 @@ static tree maybe_implicit_deref (tree exp) { /* If the type is a pointer, dereference it. */ - - if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp))) + if (POINTER_TYPE_P (TREE_TYPE (exp)) + || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp))) exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp); /* If we got a padded type, remove it too. */ - if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (exp))) + if (TYPE_IS_PADDING_P (TREE_TYPE (exp))) exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); return exp; @@ -7308,7 +7304,7 @@ protect_multiple_eval (tree exp) /* If this is a fat pointer or something that can be placed into a register, just make a SAVE_EXPR. */ - if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode) + if (TYPE_IS_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode) return save_expr (exp); /* Otherwise, reference, protect the address and dereference. */ @@ -7493,7 +7489,7 @@ gnat_stabilize_reference_1 (tree e, bool force) fat pointer. This may be more efficient, but will also allow us to more easily find the match for the PLACEHOLDER_EXPR. */ if (code == COMPONENT_REF - && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) result = build3 (COMPONENT_REF, type, gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 7acb2ce2de4..c79dd4e7a65 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -59,10 +59,6 @@ #include "ada-tree.h" #include "gigi.h" -#ifndef MAX_FIXED_MODE_SIZE -#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode) -#endif - #ifndef MAX_BITS_PER_WORD #define MAX_BITS_PER_WORD BITS_PER_WORD #endif @@ -490,7 +486,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) ; - else if (TYPE_FAT_POINTER_P (t)) + else if (TYPE_IS_FAT_POINTER_P (t)) { tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; @@ -643,7 +639,7 @@ finish_record_type (tree record_type, tree fieldlist, int rep_level, if ((TREE_CODE (type) == RECORD_TYPE || TREE_CODE (type) == UNION_TYPE || TREE_CODE (type) == QUAL_UNION_TYPE) - && !TYPE_IS_FAT_POINTER_P (type) + && !TYPE_FAT_POINTER_P (type) && !TYPE_CONTAINS_TEMPLATE_P (type) && TYPE_ADA_SIZE (type)) this_ada_size = TYPE_ADA_SIZE (type); @@ -739,21 +735,15 @@ finish_record_type (tree record_type, tree fieldlist, int rep_level, if (code == QUAL_UNION_TYPE) nreverse (fieldlist); - /* If the type is discriminated, it can be used to access all its - constrained subtypes, so force structural equality checks. */ - if (CONTAINS_PLACEHOLDER_P (size)) - SET_TYPE_STRUCTURAL_EQUALITY (record_type); - if (rep_level < 2) { /* If this is a padding record, we never want to make the size smaller than what was specified in it, if any. */ - if (TREE_CODE (record_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) + if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) size = TYPE_SIZE (record_type); /* Now set any of the values we've just computed that apply. */ - if (!TYPE_IS_FAT_POINTER_P (record_type) + if (!TYPE_FAT_POINTER_P (record_type) && !TYPE_CONTAINS_TEMPLATE_P (record_type)) SET_TYPE_ADA_SIZE (record_type, ada_size); @@ -815,9 +805,7 @@ rest_of_record_type_compilation (tree record_type) that tells the debugger how the record is laid out. See exp_dbug.ads. But don't do this for records that are padding since they confuse GDB. */ - if (var_size - && !(TREE_CODE (record_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (record_type))) + if (var_size && !TYPE_IS_PADDING_P (record_type)) { tree new_record_type = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE @@ -1306,7 +1294,7 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list, if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p) DECL_IGNORED_P (type_decl) = 1; else if (code != ENUMERAL_TYPE - && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type)) + && (code != RECORD_TYPE || TYPE_FAT_POINTER_P (type)) && !((code == POINTER_TYPE || code == REFERENCE_TYPE) && TYPE_IS_DUMMY_P (TREE_TYPE (type))) && !(code == RECORD_TYPE @@ -1465,13 +1453,13 @@ aggregate_type_contains_array_p (tree type) } } -/* Return a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its - type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if - this field is in a record type with a "pragma pack". If SIZE is nonzero - it is the specified size for this field. If POS is nonzero, it is the bit - position. If ADDRESSABLE is nonzero, it means we are allowed to take - the address of this field for aliasing purposes. If it is negative, we - should not make a bitfield, which is used by make_aligning_type. */ +/* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is + its type and RECORD_TYPE is the type of the enclosing record. PACKED is + 1 if the enclosing record is packed, -1 if it has Component_Alignment of + Storage_Unit. If SIZE is nonzero, it is the specified size of the field. + If POS is nonzero, it is the bit position. If ADDRESSABLE is nonzero, it + means we are allowed to take the address of the field; if it is negative, + we should not make a bitfield, which is used by make_aligning_type. */ tree create_field_decl (tree field_name, tree field_type, tree record_type, @@ -1505,12 +1493,8 @@ create_field_decl (tree field_name, tree field_type, tree record_type, else if (packed == 1) { size = rm_size (field_type); - - /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to - byte. */ - if (TREE_CODE (size) == INTEGER_CST - && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0) - size = round_up (size, BITS_PER_UNIT); + if (TYPE_MODE (field_type) == BLKmode) + size = round_up (size, BITS_PER_UNIT); } /* If we may, according to ADDRESSABLE, make a bitfield if a size is @@ -1874,9 +1858,9 @@ create_subprog_decl (tree subprog_name, tree asm_name, to be declared as the "main" function literally by default. Ada program entry points are typically declared with a different name within the binder generated file, exported as 'main' to satisfy the - system expectations. Redirect main_identifier_node in this case. */ + system expectations. Force main_identifier_node in this case. */ if (asm_name == main_identifier_node) - main_identifier_node = DECL_NAME (subprog_decl); + DECL_NAME (subprog_decl) = main_identifier_node; } process_attributes (subprog_decl, attr_list); @@ -2193,16 +2177,28 @@ gnat_type_for_mode (enum machine_mode mode, int unsignedp) { if (mode == BLKmode) return NULL_TREE; - else if (mode == VOIDmode) + + if (mode == VOIDmode) return void_type_node; - else if (COMPLEX_MODE_P (mode)) + + if (COMPLEX_MODE_P (mode)) return NULL_TREE; - else if (SCALAR_FLOAT_MODE_P (mode)) + + if (SCALAR_FLOAT_MODE_P (mode)) return float_type_for_precision (GET_MODE_PRECISION (mode), mode); - else if (SCALAR_INT_MODE_P (mode)) + + if (SCALAR_INT_MODE_P (mode)) return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp); - else - return NULL_TREE; + + if (VECTOR_MODE_P (mode)) + { + enum machine_mode inner_mode = GET_MODE_INNER (mode); + tree inner_type = gnat_type_for_mode (inner_mode, unsignedp); + if (inner_type) + return build_vector_type_for_mode (inner_type, mode); + } + + return NULL_TREE; } /* Return the unsigned version of a TYPE_NODE, a scalar type. */ @@ -2291,7 +2287,7 @@ gnat_types_compatible_p (tree t1, tree t2) /* Padding record types are also compatible if they pad the same type and have the same constant size. */ if (code == RECORD_TYPE - && TYPE_IS_PADDING_P (t1) && TYPE_IS_PADDING_P (t2) + && TYPE_PADDING_P (t1) && TYPE_PADDING_P (t2) && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2)) && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) return 1; @@ -2441,7 +2437,7 @@ build_template (tree template_type, tree array_type, tree expr) tree field; while (TREE_CODE (array_type) == RECORD_TYPE - && (TYPE_IS_PADDING_P (array_type) + && (TYPE_PADDING_P (array_type) || TYPE_JUSTIFIED_MODULAR_P (array_type))) array_type = TREE_TYPE (TYPE_FIELDS (array_type)); @@ -3155,7 +3151,7 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) if (POINTER_TYPE_P (gnu_type)) return convert (gnu_type, gnu_expr64); - else if (TYPE_FAT_POINTER_P (gnu_type)) + else if (TYPE_IS_FAT_POINTER_P (gnu_type)) { tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); @@ -3304,7 +3300,7 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) if (POINTER_TYPE_P (gnu_type)) return convert (gnu_type, gnu_expr32); - else if (TYPE_FAT_POINTER_P (gnu_type)) + else if (TYPE_IS_FAT_POINTER_P (gnu_type)) { tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); @@ -3542,10 +3538,10 @@ build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, { tree template_type; - gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); + gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); template_type - = (TYPE_FAT_POINTER_P (thin_fat_ptr_type) + = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type) ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type)))) : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type)))); return build_unc_object_type (template_type, object_type, name); @@ -3641,7 +3637,7 @@ update_pointer_to (tree old_type, tree new_type) /* Now deal with the unconstrained array case. In this case the "pointer" is actually a RECORD_TYPE where both fields are pointers to dummy nodes. Turn them into pointers to the correct types using update_pointer_to. */ - else if (!TYPE_FAT_POINTER_P (ptr)) + else if (!TYPE_IS_FAT_POINTER_P (ptr)) gcc_unreachable (); else @@ -3742,7 +3738,7 @@ convert_to_fat_pointer (tree type, tree expr) NULL_TREE))); /* If EXPR is a thin pointer, make template and data from the record.. */ - else if (TYPE_THIN_POINTER_P (etype)) + else if (TYPE_IS_THIN_POINTER_P (etype)) { tree fields = TYPE_FIELDS (TREE_TYPE (etype)); @@ -3792,7 +3788,7 @@ convert_to_fat_pointer (tree type, tree expr) static tree convert_to_thin_pointer (tree type, tree expr) { - if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr))) + if (!TYPE_IS_FAT_POINTER_P (TREE_TYPE (expr))) expr = convert_to_fat_pointer (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr); @@ -3827,7 +3823,7 @@ convert (tree type, tree expr) as an unchecked conversion. Likewise if one is a mere variant of the other, so we avoid a pointless unpad/repad sequence. */ else if (code == RECORD_TYPE && ecode == RECORD_TYPE - && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype) + && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype) && (!TREE_CONSTANT (TYPE_SIZE (type)) || !TREE_CONSTANT (TYPE_SIZE (etype)) || gnat_types_compatible_p (type, etype) @@ -3837,7 +3833,7 @@ convert (tree type, tree expr) /* If the output type has padding, convert to the inner type and make a constructor to build the record, unless a variable size is involved. */ - else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + else if (code == RECORD_TYPE && TYPE_PADDING_P (type)) { /* If we previously converted from another type and our type is of variable size, remove the conversion to avoid the need for @@ -3855,7 +3851,6 @@ convert (tree type, tree expr) variable-sized temporaries. Likewise if the padding is a variant of the other, so we avoid a pointless unpad/repad sequence. */ if (TREE_CODE (expr) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0))) && (!TREE_CONSTANT (TYPE_SIZE (type)) || gnat_types_compatible_p (type, @@ -3865,12 +3860,17 @@ convert (tree type, tree expr) == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))))) return convert (type, TREE_OPERAND (expr, 0)); - /* If the result type is a padded type with a self-referentially-sized - field and the expression type is a record, do this as an unchecked - conversion. */ + /* If the inner type is of self-referential size and the expression type + is a record, do this as an unchecked conversion. But first pad the + expression if possible to have the same size on both sides. */ if (TREE_CODE (etype) == RECORD_TYPE && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)))) - return unchecked_convert (type, expr, false); + { + if (TREE_CONSTANT (TYPE_SIZE (etype))) + expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty, + false, false, false, true), expr); + return unchecked_convert (type, expr, false); + } /* If we are converting between array types with variable size, do the final conversion as an unchecked conversion, again to avoid the need @@ -3898,7 +3898,7 @@ convert (tree type, tree expr) The conditions ordering is arranged to ensure that the output type is not a padding type here, as it is not clear whether the conversion would always be correct if this was to happen. */ - else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype)) + else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype)) { tree unpadded; @@ -4147,7 +4147,8 @@ convert (tree type, tree expr) /* Otherwise, we may just bypass the input view conversion unless one of the types is a fat pointer, which is handled by specialized code below which relies on exact type matching. */ - else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) + else if (!TYPE_IS_FAT_POINTER_P (type) + && !TYPE_IS_FAT_POINTER_P (etype)) return convert (type, op0); } } @@ -4166,7 +4167,7 @@ convert (tree type, tree expr) || TREE_CODE (type) == UNION_TYPE) && (TREE_CODE (etype) == RECORD_TYPE || TREE_CODE (etype) == UNION_TYPE) - && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) + && !TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype)) return build_unary_op (INDIRECT_REF, NULL_TREE, convert (build_pointer_type (type), TREE_OPERAND (expr, 0))); @@ -4177,7 +4178,7 @@ convert (tree type, tree expr) } /* Check for converting to a pointer to an unconstrained array. */ - if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) + if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype)) return convert_to_fat_pointer (type, expr); /* If we are converting between two aggregate or vector types that are mere @@ -4249,7 +4250,7 @@ convert (tree type, tree expr) /* If converting between two pointers to records denoting both a template and type, adjust if needed to account for any differing offsets, since one might be negative. */ - if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type)) + if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type)) { tree bit_diff = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))), @@ -4267,13 +4268,13 @@ convert (tree type, tree expr) } /* If converting to a thin pointer, handle specially. */ - if (TYPE_THIN_POINTER_P (type) + if (TYPE_IS_THIN_POINTER_P (type) && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) return convert_to_thin_pointer (type, expr); /* If converting fat pointer to normal pointer, get the pointer to the array and then convert it. */ - else if (TYPE_FAT_POINTER_P (etype)) + else if (TYPE_IS_FAT_POINTER_P (etype)) expr = build_component_ref (expr, get_identifier ("P_ARRAY"), NULL_TREE, false); @@ -4370,8 +4371,7 @@ remove_conversions (tree exp, bool true_address) break; case COMPONENT_REF: - if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) + if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) return remove_conversions (TREE_OPERAND (exp, 0), true_address); break; @@ -4420,7 +4420,7 @@ maybe_unconstrained_array (tree exp) case RECORD_TYPE: /* If this is a padded type, convert to the unpadded type and see if it contains a template. */ - if (TYPE_IS_PADDING_P (TREE_TYPE (exp))) + if (TYPE_PADDING_P (TREE_TYPE (exp))) { new_exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); if (TREE_CODE (TREE_TYPE (new_exp)) == RECORD_TYPE @@ -4523,13 +4523,13 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) if ((((INTEGRAL_TYPE_P (type) && !(TREE_CODE (type) == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type))) - || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type)) + || (POINTER_TYPE_P (type) && ! TYPE_IS_THIN_POINTER_P (type)) || (TREE_CODE (type) == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type))) && ((INTEGRAL_TYPE_P (etype) && !(TREE_CODE (etype) == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype))) - || (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype)) + || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype)) || (TREE_CODE (etype) == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))) || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) @@ -5509,7 +5509,7 @@ handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), /* Get the representative array type, possibly nested within a padding record e.g. for alignment purposes. */ - if (TREE_CODE (rep_type) == RECORD_TYPE && TYPE_IS_PADDING_P (rep_type)) + if (TYPE_IS_PADDING_P (rep_type)) rep_type = TREE_TYPE (TYPE_FIELDS (rep_type)); if (TREE_CODE (rep_type) != ARRAY_TYPE) diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index f8a3dfbd525..7176740f453 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -654,12 +654,9 @@ build_binary_op (enum tree_code op_code, tree result_type, can convert the constructor to the inner type, to avoid putting a VIEW_CONVERT_EXPR on the LHS. But don't do so if we wouldn't have actually copied anything. */ - else if (TREE_CODE (left_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (left_type) + else if (TYPE_IS_PADDING_P (left_type) && TREE_CONSTANT (TYPE_SIZE (left_type)) && ((TREE_CODE (right_operand) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) - == RECORD_TYPE && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (right_operand, 0))) && gnat_types_compatible_p @@ -758,6 +755,12 @@ build_binary_op (enum tree_code op_code, tree result_type, left_type = TREE_TYPE (left_operand); } + /* For a range, make sure the element type is consistent. */ + if (op_code == ARRAY_RANGE_REF + && TREE_TYPE (operation_type) != TREE_TYPE (left_type)) + operation_type = build_array_type (TREE_TYPE (left_type), + TYPE_DOMAIN (operation_type)); + /* Then convert the right operand to its base type. This will prevent unneeded sign conversions when sizetype is wider than integer. */ right_operand = convert (right_base_type, right_operand); @@ -836,8 +839,8 @@ build_binary_op (enum tree_code op_code, tree result_type, convert both operands to that type. */ if (left_base_type != right_base_type) { - if (TYPE_FAT_POINTER_P (left_base_type) - && TYPE_FAT_POINTER_P (right_base_type) + if (TYPE_IS_FAT_POINTER_P (left_base_type) + && TYPE_IS_FAT_POINTER_P (right_base_type) && TYPE_MAIN_VARIANT (left_base_type) == TYPE_MAIN_VARIANT (right_base_type)) best_type = left_base_type; @@ -872,7 +875,7 @@ build_binary_op (enum tree_code op_code, tree result_type, /* If we are comparing a fat pointer against zero, we need to just compare the data pointer. */ - else if (TYPE_FAT_POINTER_P (left_base_type) + else if (TYPE_IS_FAT_POINTER_P (left_base_type) && TREE_CODE (right_operand) == CONSTRUCTOR && integer_zerop (VEC_index (constructor_elt, CONSTRUCTOR_ELTS (right_operand), @@ -1117,11 +1120,10 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) /* If INNER is a padding type whose field has a self-referential size, convert to that inner type. We know the offset is zero and we need to have that type visible. */ - if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (inner)) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (inner))))))) + if (TYPE_IS_PADDING_P (TREE_TYPE (inner)) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (inner)))))) inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))), inner); @@ -1154,13 +1156,11 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) /* If this is just a constructor for a padded record, we can just take the address of the single field and convert it to a pointer to our type. */ - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + if (TYPE_IS_PADDING_P (type)) { - result = (VEC_index (constructor_elt, - CONSTRUCTOR_ELTS (operand), - 0) - ->value); - + result = VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (operand), + 0)->value; result = convert (build_pointer_type (TREE_TYPE (operand)), build_unary_op (ADDR_EXPR, NULL_TREE, result)); break; @@ -1202,8 +1202,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) /* If we are taking the address of a padded record whose field is contains a template, take the address of the template. */ - if (TREE_CODE (type) == RECORD_TYPE - && TYPE_IS_PADDING_P (type) + if (TYPE_IS_PADDING_P (type) && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type)))) { @@ -1226,7 +1225,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) make up an expression to do so. This will never survive to the backend. If TYPE is a thin pointer, first convert the operand to a fat pointer. */ - if (TYPE_THIN_POINTER_P (type) + if (TYPE_IS_THIN_POINTER_P (type) && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) { operand @@ -1235,7 +1234,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) type = TREE_TYPE (operand); } - if (TYPE_FAT_POINTER_P (type)) + if (TYPE_IS_FAT_POINTER_P (type)) { result = build1 (UNCONSTRAINED_ARRAY_REF, TYPE_UNCONSTRAINED_ARRAY (type), operand); @@ -1252,7 +1251,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) } side_effects - = (!TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))); + = (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))); break; case NEGATE_EXPR: @@ -2027,7 +2026,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the sizes of the object and its template. Allocate the whole thing and fill in the parts that are known. */ - else if (TYPE_FAT_OR_THIN_POINTER_P (result_type)) + else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type)) { tree storage_type = build_unc_object_type_from_ptr (result_type, type, @@ -2049,10 +2048,9 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, gnat_proc, gnat_pool, gnat_node); storage = convert (storage_ptr_type, protect_multiple_eval (storage)); - if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + if (TYPE_IS_PADDING_P (type)) { type = TREE_TYPE (TYPE_FIELDS (type)); - if (init) init = convert (type, init); } diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index e25400d09fc..4b906fe91e9 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -307,10 +307,13 @@ The GNAT Library * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: * Ada.Text_IO.C_Streams (a-tiocst.ads):: +* Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads):: * Ada.Wide_Characters.Unicode (a-wichun.ads):: * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: +* Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads):: * Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: * Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: +* Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads):: * GNAT.Altivec (g-altive.ads):: * GNAT.Altivec.Conversions (g-altcon.ads):: * GNAT.Altivec.Vector_Operations (g-alveop.ads):: @@ -13496,10 +13499,13 @@ of GNAT, and will generate a warning message. * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: * Ada.Text_IO.C_Streams (a-tiocst.ads):: +* Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads):: * Ada.Wide_Characters.Unicode (a-wichun.ads):: * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: +* Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads):: * Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: * Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: +* Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads):: * GNAT.Altivec (g-altive.ads):: * GNAT.Altivec.Conversions (g-altcon.ads):: * GNAT.Altivec.Vector_Operations (g-alveop.ads):: @@ -13819,6 +13825,18 @@ C streams and @code{Text_IO}. The stream identifier can be extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. +@node Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads) +@section @code{Ada.Text_IO.Reset_Standard_Files} (@file{a-tirsfi.ads}) +@cindex @code{Ada.Text_IO.Reset_Standard_Files} (@file{a-tirsfi.ads}) +@cindex @code{Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Text_IO. This is useful in a situation (such as a restart in an +embedded application) where the status of the files may change during +execution (for example a standard input file may be redefined to be +interactive). + @node Ada.Wide_Characters.Unicode (a-wichun.ads) @section @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) @cindex @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) @@ -13839,6 +13857,18 @@ C streams and @code{Wide_Text_IO}. The stream identifier can be extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. +@node Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads) +@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@file{a-wrstfi.ads}) +@cindex @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@file{a-wrstfi.ads}) +@cindex @code{Wide_Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Wide_Text_IO. This is useful in a situation (such as a restart in an +embedded application) where the status of the files may change during +execution (for example a standard input file may be redefined to be +interactive). + @node Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads) @section @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) @cindex @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) @@ -13859,6 +13889,18 @@ C streams and @code{Wide_Wide_Text_IO}. The stream identifier can be extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. +@node Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads) +@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@file{a-zrstfi.ads}) +@cindex @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@file{a-zrstfi.ads}) +@cindex @code{Wide_Wide_Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Wide_Wide_Text_IO. This is useful in a situation (such as a +restart in an embedded application) where the status of the files may +change during execution (for example a standard input file may be +redefined to be interactive). + @node GNAT.Altivec (g-altive.ads) @section @code{GNAT.Altivec} (@file{g-altive.ads}) @cindex @code{GNAT.Altivec} (@file{g-altive.ads}) diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index d777f6dd099..19304a75f40 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -5268,6 +5268,19 @@ This warning can also be turned on using @option{-gnatwa}. This switch disables warnings for a @code{with} of an internal GNAT implementation unit. +@item -gnatw.i +@emph{Activate warnings on overlapping actuals.} +@cindex @option{-gnatw.i} (@command{gcc}) +This switch enables a warning on statically detectable overlapping actuals in +a subprogram call, when one of the actuals is an in-out parameter, and the +types of the actuals are not by-copy types. The warning is off by default, +and is not included under -gnatwa. + +@item -gnatw.I +@emph{Disable warnings on overlapping actuals.} +@cindex @option{-gnatw.I} (@command{gcc}) +This switch disables warnings on overlapping actuals in a call.. + @item -gnatwj @emph{Activate warnings on obsolescent features (Annex J).} @cindex @option{-gnatwj} (@command{gcc}) @@ -6434,6 +6447,10 @@ If the token preceding a left parenthesis ends with a letter or digit, then a space must separate the two tokens. @item +if the token following a right parenthesis starts with a letter or digit, then +a space must separate the two tokens. + +@item A right parenthesis must either be the first non-blank character on a line, or it must be preceded by a non-blank character. @@ -6524,8 +6541,6 @@ the exception of ORDERED_SUBPROGRAMS, UNNECESSARY_BLANK_LINES, XTRA_PARENS, and DOS_LINE_ENDINGS. In addition @end ifset - - The switch @ifclear vms @option{-gnatyN} @@ -20659,7 +20674,7 @@ Invoking @command{gnatcheck} on the command line has the form: @smallexample $ gnatcheck @ovar{switches} @{@var{filename}@} @r{[}^-files^/FILES^=@{@var{arg_list_filename}@}@r{]} - @r{[}-cargs @var{gcc_switches}@r{]} @r{[}-rules @var{rule_options}@r{]} + @r{[}-cargs @var{gcc_switches}@r{]} -rules @var{rule_options} @end smallexample @noindent @@ -20785,18 +20800,9 @@ Quiet mode. All the diagnostics about rule violations are placed in the Short format of the report file (no version information, no list of applied rules, no list of checked sources is included) -@cindex @option{^-s1^/COMPILER_STYLE^} (@command{gnatcheck}) -@item ^-s1^/COMPILER_STYLE^ -Include the compiler-style section in the report file - -@cindex @option{^-s2^/BY_RULES^} (@command{gnatcheck}) -@item ^-s2^/BY_RULES^ -Include the section containing diagnostics ordered by rules in the report file - -@cindex @option{^-s3^/BY_FILES_BY_RULES^} (@command{gnatcheck}) -@item ^-s3^/BY_FILES_BY_RULES^ -Include the section containing diagnostics ordered by files and then by rules -in the report file +@cindex @option{^--include-file=@var{file}^/INCLUDE_FILE=@var{file}^} (@command{gnatcheck}) +@item ^--include-file^/INCLUDE_FILE^ +Append the content of the specified text file to the report file @cindex @option{^-t^/TIME^} (@command{gnatcheck}) @item ^-t^/TIME^ @@ -21226,7 +21232,9 @@ This rule has no parameters. @cindex @code{Anonymous_Subtypes} rule (for @command{gnatcheck}) @noindent -Flag all uses of anonymous subtypes. A use of an anonymous subtype is +Flag all uses of anonymous subtypes (except cases when subtype indication +is a part of a record component definition, and this subtype indication +depends on a discriminant). A use of an anonymous subtype is any instance of a subtype indication with a constraint, other than one that occurs immediately within a subtype declaration. Any use of a range other than as a constraint used immediately within a subtype declaration diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 48eceb0ff77..fb3dc3d74ba 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -838,6 +838,28 @@ begin end if; end loop; + -- Subunits do not appear in the elaboration table because they + -- are subsumed by their parent units, but we need to list them + -- for other tools. For now they are listed after other files, + -- rather than right after their parent, since there is no easy + -- link between the elaboration table and the ALIs table ??? + -- Note also that subunits may appear repeatedly in the list, + -- if the parent unit appears in the context of several units + -- in the closure. + + for J in Sdep.First .. Sdep.Last loop + if Sdep.Table (J).Subunit_Name /= No_Name + and then not Is_Internal_File_Name (Sdep.Table (J).Sfile) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Sdep.Table (J).Sfile)); + Write_Eol; + end if; + end loop; + if not Zero_Formatting then Write_Eol; end if; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 563b92d150e..e0ccc228473 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -1612,6 +1612,7 @@ begin elsif Argv.all = "-eL" then Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; Remove_Switch (Arg_Num); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index eb255d9fc08..5347269be00 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -189,6 +189,13 @@ procedure Gnatlink is Object_List_File_Required : Boolean := False; -- Set to True to force generation of a response file + Shared_Libgcc_Default : Character; + for Shared_Libgcc_Default'Size use Character'Size; + pragma Import + (C, Shared_Libgcc_Default, "__gnat_shared_libgcc_default"); + -- Indicates wether libgcc should be statically linked (use 'T') or + -- dynamically linked (use 'H') by default. + function Base_Name (File_Name : String) return String; -- Return just the file name part without the extension (if present) @@ -2141,11 +2148,15 @@ begin if Linker_Path = Gcc_Path and then VM_Target = No_VM then - -- If gcc is not called with -shared-libgcc, call it with - -- -static-libgcc, as there are some platforms where one of - -- these two switches is compulsory to link. + -- For systems where the default is to link statically + -- with libgcc, if gcc is not called with + -- -shared-libgcc, call it with -static-libgcc, as + -- there are some platforms where one of these two + -- switches is compulsory to link. - if not Shared_Libgcc_Seen then + if Shared_Libgcc_Default = 'T' + and then not Shared_Libgcc_Seen + then Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; Num_Args := Num_Args + 1; diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 4c6d00bd99e..4c935bebbc7 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -385,6 +385,7 @@ procedure Gnatname is elsif Arg = "-eL" then Opt.Follow_Links_For_Files := True; + Opt.Follow_Links_For_Dirs := True; -- -f diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 5fe46cd0ff2..f9bcf634e53 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2114,6 +2114,7 @@ __gnat_install_handler(void) #elif defined(__APPLE__) #include <signal.h> +#include <sys/syscall.h> #include <mach/mach_vm.h> #include <mach/mach_init.h> #include <mach/vm_statistics.h> @@ -2123,9 +2124,9 @@ char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */ static void __gnat_error_handler (int sig, siginfo_t * si, void * uc); -/* Defined in xnu unix_signal.c */ +/* Defined in xnu unix_signal.c. + Tell the kernel to re-use alt stack when delivering a signal. */ #define UC_RESET_ALT_STACK 0x80000000 -extern int sigreturn (void *uc, int flavour); /* Return true if ADDR is within a stack guard area. */ static int @@ -2173,8 +2174,9 @@ __gnat_error_handler (int sig, siginfo_t * si, void * uc ATTRIBUTE_UNUSED) msg = "erroneous memory access"; } /* Reset the use of alt stack, so that the alt stack will be used - for the next signal delivery. */ - sigreturn (NULL, UC_RESET_ALT_STACK); + for the next signal delivery. + The stack can't be used in case of stack checking. */ + syscall (SYS_sigreturn, NULL, UC_RESET_ALT_STACK); break; case SIGFPE: @@ -2301,8 +2303,10 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, { /* We used to compensate here for the raised from call vs raised from signal exception discrepancy with the GCC ZCX scheme, but this now can be dealt - with generically in the unwinder (see GCC PR other/26208). Only the VMS - ports still do the compensation described in the few lines below. + with generically in the unwinder (see GCC PR other/26208). This however + requires the use of the _Unwind_GetIPInfo routine in raise-gcc.c, which + is predicated on the definition of HAVE_GETIPINFO at compile time. Only + the VMS ports still do the compensation described in the few lines below. *** Call vs signal exception discrepancy with GCC ZCX scheme *** diff --git a/gcc/ada/link.c b/gcc/ada/link.c index c36d8e78a42..6ebd329612f 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -62,6 +62,9 @@ /* shared_libgnat_default gives the system dependent link method that */ /* be used by default for linking libgnat (shared or static) */ +/* shared_libgcc_default gives the system dependent link method that */ +/* be used by default for linking libgcc (shared or statis) */ + /* using_gnu_linker is set to 1 when the GNU linker is used under this */ /* target. */ @@ -89,6 +92,7 @@ const char *__gnat_run_path_option = "-Wl,-rpath,"; int __gnat_link_max = 10000; unsigned char __gnat_objlist_file_supported = 1; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; unsigned char __gnat_using_gnu_linker = 0; const char *__gnat_object_library_extension = ".a"; unsigned char __gnat_separate_run_path_options = 0; @@ -99,6 +103,7 @@ const char *__gnat_run_path_option = "-Wl,-rpath,"; int __gnat_link_max = 5000; unsigned char __gnat_objlist_file_supported = 1; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; unsigned char __gnat_using_gnu_linker = 0; const char *__gnat_object_library_extension = ".a"; unsigned char __gnat_separate_run_path_options = 0; @@ -109,6 +114,7 @@ const char *__gnat_run_path_option = ""; int __gnat_link_max = 30000; unsigned char __gnat_objlist_file_supported = 1; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; unsigned char __gnat_using_gnu_linker = 1; const char *__gnat_object_library_extension = ".a"; unsigned char __gnat_separate_run_path_options = 0; @@ -119,6 +125,7 @@ const char *__gnat_run_path_option = "-Wl,+b,"; int __gnat_link_max = 5000; unsigned char __gnat_objlist_file_supported = 1; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; unsigned char __gnat_using_gnu_linker = 0; const char *__gnat_object_library_extension = ".a"; unsigned char __gnat_separate_run_path_options = 0; @@ -129,6 +136,7 @@ const char *__gnat_run_path_option = ""; int __gnat_link_max = 15000; const unsigned char __gnat_objlist_file_supported = 1; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; unsigned char __gnat_using_gnu_linker = 0; const char *__gnat_object_library_extension = ".a"; unsigned char __gnat_separate_run_path_options = 0; @@ -137,6 +145,7 @@ unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = ""; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 2147483647; unsigned char __gnat_objlist_file_supported = 0; unsigned char __gnat_using_gnu_linker = 0; @@ -147,6 +156,7 @@ unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = "-Wl,-R"; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 2147483647; unsigned char __gnat_objlist_file_supported = 0; unsigned char __gnat_using_gnu_linker = 0; @@ -157,6 +167,7 @@ unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = "-Wl,-rpath,"; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 8192; unsigned char __gnat_objlist_file_supported = 1; unsigned char __gnat_using_gnu_linker = 1; @@ -167,6 +178,7 @@ unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_object_file_option = "-Wl,-filelist,"; const char *__gnat_run_path_option = "-Wl,-rpath,"; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = SHARED; int __gnat_link_max = 262144; unsigned char __gnat_objlist_file_supported = 1; unsigned char __gnat_using_gnu_linker = 0; @@ -177,6 +189,7 @@ unsigned char __gnat_separate_run_path_options = 1; const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = "-Wl,-rpath,"; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 8192; unsigned char __gnat_objlist_file_supported = 1; unsigned char __gnat_using_gnu_linker = 1; @@ -187,6 +200,7 @@ unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_object_file_option = ""; const char *__gnat_run_path_option = ""; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 2147483647; unsigned char __gnat_objlist_file_supported = 0; unsigned char __gnat_using_gnu_linker = 0; @@ -200,6 +214,7 @@ unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_run_path_option = ""; const char *__gnat_object_file_option = ""; char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 2147483647; unsigned char __gnat_objlist_file_supported = 0; unsigned char __gnat_using_gnu_linker = 0; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index dacf290c273..12e6386d045 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -106,13 +106,17 @@ package body Make is Full_Source_File : File_Name_Type; Lib_File : File_Name_Type; Source_Unit : Unit_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : aliased File_Attributes; Mapping_File : Natural := No_Mapping_File; Project : Project_Id := No_Project; - Syntax_Only : Boolean := False; - Output_Is_Object : Boolean := True; end record; -- Data recorded for each compilation process spawned + No_Compilation_Data : constant Compilation_Data := + (Invalid_Pid, No_File, No_File, No_Unit_Name, No_File, Unknown_Attributes, + No_Mapping_File, No_Project); + type Comp_Data_Arr is array (Positive range <>) of Compilation_Data; type Comp_Data_Ptr is access Comp_Data_Arr; Running_Compile : Comp_Data_Ptr; @@ -356,7 +360,7 @@ package body Make is Project_Of_Current_Object_Directory : Project_Id := No_Project; -- The object directory of the project for the last compilation. Avoid -- calling Change_Dir if the current working directory is already this - -- directory + -- directory. -- Packages of project files where unknown attributes are errors @@ -740,6 +744,8 @@ package body Make is Is_Main_Source : Boolean; The_Args : Argument_List; Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; Read_Only : Boolean; ALI : out ALI_Id; O_File : out File_Name_Type; @@ -750,6 +756,10 @@ package body Make is -- ALI is the ALI_Id corresponding to Lib_File. If Lib_File in not -- up-to-date, then the corresponding source file needs to be recompiled. -- In this case ALI = No_ALI_Id. + -- Full_Lib_File must be the result of calling Osint.Full_Lib_File_Name on + -- Lib_File. Precomputing it saves system calls. Lib_File_Attr is the + -- initialized attributes of that file, which is also used to save on + -- system calls (it can safely be initialized to Unknown_Attributes). procedure Check_Linker_Options (E_Stamp : Time_Stamp_Type; @@ -1414,6 +1424,8 @@ package body Make is Is_Main_Source : Boolean; The_Args : Argument_List; Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; Read_Only : Boolean; ALI : out ALI_Id; O_File : out File_Name_Type; @@ -1523,9 +1535,6 @@ package body Make is -- Data declarations for Check -- --------------------------------- - Full_Lib_File : File_Name_Type; - -- Full name of current library file - Full_Obj_File : File_Name_Type; -- Full name of the object file corresponding to Lib_File @@ -1576,15 +1585,14 @@ package body Make is Check_Object_Consistency; begin Check_Object_Consistency := False; - Text := Read_Library_Info (Lib_File); + Text := Read_Library_Info_From_Full (Full_Lib_File, Lib_File_Attr); Check_Object_Consistency := Saved_Check_Object_Consistency; end; else - Text := Read_Library_Info (Lib_File); + Text := Read_Library_Info_From_Full (Full_Lib_File, Lib_File_Attr); end if; - Full_Lib_File := Full_Library_Info_Name; Full_Obj_File := Full_Object_File_Name; Lib_Stamp := Current_Library_File_Stamp; Obj_Stamp := Current_Object_File_Stamp; @@ -1858,7 +1866,8 @@ package body Make is Normalize_Pathname (Dir_Name (Get_Name_String (Full_Lib_File)), - Resolve_Links => True, + Resolve_Links => + Opt.Follow_Links_For_Dirs, Case_Sensitive => False); begin @@ -2418,62 +2427,22 @@ package body Make is Initialize_ALI_Data : Boolean := True; Max_Process : Positive := 1) is - Source_Unit : Unit_Name_Type; - -- Current source unit - - Source_File : File_Name_Type; - -- Current source file - - Full_Source_File : File_Name_Type; - -- Full name of the current source file - - Lib_File : File_Name_Type; - -- Current library file - - Full_Lib_File : File_Name_Type; - -- Full name of the current library file - - Obj_File : File_Name_Type; - -- Full name of the object file corresponding to Lib_File - - Obj_Stamp : Time_Stamp_Type; - -- Time stamp of the current object file - - Sfile : File_Name_Type; - -- Contains the source file of the units withed by Source_File - - Uname : Unit_Name_Type; - -- Contains the unit name of the units withed by Source_File - - ALI : ALI_Id; - -- ALI Id of the current ALI file - - -- Comment following declarations ??? - - Read_Only : Boolean := False; - - Compilation_OK : Boolean; - Need_To_Compile : Boolean; - - Pid : Process_Id; - Text : Text_Buffer_Ptr; - - Mfile : Natural := No_Mapping_File; + Mfile : Natural := No_Mapping_File; + Mapping_File_Arg : String_Access; + -- Info on the mapping file Need_To_Check_Standard_Library : Boolean := Check_Readonly_Files and not Unique_Compile; - Mapping_File_Arg : String_Access; - - Process_Created : Boolean := False; - procedure Add_Process - (Pid : Process_Id; - Sfile : File_Name_Type; - Afile : File_Name_Type; - Uname : Unit_Name_Type; - Mfile : Natural := No_Mapping_File); + (Pid : Process_Id; + Sfile : File_Name_Type; + Afile : File_Name_Type; + Uname : Unit_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : File_Attributes; + Mfile : Natural := No_Mapping_File); -- Adds process Pid to the current list of outstanding compilation -- processes and record the full name of the source file Sfile that -- we are compiling, the name of its library file Afile and the @@ -2482,18 +2451,16 @@ package body Make is -- array The_Mapping_File_Names. procedure Await_Compile - (Sfile : out File_Name_Type; - Afile : out File_Name_Type; - Uname : out Unit_Name_Type; + (Data : out Compilation_Data; OK : out Boolean); -- Awaits that an outstanding compilation process terminates. When - -- it does set Sfile to the name of the source file that was compiled - -- Afile to the name of its library file and Uname to the name of its - -- unit. Note that this time stamp can be used to check whether the + -- it does set Data to the information registered for the corresponding + -- call to Add_Process. + -- Note that this time stamp can be used to check whether the -- compilation did generate an object file. OK is set to True if the - -- compilation succeeded. Note that Sfile, Afile and Uname could be - -- resp. No_File, No_File and No_Name if there were no compilations - -- to wait for. + -- compilation succeeded. + -- Data could be No_Compilation_Data if there was no compilation to wait + -- for. function Bad_Compilation_Count return Natural; -- Returns the number of compilation failures @@ -2501,8 +2468,15 @@ package body Make is procedure Check_Standard_Library; -- Check if s-stalib.adb needs to be compiled - procedure Collect_Arguments_And_Compile (Source_Index : Int); - -- Collect arguments from project file (if any) and compile + procedure Collect_Arguments_And_Compile + (Full_Source_File : File_Name_Type; + Lib_File : File_Name_Type; + Source_Index : Int; + Pid : out Process_Id; + Process_Created : out Boolean); + -- Collect arguments from project file (if any) and compile. + -- If no compilation was attempted, Processed_Created is set to False, + -- and the value of Pid is unknown. function Compile (Project : Project_Id; @@ -2545,16 +2519,41 @@ package body Make is procedure Record_Good_ALI (A : ALI_Id); -- Records in the previous set the Id of an ALI file + function Must_Exit_Because_Of_Error return Boolean; + -- Return True if there were errors and the user decided to exit in such + -- a case. This waits for any outstanding compilation. + + function Start_Compile_If_Possible (Args : Argument_List) return Boolean; + -- Check if there is more work that we can do (i.e. the Queue is non + -- empty). If there is, do it only if we have not yet used up all the + -- available processes. + -- Returns True if we should exit the main loop + + procedure Wait_For_Available_Slot; + -- Check if we should wait for a compilation to finish. This is the case + -- if all the available processes are busy compiling sources or there is + -- nothing else to do (that is the Q is empty and there are no good ALIs + -- to process). + + procedure Fill_Queue_From_ALI_Files; + -- Check if we recorded good ALI files. If yes process them now in the + -- order in which they have been recorded. There are two occasions in + -- which we record good ali files. The first is in phase 1 when, after + -- scanning an existing ALI file we realize it is up-to-date, the second + -- instance is after a successful compilation. + ----------------- -- Add_Process -- ----------------- procedure Add_Process - (Pid : Process_Id; - Sfile : File_Name_Type; - Afile : File_Name_Type; - Uname : Unit_Name_Type; - Mfile : Natural := No_Mapping_File) + (Pid : Process_Id; + Sfile : File_Name_Type; + Afile : File_Name_Type; + Uname : Unit_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : File_Attributes; + Mfile : Natural := No_Mapping_File) is OC1 : constant Positive := Outstanding_Compiles + 1; @@ -2562,14 +2561,15 @@ package body Make is pragma Assert (OC1 <= Max_Process); pragma Assert (Pid /= Invalid_Pid); - Running_Compile (OC1).Pid := Pid; - Running_Compile (OC1).Full_Source_File := Sfile; - Running_Compile (OC1).Lib_File := Afile; - Running_Compile (OC1).Source_Unit := Uname; - Running_Compile (OC1).Mapping_File := Mfile; - Running_Compile (OC1).Project := Arguments_Project; - Running_Compile (OC1).Syntax_Only := Syntax_Only; - Running_Compile (OC1).Output_Is_Object := Output_Is_Object; + Running_Compile (OC1) := + (Pid => Pid, + Full_Source_File => Sfile, + Lib_File => Afile, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr, + Source_Unit => Uname, + Mapping_File => Mfile, + Project => Arguments_Project); Outstanding_Compiles := OC1; end Add_Process; @@ -2579,21 +2579,17 @@ package body Make is ------------------- procedure Await_Compile - (Sfile : out File_Name_Type; - Afile : out File_Name_Type; - Uname : out Unit_Name_Type; - OK : out Boolean) + (Data : out Compilation_Data; + OK : out Boolean) is Pid : Process_Id; Project : Project_Id; - Data : Project_Compilation_Access; + Comp_Data : Project_Compilation_Access; begin pragma Assert (Outstanding_Compiles > 0); - Sfile := No_File; - Afile := No_File; - Uname := No_Unit_Name; + Data := No_Compilation_Data; OK := False; -- The loop here is a work-around for a problem on VMS; in some @@ -2611,21 +2607,19 @@ package body Make is for J in Running_Compile'First .. Outstanding_Compiles loop if Pid = Running_Compile (J).Pid then - Sfile := Running_Compile (J).Full_Source_File; - Afile := Running_Compile (J).Lib_File; - Uname := Running_Compile (J).Source_Unit; - Syntax_Only := Running_Compile (J).Syntax_Only; - Output_Is_Object := Running_Compile (J).Output_Is_Object; + Data := Running_Compile (J); Project := Running_Compile (J).Project; - -- If a mapping file was used by this compilation, - -- get its file name for reuse by a subsequent compilation + -- If a mapping file was used by this compilation, get its + -- file name for reuse by a subsequent compilation. if Running_Compile (J).Mapping_File /= No_Mapping_File then - Data := Project_Compilation_Htable.Get + Comp_Data := Project_Compilation_Htable.Get (Project_Compilation, Project); - Data.Last_Free_Indices := Data.Last_Free_Indices + 1; - Data.Free_Mapping_File_Indices (Data.Last_Free_Indices) := + Comp_Data.Last_Free_Indices := + Comp_Data.Last_Free_Indices + 1; + Comp_Data.Free_Mapping_File_Indices + (Comp_Data.Last_Free_Indices) := Running_Compile (J).Mapping_File; end if; @@ -2707,11 +2701,13 @@ package body Make is -- Collect_Arguments_And_Compile -- ----------------------------------- - procedure Collect_Arguments_And_Compile (Source_Index : Int) is + procedure Collect_Arguments_And_Compile + (Full_Source_File : File_Name_Type; + Lib_File : File_Name_Type; + Source_Index : Int; + Pid : out Process_Id; + Process_Created : out Boolean) is begin - -- Process_Created will be set True if an attempt is made to compile - -- the source, that is if it is not in an externally built project. - Process_Created := False; -- If we use mapping file (-P or -C switches), then get one @@ -2759,11 +2755,11 @@ package body Make is Pid := Compile - (Arguments_Project, - File_Name_Type (Arguments_Path_Name), - Lib_File, - Source_Index, - Arguments (1 .. Last_Argument)); + (Project => Arguments_Project, + S => File_Name_Type (Arguments_Path_Name), + L => Lib_File, + Source_Index => Source_Index, + Args => Arguments (1 .. Last_Argument)); Process_Created := True; end if; @@ -2773,11 +2769,11 @@ package body Make is Pid := Compile - (Main_Project, - Full_Source_File, - Lib_File, - Source_Index, - Arguments (1 .. Last_Argument)); + (Project => Main_Project, + S => Full_Source_File, + L => Lib_File, + Source_Index => Source_Index, + Args => Arguments (1 .. Last_Argument)); Process_Created := True; end if; end Collect_Arguments_And_Compile; @@ -2994,6 +2990,119 @@ package body Make is (Gcc_Path.all, Comp_Args (Args'First .. Comp_Last)); end Compile; + ------------------------------- + -- Fill_Queue_From_ALI_Files -- + ------------------------------- + + procedure Fill_Queue_From_ALI_Files is + ALI : ALI_Id; + Source_Index : Int; + Sfile : File_Name_Type; + Uname : Unit_Name_Type; + Unit_Name : Name_Id; + Uid : Prj.Unit_Index; + begin + while Good_ALI_Present loop + ALI := Get_Next_Good_ALI; + Source_Index := Unit_Index_Of (ALIs.Table (ALI).Afile); + + -- If we are processing the library file corresponding to the + -- main source file check if this source can be a main unit. + + if ALIs.Table (ALI).Sfile = Main_Source + and then Source_Index = Main_Index + then + Main_Unit := ALIs.Table (ALI).Main_Program /= None; + end if; + + -- The following adds the standard library (s-stalib) to the + -- list of files to be handled by gnatmake: this file and any + -- files it depends on are always included in every bind, + -- even if they are not in the explicit dependency list. + -- Of course, it is not added if Suppress_Standard_Library + -- is True. + + -- However, to avoid annoying output about s-stalib.ali being + -- read only, when "-v" is used, we add the standard library + -- only when "-a" is used. + + if Need_To_Check_Standard_Library then + Check_Standard_Library; + end if; + + -- Now insert in the Q the unmarked source files (i.e. those + -- which have never been inserted in the Q and hence never + -- considered). Only do that if Unique_Compile is False. + + if not Unique_Compile then + for J in + ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit + loop + for K in + Units.Table (J).First_With .. Units.Table (J).Last_With + loop + Sfile := Withs.Table (K).Sfile; + Uname := Withs.Table (K).Uname; + + -- If project files are used, find the proper source + -- to compile, in case Sfile is the spec, but there + -- is a body. + + if Main_Project /= No_Project then + Get_Name_String (Uname); + 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 + if Uid.File_Names (Impl) /= null + and then not Uid.File_Names (Impl).Locally_Removed + then + Sfile := Uid.File_Names (Impl).File; + Source_Index := Uid.File_Names (Impl).Index; + + elsif Uid.File_Names (Spec) /= null + and then not Uid.File_Names (Spec).Locally_Removed + then + Sfile := Uid.File_Names (Spec).File; + Source_Index := Uid.File_Names (Spec).Index; + end if; + end if; + end if; + + Dependencies.Append ((ALIs.Table (ALI).Sfile, Sfile)); + + if Is_In_Obsoleted (Sfile) then + Executable_Obsolete := True; + end if; + + if Sfile = No_File then + Debug_Msg ("Skipping generic:", Withs.Table (K).Uname); + + else + Source_Index := Unit_Index_Of (Withs.Table (K).Afile); + + if Is_Marked (Sfile, Source_Index) then + Debug_Msg ("Skipping marked file:", Sfile); + + elsif not Check_Readonly_Files + and then Is_Internal_File_Name (Sfile, False) + then + Debug_Msg ("Skipping internal file:", Sfile); + + else + Insert_Q + (Sfile, Withs.Table (K).Uname, Source_Index); + Mark (Sfile, Source_Index); + end if; + end if; + end loop; + end loop; + end if; + end loop; + end Fill_Queue_From_ALI_Files; + ---------------------- -- Get_Mapping_File -- ---------------------- @@ -3049,6 +3158,29 @@ package body Make is return Good_ALI.First <= Good_ALI.Last; end Good_ALI_Present; + -------------------------------- + -- Must_Exit_Because_Of_Error -- + -------------------------------- + + function Must_Exit_Because_Of_Error return Boolean is + Data : Compilation_Data; + Success : Boolean; + begin + if Bad_Compilation_Count > 0 and then not Keep_Going then + while Outstanding_Compiles > 0 loop + Await_Compile (Data, Success); + + if not Success then + Record_Failure (Data.Full_Source_File, Data.Source_Unit); + end if; + end loop; + + return True; + end if; + + return False; + end Must_Exit_Because_Of_Error; + -------------------- -- Record_Failure -- -------------------- @@ -3073,276 +3205,320 @@ package body Make is Good_ALI.Table (Good_ALI.Last) := A; end Record_Good_ALI; - -- Start of processing for Compile_Sources - - begin - pragma Assert (Args'First = 1); - - Outstanding_Compiles := 0; - Running_Compile := new Comp_Data_Arr (1 .. Max_Process); - - -- Package and Queue initializations - - Good_ALI.Init; - - if First_Q_Initialization then - Init_Q; - end if; + ------------------------------- + -- Start_Compile_If_Possible -- + ------------------------------- - if Initialize_ALI_Data then - Initialize_ALI; - Initialize_ALI_Source; - end if; + function Start_Compile_If_Possible + (Args : Argument_List) return Boolean + is + In_Lib_Dir : Boolean; + Need_To_Compile : Boolean; + Pid : Process_Id; + Process_Created : Boolean; + + Source_File : File_Name_Type; + Full_Source_File : File_Name_Type; + Source_File_Attr : aliased File_Attributes; + -- The full name of the source file and its attributes (size, ...) + + Source_Unit : Unit_Name_Type; + Source_Index : Int; + -- Index of the current unit in the current source file + + Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : aliased File_Attributes; + Read_Only : Boolean := False; + ALI : ALI_Id; + -- The ALI file and its attributes (size, stamp, ...) + + Obj_File : File_Name_Type; + Obj_Stamp : Time_Stamp_Type; + -- The object file - -- The following two flags affect the behavior of ALI.Set_Source_Table. - -- We set Check_Source_Files to True to ensure that source file - -- time stamps are checked, and we set All_Sources to False to - -- avoid checking the presence of the source files listed in the - -- source dependency section of an ali file (which would be a mistake - -- since the ali file may be obsolete). + begin + if not Empty_Q and then Outstanding_Compiles < Max_Process then + Extract_From_Q (Source_File, Source_Unit, Source_Index); - Check_Source_Files := True; - All_Sources := False; + Osint.Full_Source_Name + (Source_File, + Full_File => Full_Source_File, + Attr => Source_File_Attr'Access); - -- Only insert in the Q if it is not already done, to avoid simultaneous - -- compilations if -jnnn is used. + Lib_File := Osint.Lib_File_Name (Source_File, Source_Index); + Osint.Full_Lib_File_Name + (Lib_File, + Lib_File => Full_Lib_File, + Attr => Lib_File_Attr); - if not Is_Marked (Main_Source, Main_Index) then - Insert_Q (Main_Source, Index => Main_Index); - Mark (Main_Source, Main_Index); - end if; + -- If this source has already been compiled, the executable is + -- obsolete. - First_Compiled_File := No_File; - Most_Recent_Obj_File := No_File; - Most_Recent_Obj_Stamp := Empty_Time_Stamp; - Main_Unit := False; + if Is_In_Obsoleted (Source_File) then + Executable_Obsolete := True; + end if; - -- Keep looping until there is no more work to do (the Q is empty) - -- and all the outstanding compilations have terminated + In_Lib_Dir := Full_Lib_File /= No_File + and then In_Ada_Lib_Dir (Full_Lib_File); - Make_Loop : while not Empty_Q or else Outstanding_Compiles > 0 loop + -- Since the following requires a system call, we precompute it + -- when needed. - -- If the user does not want to keep going in case of errors then - -- wait for the remaining outstanding compiles and then exit. + if not In_Lib_Dir then + if Full_Lib_File /= No_File + and then not Check_Readonly_Files + then + Get_Name_String (Full_Lib_File); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + Read_Only := not Is_Writable_File + (Name_Buffer'Address, Lib_File_Attr'Access); + else + Read_Only := False; + end if; + end if; - if Bad_Compilation_Count > 0 and then not Keep_Going then - while Outstanding_Compiles > 0 loop - Await_Compile - (Full_Source_File, Lib_File, Source_Unit, Compilation_OK); + -- If the library file is an Ada library skip it - if not Compilation_OK then - Record_Failure (Full_Source_File, Source_Unit); - end if; - end loop; + if In_Lib_Dir then + Verbose_Msg + (Lib_File, + "is in an Ada library", + Prefix => " ", + Minimum_Verbosity => Opt.High); - exit Make_Loop; - end if; + -- If the library file is a read-only library skip it, but only + -- if, when using project files, this library file is in the + -- right object directory (a read-only ALI file in the object + -- directory of a project being extended must not be skipped). - -- PHASE 1: Check if there is more work that we can do (i.e. the Q - -- is non empty). If there is, do it only if we have not yet used - -- up all the available processes. + elsif Read_Only + and then Is_In_Object_Directory (Source_File, Full_Lib_File) + then + Verbose_Msg + (Lib_File, + "is a read-only library", + Prefix => " ", + Minimum_Verbosity => Opt.High); - if not Empty_Q and then Outstanding_Compiles < Max_Process then - declare - Source_Index : Int; - -- Index of the current unit in the current source file + -- The source file that we are checking cannot be located - begin - Extract_From_Q (Source_File, Source_Unit, Source_Index); - Full_Source_File := Osint.Full_Source_Name (Source_File); - Lib_File := Osint.Lib_File_Name - (Source_File, Source_Index); - Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); + elsif Full_Source_File = No_File then + Record_Failure (Source_File, Source_Unit, False); - -- If this source has already been compiled, the executable is - -- obsolete. + -- Source and library files can be located but are internal + -- files. - if Is_In_Obsoleted (Source_File) then - Executable_Obsolete := True; + elsif not Check_Readonly_Files + and then Full_Lib_File /= No_File + and then Is_Internal_File_Name (Source_File, False) + then + if Force_Compilations then + Fail + ("not allowed to compile """ & + Get_Name_String (Source_File) & + """; use -a switch, or compile file with " & + """-gnatg"" switch"); end if; - -- If the library file is an Ada library skip it - - if Full_Lib_File /= No_File - and then In_Ada_Lib_Dir (Full_Lib_File) - then - Verbose_Msg - (Lib_File, - "is in an Ada library", - Prefix => " ", - Minimum_Verbosity => Opt.High); - - -- If the library file is a read-only library skip it, but - -- only if, when using project files, this library file is - -- in the right object directory (a read-only ALI file - -- in the object directory of a project being extended - -- should not be skipped). - - elsif Full_Lib_File /= No_File - and then not Check_Readonly_Files - and then Is_Readonly_Library (Full_Lib_File) - and then Is_In_Object_Directory (Source_File, Full_Lib_File) - then - Verbose_Msg - (Lib_File, - "is a read-only library", - Prefix => " ", - Minimum_Verbosity => Opt.High); + Verbose_Msg + (Lib_File, + "is an internal library", + Prefix => " ", + Minimum_Verbosity => Opt.High); - -- The source file that we are checking cannot be located + -- The source file that we are checking can be located - elsif Full_Source_File = No_File then - Record_Failure (Source_File, Source_Unit, False); + else + Collect_Arguments (Source_File, Source_Index, + Source_File = Main_Source, Args); - -- Source and library files can be located but are internal - -- files + -- Do nothing if project of source is externally built - elsif not Check_Readonly_Files - and then Full_Lib_File /= No_File - and then Is_Internal_File_Name (Source_File, False) + if Arguments_Project = No_Project + or else not Arguments_Project.Externally_Built then - if Force_Compilations then - Fail - ("not allowed to compile """ & - Get_Name_String (Source_File) & - """; use -a switch, or compile file with " & - """-gnatg"" switch"); + -- Don't waste any time if we have to recompile anyway + + Obj_Stamp := Empty_Time_Stamp; + Need_To_Compile := Force_Compilations; + + if not Force_Compilations then + Check (Source_File => Source_File, + Source_Index => Source_Index, + Is_Main_Source => Source_File = Main_Source, + The_Args => Args, + Lib_File => Lib_File, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr'Access, + Read_Only => Read_Only, + ALI => ALI, + O_File => Obj_File, + O_Stamp => Obj_Stamp); + Need_To_Compile := (ALI = No_ALI_Id); end if; - Verbose_Msg - (Lib_File, - "is an internal library", - Prefix => " ", - Minimum_Verbosity => Opt.High); + if not Need_To_Compile then + -- The ALI file is up-to-date. Record its Id - -- The source file that we are checking can be located - - else - Collect_Arguments (Source_File, Source_Index, - Source_File = Main_Source, Args); + Record_Good_ALI (ALI); - -- Do nothing if project of source is externally built + -- Record the time stamp of the most recent object + -- file as long as no (re)compilations are needed. - if Arguments_Project = No_Project - or else not Arguments_Project.Externally_Built - then - -- Don't waste any time if we have to recompile anyway - - Obj_Stamp := Empty_Time_Stamp; - Need_To_Compile := Force_Compilations; - - if not Force_Compilations then - Read_Only := - Full_Lib_File /= No_File - and then not Check_Readonly_Files - and then Is_Readonly_Library (Full_Lib_File); - Check (Source_File, Source_Index, - Source_File = Main_Source, Args, Lib_File, - Read_Only, ALI, Obj_File, Obj_Stamp); - Need_To_Compile := (ALI = No_ALI_Id); + if First_Compiled_File = No_File + and then (Most_Recent_Obj_File = No_File + or else Obj_Stamp > Most_Recent_Obj_Stamp) + then + Most_Recent_Obj_File := Obj_File; + Most_Recent_Obj_Stamp := Obj_Stamp; end if; - if not Need_To_Compile then - -- The ALI file is up-to-date. Record its Id - - Record_Good_ALI (ALI); - - -- Record the time stamp of the most recent object - -- file as long as no (re)compilations are needed. - - if First_Compiled_File = No_File - and then (Most_Recent_Obj_File = No_File - or else Obj_Stamp > Most_Recent_Obj_Stamp) - then - Most_Recent_Obj_File := Obj_File; - Most_Recent_Obj_Stamp := Obj_Stamp; - end if; + else + -- Check that switch -x has been used if a source + -- outside of project files need to be compiled. - else - -- Check that switch -x has been used if a source - -- outside of project files need to be compiled. + if Main_Project /= No_Project + and then Arguments_Project = No_Project + and then not External_Unit_Compilation_Allowed + then + Make_Failed ("external source (" + & Get_Name_String (Source_File) + & ") is not part of any project;" + & " cannot be compiled without" + & " gnatmake switch -x"); + end if; - if Main_Project /= No_Project - and then Arguments_Project = No_Project - and then not External_Unit_Compilation_Allowed - then - Make_Failed ("external source (" - & Get_Name_String (Source_File) - & ") is not part of any project;" - & " cannot be compiled without" - & " gnatmake switch -x"); - end if; + -- Is this the first file we have to compile? - -- Is this the first file we have to compile? + if First_Compiled_File = No_File then + First_Compiled_File := Full_Source_File; + Most_Recent_Obj_File := No_File; - if First_Compiled_File = No_File then - First_Compiled_File := Full_Source_File; - Most_Recent_Obj_File := No_File; + if Do_Not_Execute then + -- Exit the main loop - if Do_Not_Execute then - exit Make_Loop; - end if; + return True; end if; + end if; - if In_Place_Mode then + -- Compute where the ALI file must be generated in + -- In_Place_Mode (this does not require to know the + -- location of the object directory) + if In_Place_Mode then + if Full_Lib_File = No_File then -- If the library file was not found, then save -- the library file near the source file. - if Full_Lib_File = No_File then - Lib_File := Osint.Lib_File_Name - (Full_Source_File, Source_Index); + Lib_File := Osint.Lib_File_Name + (Full_Source_File, Source_Index); + Full_Lib_File := Lib_File; - -- If the library file was found, then save the - -- library file in the same place. + else + -- If the library file was found, then save the + -- library file in the same place. + + Lib_File := Full_Lib_File; + end if; + end if; + -- Start the compilation and record it. We can do + -- this because there is at least one free process. + -- This might change the current directory + + Collect_Arguments_And_Compile + (Full_Source_File => Full_Source_File, + Lib_File => Lib_File, + Source_Index => Source_Index, + Pid => Pid, + Process_Created => Process_Created); + + -- Compute where the ALI file will be generated (for + -- cases that might require to know the current + -- directory). The current directory might be changed + -- when compiling other files so we cannot rely on it + -- being the same to find the resulting ALI file. + + if not In_Place_Mode then + -- Compute the expected location of the ALI file. This + -- can be from several places: + -- -i => in place mode. In such a case, + -- Full_Lib_File has already been set above + -- -D => if specified + -- or defaults in current dir + -- We could simply use a call similar to + -- Osint.Full_Lib_File_Name (Lib_File) + -- but that involves system calls and is thus slower + + if Object_Directory_Path /= null then + Name_Len := 0; + Add_Str_To_Name_Buffer (Object_Directory_Path.all); + Add_Str_To_Name_Buffer (Get_Name_String (Lib_File)); + Full_Lib_File := Name_Find; + else + if Project_Of_Current_Object_Directory /= + No_Project + then + Get_Name_String + (Project_Of_Current_Object_Directory + .Object_Directory.Name); + Add_Str_To_Name_Buffer + (Get_Name_String (Lib_File)); + Full_Lib_File := Name_Find; else - Lib_File := Full_Lib_File; + Full_Lib_File := Lib_File; end if; - end if; - -- Start the compilation and record it. We can do - -- this because there is at least one free process. + end if; - Collect_Arguments_And_Compile (Source_Index); + Lib_File_Attr := Unknown_Attributes; - -- Make sure we could successfully start - -- the Compilation. + -- Make sure we could successfully start + -- the Compilation. - if Process_Created then - if Pid = Invalid_Pid then - Record_Failure (Full_Source_File, Source_Unit); - else - Add_Process - (Pid, - Full_Source_File, - Lib_File, - Source_Unit, - Mfile); - end if; + if Process_Created then + if Pid = Invalid_Pid then + Record_Failure (Full_Source_File, Source_Unit); + else + Add_Process + (Pid => Pid, + Sfile => Full_Source_File, + Afile => Lib_File, + Uname => Source_Unit, + Mfile => Mfile, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr); end if; end if; end if; end if; - end; + end if; end if; + return False; + end Start_Compile_If_Possible; + + ----------------------------- + -- Wait_For_Available_Slot -- + ----------------------------- - -- PHASE 2: Now check if we should wait for a compilation to - -- finish. This is the case if all the available processes are - -- busy compiling sources or there is nothing else to do - -- (that is the Q is empty and there are no good ALIs to process). + procedure Wait_For_Available_Slot is + Compilation_OK : Boolean; + Text : Text_Buffer_Ptr; + ALI : ALI_Id; + Data : Compilation_Data; + begin if Outstanding_Compiles = Max_Process or else (Empty_Q - and then not Good_ALI_Present - and then Outstanding_Compiles > 0) + and then not Good_ALI_Present + and then Outstanding_Compiles > 0) then - Await_Compile - (Full_Source_File, Lib_File, Source_Unit, Compilation_OK); + Await_Compile (Data, Compilation_OK); if not Compilation_OK then - Record_Failure (Full_Source_File, Source_Unit); + Record_Failure (Data.Full_Source_File, Data.Source_Unit); end if; if Compilation_OK or else Keep_Going then @@ -3354,15 +3530,17 @@ package body Make is Check_Object_Consistency; begin - -- If compilation was not OK, or if output is not an - -- object file and we don't do the bind step, don't check - -- for object consistency. + -- If compilation was not OK, or if output is not an object + -- file and we don't do the bind step, don't check for + -- object consistency. Check_Object_Consistency := Check_Object_Consistency and Compilation_OK and (Output_Is_Object or Do_Bind_Step); - Text := Read_Library_Info (Lib_File); + + Text := Read_Library_Info_From_Full + (Data.Full_Lib_File, Data.Lib_File_Attr'Access); -- Restore Check_Object_Consistency to its initial value @@ -3376,8 +3554,8 @@ package body Make is -- the unit just compiled. if Text /= null then - ALI := - Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); + ALI := Scan_ALI + (Data.Lib_File, Text, Ignore_ED => False, Err => True); if ALI = No_ALI_Id then @@ -3385,15 +3563,18 @@ package body Make is if Compilation_OK then Inform - (Lib_File, + (Data.Lib_File, "incompatible ALI file, please recompile"); - Record_Failure (Full_Source_File, Source_Unit); + Record_Failure + (Data.Full_Source_File, Data.Source_Unit); end if; + else - Free (Text); Record_Good_ALI (ALI); end if; + Free (Text); + -- If we could not read the ALI file that was just generated -- then there could be a problem reading either the ALI or the -- corresponding object file (if Check_Object_Consistency is @@ -3404,137 +3585,72 @@ package body Make is else if Compilation_OK and not Syntax_Only then Inform - (Lib_File, + (Data.Lib_File, "WARNING: ALI or object file not found after compile"); - Record_Failure (Full_Source_File, Source_Unit); + Record_Failure (Data.Full_Source_File, Data.Source_Unit); end if; end if; end if; end if; + end Wait_For_Available_Slot; - -- PHASE 3: Check if we recorded good ALI files. If yes process - -- them now in the order in which they have been recorded. There - -- are two occasions in which we record good ali files. The first is - -- in phase 1 when, after scanning an existing ALI file we realize - -- it is up-to-date, the second instance is after a successful - -- compilation. - - while Good_ALI_Present loop - ALI := Get_Next_Good_ALI; - - declare - Source_Index : Int := Unit_Index_Of (ALIs.Table (ALI).Afile); - - begin - -- If we are processing the library file corresponding to the - -- main source file check if this source can be a main unit. + -- Start of processing for Compile_Sources - if ALIs.Table (ALI).Sfile = Main_Source and then - Source_Index = Main_Index - then - Main_Unit := ALIs.Table (ALI).Main_Program /= None; - end if; + begin + pragma Assert (Args'First = 1); - -- The following adds the standard library (s-stalib) to the - -- list of files to be handled by gnatmake: this file and any - -- files it depends on are always included in every bind, - -- even if they are not in the explicit dependency list. - -- Of course, it is not added if Suppress_Standard_Library - -- is True. + Outstanding_Compiles := 0; + Running_Compile := new Comp_Data_Arr (1 .. Max_Process); - -- However, to avoid annoying output about s-stalib.ali being - -- read only, when "-v" is used, we add the standard library - -- only when "-a" is used. + -- Package and Queue initializations - if Need_To_Check_Standard_Library then - Check_Standard_Library; - end if; + Good_ALI.Init; - -- Now insert in the Q the unmarked source files (i.e. those - -- which have never been inserted in the Q and hence never - -- considered). Only do that if Unique_Compile is False. + if First_Q_Initialization then + Init_Q; + end if; - if not Unique_Compile then - for J in - ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit - loop - for K in - Units.Table (J).First_With .. Units.Table (J).Last_With - loop - Sfile := Withs.Table (K).Sfile; - Uname := Withs.Table (K).Uname; + if Initialize_ALI_Data then + Initialize_ALI; + Initialize_ALI_Source; + end if; - -- If project files are used, find the proper source - -- to compile, in case Sfile is the spec, but there - -- is a body. + -- The following two flags affect the behavior of ALI.Set_Source_Table. + -- We set Check_Source_Files to True to ensure that source file + -- time stamps are checked, and we set All_Sources to False to + -- avoid checking the presence of the source files listed in the + -- source dependency section of an ali file (which would be a mistake + -- since the ali file may be obsolete). - if Main_Project /= No_Project then - declare - Unit_Name : Name_Id; - Uid : Prj.Unit_Index; + Check_Source_Files := True; + All_Sources := False; - begin - Get_Name_String (Uname); - 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 - if Uid.File_Names (Impl) /= null - and then - not Uid.File_Names (Impl).Locally_Removed - then - Sfile := Uid.File_Names (Impl).File; - Source_Index := - Uid.File_Names (Impl).Index; - - elsif Uid.File_Names (Spec) /= null - and then - not Uid.File_Names (Spec).Locally_Removed - then - Sfile := Uid.File_Names (Spec).File; - Source_Index := - Uid.File_Names (Spec).Index; - end if; - end if; - end; - end if; + -- Only insert in the Q if it is not already done, to avoid simultaneous + -- compilations if -jnnn is used. - Dependencies.Append ((ALIs.Table (ALI).Sfile, Sfile)); + if not Is_Marked (Main_Source, Main_Index) then + Insert_Q (Main_Source, Index => Main_Index); + Mark (Main_Source, Main_Index); + end if; - if Is_In_Obsoleted (Sfile) then - Executable_Obsolete := True; - end if; + First_Compiled_File := No_File; + Most_Recent_Obj_File := No_File; + Most_Recent_Obj_Stamp := Empty_Time_Stamp; + Main_Unit := False; - if Sfile = No_File then - Debug_Msg - ("Skipping generic:", Withs.Table (K).Uname); + -- Keep looping until there is no more work to do (the Q is empty) + -- and all the outstanding compilations have terminated. - else - Source_Index := - Unit_Index_Of (Withs.Table (K).Afile); + Make_Loop : while not Empty_Q or else Outstanding_Compiles > 0 loop + exit Make_Loop when Must_Exit_Because_Of_Error; + exit Make_Loop when Start_Compile_If_Possible (Args); - if Is_Marked (Sfile, Source_Index) then - Debug_Msg ("Skipping marked file:", Sfile); + Wait_For_Available_Slot; - elsif not Check_Readonly_Files - and then Is_Internal_File_Name (Sfile, False) - then - Debug_Msg ("Skipping internal file:", Sfile); + -- ??? Should be done as soon as we add a Good_ALI, wouldn't it avoid + -- the need for a list of good ALI? - else - Insert_Q - (Sfile, Withs.Table (K).Uname, Source_Index); - Mark (Sfile, Source_Index); - end if; - end if; - end loop; - end loop; - end if; - end; - end loop; + Fill_Queue_From_ALI_Files; if Display_Compilation_Progress then Write_Str ("completed "); @@ -3791,7 +3907,7 @@ package body Make is -- recreate another config file: we cannot reuse the one that -- we just deleted! - Proj.Project.Config_Checked := False; + Proj.Project.Config_Checked := False; Proj.Project.Config_File_Name := No_Path; Proj.Project.Config_File_Temp := False; end if; @@ -3842,8 +3958,8 @@ package body Make is then Temporary_Config_File := False; - -- Do not display the -F=mapping_file switch for - -- gnatbind, if -dn is not specified. + -- Do not display the -F=mapping_file switch for gnatbind + -- if -dn is not specified. elsif Debug.Debug_Flag_N or else Args (J)'Length < 4 @@ -4003,8 +4119,7 @@ package body Make is Total_Compilation_Failures : Natural := 0; Is_Main_Unit : Boolean; - -- Set to True by Compile_Sources if the Main_Source_File can be a - -- main unit. + -- Set True by Compile_Sources if Main_Source_File can be a main unit Main_ALI_File : File_Name_Type; -- The ali file corresponding to Main_Source_File @@ -4013,8 +4128,8 @@ package body Make is -- The file name of an executable Non_Std_Executable : Boolean := False; - -- Non_Std_Executable is set to True when there is a possibility - -- that the linker will not choose the correct executable file name. + -- Non_Std_Executable is set to True when there is a possibility that + -- the linker will not choose the correct executable file name. Current_Work_Dir : constant String_Access := new String'(Get_Current_Dir); @@ -4065,8 +4180,8 @@ package body Make is loop declare Main : constant String := Mains.Next_Main; - -- The name specified on the command line may include - -- directory information. + -- The name specified on the command line may include directory + -- information. File_Name : constant String := Base_Name (Main); -- The simple file name of the current main @@ -4081,17 +4196,16 @@ package body Make is Proj := Prj.Env.Project_Of (File_Name, Main_Project, Project_Tree); - -- Fail if the current main is not a source of a - -- project. + -- Fail if the current main is not a source of a project if Proj = No_Project then Make_Failed ("""" & Main & """ is not a source of any project"); else - -- If there is directory information, check that - -- the source exists and, if it does, that the path - -- is the actual path of a source of a project. + -- If there is directory information, check that the source + -- exists and, if it does, that the path is the actual path + -- of a source of a project. if Main /= File_Name then Lang := Get_Language_From_Name (Main_Project, "ada"); @@ -4165,8 +4279,8 @@ package body Make is elsif Proj /= Real_Main_Project then - -- Fail, as the current main is not a source - -- of the same project as the first main. + -- Fail, as the current main is not a source of the + -- same project as the first main. Make_Failed ("""" & Main & @@ -4176,9 +4290,9 @@ package body Make is end if; end if; - -- If -u and -U are not used, we may have mains that - -- are sources of a project that is not the one - -- specified with switch -P. + -- If -u and -U are not used, we may have mains that are + -- sources of a project that is not the one specified with + -- switch -P. if not Unique_Compile then Main_Project := Real_Main_Project; @@ -4240,8 +4354,7 @@ package body Make is (Unit.File_Names (Impl).Display_File); ALI_Project := Unit.File_Names (Impl).Project; - -- Otherwise, if there is a spec, put it in the - -- mapping. + -- Otherwise, if there is a spec, put it in the mapping elsif Unit.File_Names (Spec) /= No_Source and then Unit.File_Names (Spec).Project /= @@ -4262,8 +4375,9 @@ package body Make is -- If we have something to put in the mapping then do it -- now. However, if the project is extended, we don't put -- anything in the mapping file, because we don't know where - -- the ALI file is: it might be in the extended project obj - -- dir as well as in the extending project obj dir. + -- the ALI file is: it might be in the extended project + -- object directory as well as in the extending project + -- object directory. if ALI_Name /= No_File and then ALI_Project.Extended_By = No_Project @@ -4356,8 +4470,8 @@ package body Make is OK := OK and Status; - -- If the creation of the mapping file was successful, - -- we add the switch to the arguments of gnatbind. + -- If the creation of the mapping file was successful, we add the + -- switch to the arguments of gnatbind. if OK then Last_Arg := Last_Arg + 1; @@ -4369,7 +4483,7 @@ package body Make is -- Start of processing for Gnatmake - -- This body is very long, should be broken down ??? + -- This body is very long, should be broken down??? begin Install_Int_Handler (Sigint_Intercepted'Access); @@ -4422,10 +4536,10 @@ package body Make is end if; -- Specify -n for gnatbind and add the ALI files of all the - -- sources, except the one which is a fake main subprogram: - -- this is the one for the binder generated file and it will be - -- transmitted to gnatlink. These sources are those that are - -- in the queue. + -- sources, except the one which is a fake main subprogram: this + -- is the one for the binder generated file and it will be + -- transmitted to gnatlink. These sources are those that are in + -- the queue. Add_Switch ("-n", Binder, And_Save => True); @@ -4442,8 +4556,8 @@ package body Make is elsif Main_Project /= No_Project then - -- If the main project file is a library project file, main(s) - -- cannot be specified on the command line. + -- If the main project file is a library project file, main(s) cannot + -- be specified on the command line. if Osint.Number_Of_Files /= 0 then if Main_Project.Library @@ -4461,10 +4575,10 @@ package body Make is Check_Mains; end if; - -- If no mains have been specified on the command line, - -- and we are using a project file, we either find the main(s) - -- in the attribute Main of the main project, or we put all - -- the sources of the project file as mains. + -- If no mains have been specified on the command line, and we are + -- using a project file, we either find the main(s) in attribute + -- Main of the main project, or we put all the sources of the project + -- file as mains. else if Main_Index /= 0 then @@ -4476,16 +4590,16 @@ package body Make is Value : String_List_Id := Main_Project.Mains; begin - -- The attribute Main is an empty list or not specified, - -- or else gnatmake was invoked with the switch "-u". + -- The attribute Main is an empty list or not specified, or + -- else gnatmake was invoked with the switch "-u". if Value = Prj.Nil_String or else Unique_Compile then if (not Make_Steps) or else Compile_Only or else not Main_Project.Library then - -- First make sure that the binder and the linker - -- will not be invoked. + -- First make sure that the binder and the linker will + -- not be invoked. Do_Bind_Step := False; Do_Link_Step := False; @@ -4513,8 +4627,8 @@ package body Make is else -- The attribute Main is not an empty list. - -- Put all the main subprograms in the list as if there - -- were specified on the command line. However, if attribute + -- Put all the main subprograms in the list as if they were + -- specified on the command line. However, if attribute -- Languages includes a language other than Ada, only -- include the Ada mains; if there is no Ada main, compile -- all the sources of the project. @@ -4778,8 +4892,8 @@ package body Make is & """ is not a unit of project " & Project_File_Name.all & "."); else - -- Remove any directory information from the main - -- source file name. + -- Remove any directory information from the main source file + -- file name. declare Pos : Natural := Main_Unit_File_Name'Last; @@ -5051,8 +5165,8 @@ package body Make is end if; -- Get the target parameters, which are only needed for a couple of - -- cases in gnatmake. Protect against an exception, such as the case - -- of system.ads missing from the library, and fail gracefully. + -- cases in gnatmake. Protect against an exception, such as the case of + -- system.ads missing from the library, and fail gracefully. begin Targparm.Get_Target_Parameters; @@ -5145,8 +5259,8 @@ package body Make is end; end if; - -- If a relative path output file has been specified, we add - -- the exec directory. + -- If a relative path output file has been specified, we add the + -- exec directory. for J in reverse 1 .. Saved_Linker_Switches.Last - 1 loop if Saved_Linker_Switches.Table (J).all = Output_Flag.all then @@ -5267,9 +5381,9 @@ package body Make is The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) := No_gnat_adc; end if; - -- If there was a --GCC, --GNATBIND or --GNATLINK switch on - -- the command line, then we have to use it, even if there was - -- another switch in the project file. + -- If there was a --GCC, --GNATBIND or --GNATLINK switch on the command + -- line, then we have to use it, even if there was another switch in + -- the project file. if Saved_Gcc /= null then Gcc := Saved_Gcc; @@ -6586,8 +6700,8 @@ package body Make is Mains.Delete; - -- Add the directory where gnatmake is invoked in front of the - -- path, if gnatmake is invoked from a bin directory or with directory + -- Add the directory where gnatmake is invoked in front of the path, + -- if gnatmake is invoked from a bin directory or with directory -- information. Only do this if the platform is not VMS, where the -- notion of path does not really exist. @@ -6755,8 +6869,8 @@ package body Make is Write_Eol; end if; - -- We add the source directories and the object directories - -- to the search paths. + -- We add the source directories and the object directories to the + -- search paths. Add_Source_Directories (Main_Project, Project_Tree); Add_Object_Directories (Main_Project); @@ -6917,9 +7031,8 @@ package body Make is and then not Unit.File_Names (Spec).Locally_Removed and then Check_Project (Unit.File_Names (Spec).Project) then - -- If there is no source for the body, but there is a source - -- for the spec which has not been locally removed, then we take - -- this one. + -- If there is no source for the body, but there is one for the + -- spec which has not been locally removed, then we take this one. Sfile := Unit.File_Names (Spec).Display_File; Index := Unit.File_Names (Spec).Index; @@ -7263,9 +7376,9 @@ package body Make is B : Byte; function Base_Directory return String; - -- If Dir comes from the command line, empty string (relative paths - -- are resolved with respect to the current directory), else return - -- the main project's directory. + -- If Dir comes from the command line, empty string (relative paths are + -- resolved with respect to the current directory), else return the main + -- project's directory. -------------------- -- Base_Directory -- @@ -7372,7 +7485,7 @@ package body Make is Multilib_Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Multilib_Gcc.all); - Create_Temp_File (Output_FD, Output_Name); + Create_Temp_Output_File (Output_FD, Output_Name); if Output_FD = Invalid_FD then return; @@ -7566,7 +7679,7 @@ package body Make is -- If the previous switch has set the Object_Directory_Present flag -- (that is we have seen a -D), then the next argument is the path name - -- of the object directory.. + -- of the object directory. elsif Object_Directory_Present and then not Object_Directory_Seen @@ -7580,21 +7693,26 @@ package body Make is Make_Failed ("cannot find object directory """ & Argv & """"); else - Add_Lib_Search_Dir (Argv); + -- Record the object directory. Make sure it ends with a directory + -- separator. - -- Specify the object directory to the binder + declare + Norm : constant String := Normalize_Pathname (Argv); + begin + if Norm (Norm'Last) = Directory_Separator then + Object_Directory_Path := new String'(Norm); + else + Object_Directory_Path := + new String'(Norm & Directory_Separator); + end if; - Add_Switch ("-aO" & Argv, Binder, And_Save => And_Save); + Add_Lib_Search_Dir (Norm); - -- Record the object directory. Make sure it ends with a directory - -- separator. + -- Specify the object directory to the binder + + Add_Switch ("-aO" & Norm, Binder, And_Save => And_Save); + end; - if Argv (Argv'Last) = Directory_Separator then - Object_Directory_Path := new String'(Argv); - else - Object_Directory_Path := - new String'(Argv & Directory_Separator); - end if; end if; -- Then check if we are dealing with -cargs/-bargs/-largs/-margs @@ -7617,9 +7735,8 @@ package body Make is raise Program_Error; end case; - -- A special test is needed for the -o switch within a -largs - -- since that is another way to specify the name of the final - -- executable. + -- A special test is needed for the -o switch within a -largs since that + -- is another way to specify the name of the final executable. elsif Program_Args = Linker and then Argv = "-o" @@ -7627,8 +7744,8 @@ package body Make is Make_Failed ("switch -o not allowed within a -largs. " & "Use -o directly."); - -- Check to see if we are reading switches after a -cargs, - -- -bargs or -largs switch. If yes save it. + -- Check to see if we are reading switches after a -cargs, -bargs or + -- -largs switch. If so, save it. elsif Program_Args /= None then @@ -7671,9 +7788,7 @@ package body Make is for J in 2 .. Program_Args.all'Last loop Add_Switch - (Program_Args.all (J).all, - Compiler, - And_Save => And_Save); + (Program_Args.all (J).all, Compiler, And_Save => And_Save); end loop; end; @@ -7721,7 +7836,7 @@ package body Make is Argv (1 .. 5) = "--RTS" then Add_Switch (Argv, Compiler, And_Save => And_Save); - Add_Switch (Argv, Binder, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); if Argv'Length <= 6 or else Argv (6) /= '=' then Make_Failed ("missing path for --RTS"); @@ -7784,7 +7899,7 @@ package body Make is Argv (1 .. 8) = "--param=" then Add_Switch (Argv, Compiler, And_Save => And_Save); - Add_Switch (Argv, Linker, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); else Scan_Make_Switches (Project_Node_Tree, Argv, Success); @@ -7822,18 +7937,17 @@ package body Make is -- -Idir elsif Argv (2) = 'I' then - Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); Add_Library_Search_Dir (Argv (3 .. Argv'Last), And_Save); Add_Switch (Argv, Compiler, And_Save => And_Save); - Add_Switch (Argv, Binder, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); -- -aIdir (to gcc this is like a -I switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then Add_Source_Search_Dir (Argv (4 .. Argv'Last), And_Save); - Add_Switch ("-I" & Argv (4 .. Argv'Last), - Compiler, - And_Save => And_Save); + Add_Switch + ("-I" & Argv (4 .. Argv'Last), Compiler, And_Save => And_Save); Add_Switch (Argv, Binder, And_Save => And_Save); -- -aOdir @@ -7847,9 +7961,8 @@ package body Make is elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then Mark_Directory (Argv (4 .. Argv'Last), Ada_Lib_Dir, And_Save); Add_Library_Search_Dir (Argv (4 .. Argv'Last), And_Save); - Add_Switch ("-aO" & Argv (4 .. Argv'Last), - Binder, - And_Save => And_Save); + Add_Switch + ("-aO" & Argv (4 .. Argv'Last), Binder, And_Save => And_Save); -- -aamp_target=... @@ -7867,14 +7980,12 @@ package body Make is elsif Argv (2) = 'A' then Mark_Directory (Argv (3 .. Argv'Last), Ada_Lib_Dir, And_Save); - Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); Add_Library_Search_Dir (Argv (3 .. Argv'Last), And_Save); - Add_Switch ("-I" & Argv (3 .. Argv'Last), - Compiler, - And_Save => And_Save); - Add_Switch ("-aO" & Argv (3 .. Argv'Last), - Binder, - And_Save => And_Save); + Add_Switch + ("-I" & Argv (3 .. Argv'Last), Compiler, And_Save => And_Save); + Add_Switch + ("-aO" & Argv (3 .. Argv'Last), Binder, And_Save => And_Save); -- -Ldir @@ -7882,11 +7993,11 @@ package body Make is Add_Switch (Argv, Linker, And_Save => And_Save); -- For -gxxxxx, -pg, -mxxx, -fxxx: give the switch to both the - -- compiler and the linker (except for -gnatxxx which is only for - -- the compiler). Some of the -mxxx (for example -m64) and -fxxx - -- (for example -ftest-coverage for gcov) need to be used when - -- compiling the binder generated files, and using all these gcc - -- switches for the binder generated files should not be a problem. + -- compiler and the linker (except for -gnatxxx which is only for the + -- compiler). Some of the -mxxx (for example -m64) and -fxxx (for + -- example -ftest-coverage for gcov) need to be used when compiling + -- the binder generated files, and using all these gcc switches for + -- the binder generated files should not be a problem. elsif (Argv (2) = 'g' and then (Argv'Last < 5 @@ -7896,7 +8007,7 @@ package body Make is or else (Argv (2) = 'f' and then Argv'Last > 2) then Add_Switch (Argv, Compiler, And_Save => And_Save); - Add_Switch (Argv, Linker, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); -- The following condition has to be kept synchronized with -- the Process_Multilib one. @@ -7922,8 +8033,8 @@ package body Make is elsif Argv'Last = 2 and then Argv (2) = 'D' then if Project_File_Name /= null then - Make_Failed ("-D cannot be used in conjunction with a " & - "project file"); + Make_Failed + ("-D cannot be used in conjunction with a project file"); else Scan_Make_Switches (Project_Node_Tree, Argv, Success); @@ -7931,17 +8042,15 @@ package body Make is -- -d - elsif Argv (2) = 'd' - and then Argv'Last = 2 - then + elsif Argv (2) = 'd' and then Argv'Last = 2 then Display_Compilation_Progress := True; -- -i elsif Argv'Last = 2 and then Argv (2) = 'i' then if Project_File_Name /= null then - Make_Failed ("-i cannot be used in conjunction with a " & - "project file"); + Make_Failed + ("-i cannot be used in conjunction with a project file"); else Scan_Make_Switches (Project_Node_Tree, Argv, Success); end if; @@ -7957,20 +8066,16 @@ package body Make is -- -m - elsif Argv (2) = 'm' - and then Argv'Last = 2 - then + elsif Argv (2) = 'm' and then Argv'Last = 2 then Minimal_Recompilation := True; -- -u - elsif Argv (2) = 'u' - and then Argv'Last = 2 - then - Unique_Compile := True; - Compile_Only := True; - Do_Bind_Step := False; - Do_Link_Step := False; + elsif Argv (2) = 'u' and then Argv'Last = 2 then + Unique_Compile := True; + Compile_Only := True; + Do_Bind_Step := False; + Do_Link_Step := False; -- -U @@ -7978,10 +8083,10 @@ package body Make is and then Argv'Last = 2 then Unique_Compile_All_Projects := True; - Unique_Compile := True; - Compile_Only := True; - Do_Bind_Step := False; - Do_Link_Step := False; + Unique_Compile := True; + Compile_Only := True; + Do_Bind_Step := False; + Do_Link_Step := False; -- -Pprj or -P prj (only once, and only on the command line) @@ -7990,16 +8095,16 @@ package body Make is Make_Failed ("cannot have several project files specified"); elsif Object_Directory_Path /= null then - Make_Failed ("-D cannot be used in conjunction with a " & - "project file"); + Make_Failed + ("-D cannot be used in conjunction with a project file"); elsif In_Place_Mode then - Make_Failed ("-i cannot be used in conjunction with a " & - "project file"); + Make_Failed + ("-i cannot be used in conjunction with a project file"); elsif not And_Save then - -- It could be a tool other than gnatmake (i.e, gnatdist) + -- It could be a tool other than gnatmake (e.g. gnatdist) -- or a -P switch inside a project file. Fail @@ -8040,31 +8145,30 @@ package body Make is elsif Argv (2) = 'X' and then Is_External_Assignment (Project_Node_Tree, Argv) then - -- Is_External_Assignment has side effects - -- when it returns True; + -- Is_External_Assignment has side effects when it returns True null; - -- If -gnath is present, then generate the usage information - -- right now and do not pass this option on to the compiler calls. + -- If -gnath is present, then generate the usage information right + -- now and do not pass this option on to the compiler calls. elsif Argv = "-gnath" then Usage; - -- If -gnatc is specified, make sure the bind step and the link - -- step are not executed. + -- If -gnatc is specified, make sure the bind and link steps are not + -- executed. elsif Argv'Length >= 6 and then Argv (2 .. 6) = "gnatc" then - -- If -gnatc is specified, make sure the bind step and the link - -- step are not executed. + -- If -gnatc is specified, make sure the bind and link steps are + -- not executed. Add_Switch (Argv, Compiler, And_Save => And_Save); - Operating_Mode := Check_Semantics; + Operating_Mode := Check_Semantics; Check_Object_Consistency := False; Compile_Only := True; - Do_Bind_Step := False; - Do_Link_Step := False; + Do_Bind_Step := False; + Do_Link_Step := False; elsif Argv (2 .. Argv'Last) = "nostdlib" then @@ -8082,7 +8186,7 @@ package body Make is No_Stdinc := True; Add_Switch (Argv, Compiler, And_Save => And_Save); - Add_Switch (Argv, Binder, 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 Gnatmake_Switch_Found = False, then the switch diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index a570737d711..307ec6ffccc 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -25,6 +25,7 @@ with ALI; use ALI; with Debug; +with Fname; with Osint; use Osint; with Output; use Output; with Opt; use Opt; @@ -213,31 +214,35 @@ package body Makeutl is if Unit_Name /= No_Name then -- For separates, the file is no longer associated with the - -- unit ("proc-sep.adb" is not associated with unit "proc.sep". - -- So we need to check whether the source file still exists in + -- unit ("proc-sep.adb" is not associated with unit "proc.sep") + -- so we need to check whether the source file still exists in -- the source tree: it will if it matches the naming scheme -- (and then will be for the same unit). if Find_Source - (In_Tree => Project_Tree, - Project => No_Project, - Base_Name => SD.Sfile) = No_Source + (In_Tree => Project_Tree, + Project => No_Project, + Base_Name => SD.Sfile) = No_Source then - -- If this is not a runtime file (when using -a) ? Otherwise - -- we get complaints about a-except.adb, which uses - -- separates. - - if not Check_Readonly_Files - or else Find_File (SD.Sfile, Osint.Source) = No_File + -- If this is not a runtime file or if, when gnatmake switch + -- -a is used, we are not able to find this subunit in the + -- source directories, then recompilation is needed. + + if not Fname.Is_Internal_File_Name (SD.Sfile) + or else + (Check_Readonly_Files + and then Find_File (SD.Sfile, Osint.Source) = No_File) then if Verbose_Mode then Write_Line - ("While parsing ALI file: Sdep associates " + ("While parsing ALI file, file " & Get_Name_String (SD.Sfile) - & " with unit " & Get_Name_String (Unit_Name) + & " is indicated as containing subunit " + & Get_Name_String (Unit_Name) & " but this does not match what was found while" & " parsing the project. Will recompile"); end if; + return False; end if; end if; @@ -323,7 +328,9 @@ package body Makeutl is return ""; end if; - return Normalize_Pathname (Exec (Exec'First .. Path_Last - 4)) + return Normalize_Pathname + (Exec (Exec'First .. Path_Last - 4), + Resolve_Links => Opt.Follow_Links_For_Dirs) & Directory_Separator; end Get_Install_Dir; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index d184da9aa54..542b1f02551 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -663,7 +663,7 @@ package Opt is -- still valid if they point to a file which is outside of the project), -- and that no directory has a name which is a valid source name. - Follow_Links_For_Dirs : Boolean := True; + Follow_Links_For_Dirs : Boolean := False; -- PROJECT MANAGER -- Set to True if directories can be links in this project, and therefore -- additional system calls must be performed to ensure that we always see @@ -1361,6 +1361,11 @@ package Opt is -- Set to True to generate warnings on use of any feature in Annex or if a -- subprogram is called for which a pragma Obsolescent applies. + Warn_On_Overlap : Boolean := False; + -- GNAT + -- Set to True to generate warnings when a writable actual which is not + -- a by-copy type overlaps with another actual in a subprogram call. + Warn_On_Questionable_Missing_Parens : Boolean := True; -- GNAT -- Set to True to generate warnings for cases where parentheses are missing diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index a02e1eefe7e..1b1f5085984 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -80,7 +80,8 @@ package body Osint is -- Appends Suffix to Name and returns the new name function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; - -- Convert OS format time to GNAT format time stamp + -- Convert OS format time to GNAT format time stamp. + -- Returns Empty_Time_Stamp if T is Invalid_Time function Executable_Prefix return String_Ptr; -- Returns the name of the root directory where the executable is stored. @@ -93,16 +94,39 @@ package body Osint is -- Update the specified path to replace the prefix with the location -- where GNAT is installed. See the file prefix.c in GCC for details. - function Locate_File - (N : File_Name_Type; - T : File_Type; - Dir : Natural; - Name : String) return File_Name_Type; + procedure Locate_File + (N : File_Name_Type; + T : File_Type; + Dir : Natural; + Name : String; + Found : out File_Name_Type; + Attr : access File_Attributes); -- See if the file N whose name is Name exists in directory Dir. Dir is an -- index into the Lib_Search_Directories table if T = Library. Otherwise -- if T = Source, Dir is an index into the Src_Search_Directories table. -- Returns the File_Name_Type of the full file name if file found, or -- No_File if not found. + -- On exit, Found is set to the file that was found, and Attr to a cache of + -- its attributes (at least those that have been computed so far). Reusing + -- the cache will save some system calls. + -- Attr is always reset in this call to Unknown_Attributes, even in case of + -- failure + + procedure Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : access File_Attributes); + -- A version of Find_File that also returns a cache of the file attributes + -- for later reuse + + procedure Smart_Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : out File_Attributes); + -- A version of Smart_Find_File that also returns a cache of the file + -- attributes for later reuse function C_String_Length (S : Address) return Integer; -- Returns length of a C string (zero for a null address) @@ -211,18 +235,17 @@ package body Osint is function File_Hash (F : File_Name_Type) return File_Hash_Num; -- Compute hash index for use by Simple_HTable - package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( - Header_Num => File_Hash_Num, - Element => File_Name_Type, - No_Element => No_File, - Key => File_Name_Type, - Hash => File_Hash, - Equal => "="); + type File_Info_Cache is record + File : File_Name_Type; + Attr : aliased File_Attributes; + end record; + No_File_Info_Cache : constant File_Info_Cache := + (No_File, Unknown_Attributes); - package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable ( + package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( Header_Num => File_Hash_Num, - Element => Time_Stamp_Type, - No_Element => Empty_Time_Stamp, + Element => File_Info_Cache, + No_Element => No_File_Info_Cache, Key => File_Name_Type, Hash => File_Hash, Equal => "="); @@ -559,9 +582,25 @@ package body Osint is Fail ("missing library directory name"); end if; - Lib_Search_Directories.Increment_Last; - Lib_Search_Directories.Table (Lib_Search_Directories.Last) := - Normalize_Directory_Name (Dir); + declare + Norm : String_Ptr := Normalize_Directory_Name (Dir); + begin + + -- Do nothing if the directory is already in the list. This saves + -- system calls and avoid unneeded work + + for D in Lib_Search_Directories.First .. + Lib_Search_Directories.Last + loop + if Lib_Search_Directories.Table (D).all = Norm.all then + Free (Norm); + return; + end if; + end loop; + + Lib_Search_Directories.Increment_Last; + Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm; + end; end Add_Lib_Search_Dir; --------------------- @@ -958,6 +997,33 @@ package body Osint is return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); end File_Hash; + ----------------- + -- File_Length -- + ----------------- + + function File_Length + (Name : C_File_Name; Attr : access File_Attributes) return Long_Integer + is + function Internal + (F : Integer; N : C_File_Name; A : System.Address) return Long_Integer; + pragma Import (C, Internal, "__gnat_file_length_attr"); + begin + return Internal (-1, Name, Attr.all'Address); + end File_Length; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + function File_Time_Stamp + (Name : C_File_Name; Attr : access File_Attributes) return OS_Time + is + function Internal (N : C_File_Name; A : System.Address) return OS_Time; + pragma Import (C, Internal, "__gnat_file_time_name_attr"); + begin + return Internal (Name, Attr.all'Address); + end File_Time_Stamp; + ---------------- -- File_Stamp -- ---------------- @@ -970,12 +1036,13 @@ package body Osint is Get_Name_String (Name); - if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then - return Empty_Time_Stamp; - else - Name_Buffer (Name_Len + 1) := ASCII.NUL; - return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer)); - end if; + -- File_Time_Stamp will always return Invalid_Time if the file does not + -- exist, and OS_Time_To_GNAT_Time will convert this value to + -- Empty_Time_Stamp. Therefore we do not need to first test whether the + -- file actually exists, which saves a system call. + + return OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); end File_Stamp; function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is @@ -991,6 +1058,22 @@ package body Osint is (N : File_Name_Type; T : File_Type) return File_Name_Type is + Attr : aliased File_Attributes; + Found : File_Name_Type; + begin + Find_File (N, T, Found, Attr'Access); + return Found; + end Find_File; + + --------------- + -- Find_File -- + --------------- + + procedure Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : access File_Attributes) is begin Get_Name_String (N); @@ -1014,7 +1097,9 @@ package body Osint is (Hostparm.OpenVMS and then Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg"))) then - return N; + Found := N; + Attr.all := Unknown_Attributes; + return; -- If we are trying to find the current main file just look in the -- directory where the user said it was. @@ -1022,7 +1107,8 @@ package body Osint is elsif Look_In_Primary_Directory_For_Current_Main and then Current_Main = N then - return Locate_File (N, T, Primary_Directory, File_Name); + Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); + return; -- Otherwise do standard search for source file @@ -1040,21 +1126,23 @@ package body Osint is -- return No_File, indicating the file is not a source. if File = Error_File_Name then - return No_File; - + Found := No_File; else - return File; + Found := File; end if; + + Attr.all := Unknown_Attributes; + return; end if; -- First place to look is in the primary directory (i.e. the same -- directory as the source) unless this has been disabled with -I- if Opt.Look_In_Primary_Dir then - File := Locate_File (N, T, Primary_Directory, File_Name); + Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); - if File /= No_File then - return File; + if Found /= No_File then + return; end if; end if; @@ -1067,14 +1155,15 @@ package body Osint is end if; for D in Primary_Directory + 1 .. Last_Dir loop - File := Locate_File (N, T, D, File_Name); + Locate_File (N, T, D, File_Name, Found, Attr); - if File /= No_File then - return File; + if Found /= No_File then + return; end if; end loop; - return No_File; + Attr.all := Unknown_Attributes; + Found := No_File; end if; end; end Find_File; @@ -1146,9 +1235,28 @@ package body Osint is -- Full_Lib_File_Name -- ------------------------ + procedure Full_Lib_File_Name + (N : File_Name_Type; + Lib_File : out File_Name_Type; + Attr : out File_Attributes) + is + A : aliased File_Attributes; + begin + -- ??? seems we could use Smart_Find_File here + Find_File (N, Library, Lib_File, A'Access); + Attr := A; + end Full_Lib_File_Name; + + ------------------------ + -- Full_Lib_File_Name -- + ------------------------ + function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is + Attr : File_Attributes; + File : File_Name_Type; begin - return Find_File (N, Library); + Full_Lib_File_Name (N, File, Attr); + return File; end Full_Lib_File_Name; ---------------------------- @@ -1187,6 +1295,18 @@ package body Osint is return Smart_Find_File (N, Source); end Full_Source_Name; + ---------------------- + -- Full_Source_Name -- + ---------------------- + + procedure Full_Source_Name + (N : File_Name_Type; + Full_File : out File_Name_Type; + Attr : access File_Attributes) is + begin + Smart_Find_File (N, Source, Full_File, Attr.all); + end Full_Source_Name; + ------------------- -- Get_Directory -- ------------------- @@ -1468,6 +1588,19 @@ package body Osint is Lib_Search_Directories.Table (Primary_Directory) := new String'(""); end Initialize; + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_directory_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Directory; + ---------------------------- -- Is_Directory_Separator -- ---------------------------- @@ -1499,6 +1632,71 @@ package body Osint is return not Is_Writable_File (Name_Buffer (1 .. Name_Len)); end Is_Readonly_Library; + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_executable_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Executable_File; + + ---------------------- + -- Is_Readable_File -- + ---------------------- + + function Is_Readable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_readable_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Readable_File; + + --------------------- + -- Is_Regular_File -- + --------------------- + + function Is_Regular_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_regular_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Regular_File; + + ---------------------- + -- Is_Symbolic_Link -- + ---------------------- + + function Is_Symbolic_Link + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_symbolic_link_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Symbolic_Link; + + ---------------------- + -- Is_Writable_File -- + ---------------------- + + function Is_Writable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_writable_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Writable_File; + ------------------- -- Lib_File_Name -- ------------------- @@ -1527,24 +1725,17 @@ package body Osint is return Name_Find; end Lib_File_Name; - ------------------------ - -- Library_File_Stamp -- - ------------------------ - - function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is - begin - return File_Stamp (Find_File (N, Library)); - end Library_File_Stamp; - ----------------- -- Locate_File -- ----------------- - function Locate_File - (N : File_Name_Type; - T : File_Type; - Dir : Natural; - Name : String) return File_Name_Type + procedure Locate_File + (N : File_Name_Type; + T : File_Type; + Dir : Natural; + Name : String; + Found : out File_Name_Type; + Attr : access File_Attributes) is Dir_Name : String_Ptr; @@ -1557,29 +1748,34 @@ package body Osint is elsif T = Library then Dir_Name := Lib_Search_Directories.Table (Dir); - else pragma Assert (T /= Config); + else + pragma Assert (T /= Config); Dir_Name := Src_Search_Directories.Table (Dir); end if; declare - Full_Name : String (1 .. Dir_Name'Length + Name'Length); + Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1); begin Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; - Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name; + Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name; + Full_Name (Full_Name'Last) := ASCII.NUL; + + Attr.all := Unknown_Attributes; - if not Is_Regular_File (Full_Name) then - return No_File; + if not Is_Regular_File (Full_Name'Address, Attr) then + Found := No_File; else -- If the file is in the current directory then return N itself if Dir_Name'Length = 0 then - return N; + Found := N; else - Name_Len := Full_Name'Length; - Name_Buffer (1 .. Name_Len) := Full_Name; - return Name_Enter; + Name_Len := Full_Name'Length - 1; + Name_Buffer (1 .. Name_Len) := + Full_Name (1 .. Full_Name'Last - 1); + Found := Name_Find; -- ??? Was Name_Enter, no obvious reason end if; end if; end; @@ -1599,11 +1795,13 @@ package body Osint is declare File_Name : constant String := Name_Buffer (1 .. Name_Len); File : File_Name_Type := No_File; + Attr : aliased File_Attributes; Last_Dir : Natural; begin if Opt.Look_In_Primary_Dir then - File := Locate_File (N, Source, Primary_Directory, File_Name); + Locate_File + (N, Source, Primary_Directory, File_Name, File, Attr'Access); if File /= No_File and then T = File_Stamp (N) then return File; @@ -1613,7 +1811,7 @@ package body Osint is Last_Dir := Src_Search_Directories.Last; for D in Primary_Directory + 1 .. Last_Dir loop - File := Locate_File (N, Source, D, File_Name); + Locate_File (N, Source, D, File_Name, File, Attr'Access); if File /= No_File and then T = File_Stamp (File) then return File; @@ -1887,6 +2085,10 @@ package body Osint is S : Second_Type; begin + if T = Invalid_Time then + return Empty_Time_Stamp; + end if; + GM_Split (T, Y, Mo, D, H, Mn, S); Make_Time_Stamp (Year => Nat (Y), @@ -2115,10 +2317,33 @@ package body Osint is (Lib_File : File_Name_Type; Fatal_Err : Boolean := False) return Text_Buffer_Ptr is + File : File_Name_Type; + Attr : aliased File_Attributes; + begin + Find_File (Lib_File, Library, File, Attr'Access); + return Read_Library_Info_From_Full + (Full_Lib_File => File, + Lib_File_Attr => Attr'Access, + Fatal_Err => Fatal_Err); + end Read_Library_Info; + + --------------------------------- + -- Read_Library_Info_From_Full -- + --------------------------------- + + function Read_Library_Info_From_Full + (Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; + Fatal_Err : Boolean := False) return Text_Buffer_Ptr + is Lib_FD : File_Descriptor; -- The file descriptor for the current library file. A negative value -- indicates failure to open the specified source file. + Len : Integer; + -- Length of source file text (ALI). If it doesn't fit in an integer + -- we're probably stuck anyway (>2 gigs of source seems a lot!) + Text : Text_Buffer_Ptr; -- Allocated text buffer @@ -2127,7 +2352,7 @@ package body Osint is -- For the calls to Close begin - Current_Full_Lib_Name := Find_File (Lib_File, Library); + Current_Full_Lib_Name := Full_Lib_File; Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); if Current_Full_Lib_Name = No_File then @@ -2158,17 +2383,32 @@ package body Osint is end if; end if; + -- Compute the length of the file (potentially also preparing other data + -- like the timestamp and whether the file is read-only, for future use) + + Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); + -- Check for object file consistency if requested if Opt.Check_Object_Consistency then - Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name); + -- On most systems, this does not result in an extra system call + Current_Full_Lib_Stamp := OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); + + -- ??? One system call here Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); if Current_Full_Obj_Stamp (1) = ' ' then -- When the library is readonly always assume object is consistent + -- The call to Is_Writable_File only results in a system call on + -- some systems, but in most cases it has already been computed as + -- part of the call to File_Length above. + + Get_Name_String (Current_Full_Lib_Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; - if Is_Readonly_Library (Current_Full_Lib_Name) then + if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; elsif Fatal_Err then @@ -2193,10 +2433,6 @@ package body Osint is -- Read data from the file declare - Len : constant Integer := Integer (File_Length (Lib_FD)); - -- Length of source file text. If it doesn't fit in an integer - -- we're probably stuck anyway (>2 gigs of source seems a lot!) - Actual_Len : Integer := 0; Lo : constant Text_Ptr := 0; @@ -2233,7 +2469,7 @@ package body Osint is return Text; - end Read_Library_Info; + end Read_Library_Info_From_Full; ---------------------- -- Read_Source_File -- @@ -2472,21 +2708,23 @@ package body Osint is (N : File_Name_Type; T : File_Type) return Time_Stamp_Type is - Time_Stamp : Time_Stamp_Type; - + File : File_Name_Type; + Attr : aliased File_Attributes; begin if not File_Cache_Enabled then - return File_Stamp (Find_File (N, T)); + Find_File (N, T, File, Attr'Access); + else + Smart_Find_File (N, T, File, Attr); end if; - Time_Stamp := File_Stamp_Hash_Table.Get (N); - - if Time_Stamp (1) = ' ' then - Time_Stamp := File_Stamp (Smart_Find_File (N, T)); - File_Stamp_Hash_Table.Set (N, Time_Stamp); + if File = No_File then + return Empty_Time_Stamp; + else + Get_Name_String (File); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); end if; - - return Time_Stamp; end Smart_File_Stamp; --------------------- @@ -2497,21 +2735,38 @@ package body Osint is (N : File_Name_Type; T : File_Type) return File_Name_Type is - Full_File_Name : File_Name_Type; - + File : File_Name_Type; + Attr : File_Attributes; begin - if not File_Cache_Enabled then - return Find_File (N, T); - end if; + Smart_Find_File (N, T, File, Attr); + return File; + end Smart_Find_File; - Full_File_Name := File_Name_Hash_Table.Get (N); + --------------------- + -- Smart_Find_File -- + --------------------- + + procedure Smart_Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : out File_Attributes) + is + Info : File_Info_Cache; - if Full_File_Name = No_File then - Full_File_Name := Find_File (N, T); - File_Name_Hash_Table.Set (N, Full_File_Name); + begin + if not File_Cache_Enabled then + Find_File (N, T, Info.File, Info.Attr'Access); + else + Info := File_Name_Hash_Table.Get (N); + if Info.File = No_File then + Find_File (N, T, Info.File, Info.Attr'Access); + File_Name_Hash_Table.Set (N, Info); + end if; end if; - return Full_File_Name; + Found := Info.File; + Attr := Info.Attr; end Smart_Find_File; ---------------------- @@ -2941,6 +3196,9 @@ package body Osint is -- Package Initialization -- ---------------------------- + procedure Reset_File_Attributes (Attr : System.Address); + pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); + begin Initialization : declare @@ -2956,7 +3214,15 @@ begin "__gnat_get_maximum_file_name_length"); -- Function to get maximum file name length for system + Sizeof_File_Attributes : Integer; + pragma Import (C, Sizeof_File_Attributes, + "__gnat_size_of_file_attributes"); + begin + pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size); + + Reset_File_Attributes (Unknown_Attributes'Address); + Identifier_Character_Set := Get_Default_Identifier_Character_Set; Maximum_File_Name_Length := Get_Maximum_File_Name_Length; diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index a44d4e24b3c..34b3f642fee 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -29,6 +29,7 @@ with Namet; use Namet; with Types; use Types; +with System.Storage_Elements; with System.OS_Lib; use System.OS_Lib; with System; use System; @@ -230,6 +231,47 @@ package Osint is -- this routine called with Name set to "gnat" will return "-lgnat-5.02" -- on UNIX and Windows and -lgnat_5_02 on VMS. + --------------------- + -- File attributes -- + --------------------- + -- The following subprograms offer services similar to those found in + -- System.OS_Lib, but with the ability to extra multiple information from + -- a single system call, depending on the system. This can result in fewer + -- system calls when reused. + -- In all these subprograms, the requested value is either read from the + -- File_Attributes parameter (resulting in no system call), or computed + -- from the disk and then cached in the File_Attributes parameter (possibly + -- along with other values). + + type File_Attributes is private; + Unknown_Attributes : constant File_Attributes; + -- A cache for various attributes for a file (length, accessibility,...) + -- This must be initialized to Unknown_Attributes prior to the first call. + + function Is_Directory + (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + function Is_Regular_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + function Is_Symbolic_Link + (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + -- Return the type of the file, + + function File_Length + (Name : C_File_Name; Attr : access File_Attributes) return Long_Integer; + -- Return the length (number of bytes) of the file + + function File_Time_Stamp + (Name : C_File_Name; Attr : access File_Attributes) return OS_Time; + -- Return the time stamp of the file + + function Is_Readable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + function Is_Executable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + function Is_Writable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + -- Return the access rights for the file + ------------------------- -- Search Dir Routines -- ------------------------- @@ -380,6 +422,10 @@ package Osint is -- using Read_Source_File. Calling this routine entails no source file -- directory lookup penalty. + procedure Full_Source_Name + (N : File_Name_Type; + Full_File : out File_Name_Type; + Attr : access File_Attributes); function Full_Source_Name (N : File_Name_Type) return File_Name_Type; function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type; -- Returns the full name/time stamp of the source file whose simple name @@ -390,6 +436,8 @@ package Osint is -- The source file directory lookup penalty is incurred every single time -- the routines are called unless you have previously called -- Source_File_Data (Cache => True). See below. + -- The procedural version also returns some file attributes for the ALI + -- file (to save on system calls later on). function Current_File_Index return Int; -- Return the index in its source file of the current main unit @@ -486,6 +534,17 @@ package Osint is -- behaves as if it did not find Lib_File (namely if Fatal_Err is -- False, null is returned). + function Read_Library_Info_From_Full + (Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; + Fatal_Err : Boolean := False) return Text_Buffer_Ptr; + -- Same as Read_Library_Info, except Full_Lib_File must contains the full + -- path to the library file (instead of having Read_Library_Info recompute + -- it). + -- Lib_File_Attr should be an initialized set of attributes for the + -- library file (it can be initialized to Unknown_Attributes, but in + -- general will have been initialized by a previous call to Find_File). + function Full_Library_Info_Name return File_Name_Type; function Full_Object_File_Name return File_Name_Type; -- Returns the full name of the library/object file most recently read @@ -501,14 +560,19 @@ package Osint is -- It is an error to call Current_Object_File_Stamp if -- Opt.Check_Object_Consistency is set to False. + procedure Full_Lib_File_Name + (N : File_Name_Type; + Lib_File : out File_Name_Type; + Attr : out File_Attributes); function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type; - function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type; - -- Returns the full name/time stamp of library file N. N should not include + -- Returns the full name of library file N. N should not include -- path information. Note that if the file cannot be located No_File is -- returned for the first routine and an all blank time stamp is returned -- for the second (this is not an error situation). The full name includes -- the appropriate directory information. The library file directory lookup -- penalty is incurred every single time this routine is called. + -- The procedural version also returns some file attributes for the ALI + -- file (to save on system calls later on). function Lib_File_Name (Source_File : File_Name_Type; @@ -654,4 +718,19 @@ private -- detected, the file being written is deleted, and a fatal error is -- signalled. + File_Attributes_Size : constant Integer := 50; + -- This should be big enough to fit a "struct file_attributes" on any + -- system. It doesn't matter if it is too big (which avoids the need for + -- either mapping the struct exactly or importing the sizeof from C, which + -- would result in dynamic code) + + type File_Attributes is + array (1 .. File_Attributes_Size) + of System.Storage_Elements.Storage_Element; + for File_Attributes'Alignment use Standard'Maximum_Alignment; + + Unknown_Attributes : constant File_Attributes := (others => 0); + -- Will be initialized properly at elaboration (for efficiency later on, + -- avoid function calls every time we want to reset the attributes). + end Osint; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f07f54e5098..2bb9d25fcc1 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -89,9 +89,6 @@ package body Ch4 is -- prefix. The current token is known to be an apostrophe and the -- following token is known to be RANGE. - procedure Set_Op_Name (Node : Node_Id); - -- Procedure to set name field (Chars) in operator node - ------------------------- -- Bad_Range_Attribute -- ------------------------- @@ -102,51 +99,6 @@ package body Ch4 is Resync_Expression; end Bad_Range_Attribute; - ------------------ - -- Set_Op_Name -- - ------------------ - - procedure Set_Op_Name (Node : Node_Id) is - type Name_Of_Type is array (N_Op) of Name_Id; - Name_Of : constant Name_Of_Type := Name_Of_Type'( - N_Op_And => Name_Op_And, - N_Op_Or => Name_Op_Or, - N_Op_Xor => Name_Op_Xor, - N_Op_Eq => Name_Op_Eq, - N_Op_Ne => Name_Op_Ne, - N_Op_Lt => Name_Op_Lt, - N_Op_Le => Name_Op_Le, - N_Op_Gt => Name_Op_Gt, - N_Op_Ge => Name_Op_Ge, - N_Op_Add => Name_Op_Add, - N_Op_Subtract => Name_Op_Subtract, - N_Op_Concat => Name_Op_Concat, - N_Op_Multiply => Name_Op_Multiply, - N_Op_Divide => Name_Op_Divide, - N_Op_Mod => Name_Op_Mod, - N_Op_Rem => Name_Op_Rem, - N_Op_Expon => Name_Op_Expon, - N_Op_Plus => Name_Op_Add, - N_Op_Minus => Name_Op_Subtract, - N_Op_Abs => Name_Op_Abs, - N_Op_Not => Name_Op_Not, - - -- We don't really need these shift operators, since they never - -- appear as operators in the source, but the path of least - -- resistance is to put them in (the aggregate must be complete) - - N_Op_Rotate_Left => Name_Rotate_Left, - N_Op_Rotate_Right => Name_Rotate_Right, - N_Op_Shift_Left => Name_Shift_Left, - N_Op_Shift_Right => Name_Shift_Right, - N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); - - begin - if Nkind (Node) in N_Op then - Set_Chars (Node, Name_Of (Nkind (Node))); - end if; - end Set_Op_Name; - -------------------------- -- 4.1 Name (also 6.4) -- -------------------------- @@ -1600,10 +1552,9 @@ package body Ch4 is end if; Node2 := Node1; - Node1 := New_Node (Logical_Op, Op_Location); + Node1 := New_Op_Node (Logical_Op, Op_Location); Set_Left_Opnd (Node1, Node2); Set_Right_Opnd (Node1, P_Relation); - Set_Op_Name (Node1); exit when Token not in Token_Class_Logop; end loop; @@ -1704,10 +1655,9 @@ package body Ch4 is end if; Node2 := Node1; - Node1 := New_Node (Logical_Op, Op_Location); + Node1 := New_Op_Node (Logical_Op, Op_Location); Set_Left_Opnd (Node1, Node2); Set_Right_Opnd (Node1, P_Relation); - Set_Op_Name (Node1); exit when Token not in Token_Class_Logop; end loop; @@ -1768,9 +1718,8 @@ package body Ch4 is -- P_Relational_Operator also parses the IN and NOT IN operations. Optok := Token_Ptr; - Node2 := New_Node (P_Relational_Operator, Optok); + Node2 := New_Op_Node (P_Relational_Operator, Optok); Set_Left_Opnd (Node2, Node1); - Set_Op_Name (Node2); -- Case of IN or NOT IN @@ -1881,18 +1830,17 @@ package body Ch4 is Style.Check_Exponentiation_Operator; end if; - Node2 := New_Node (N_Op_Expon, Token_Ptr); + Node2 := New_Op_Node (N_Op_Expon, Token_Ptr); Scan; -- past ** Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Primary); - Set_Op_Name (Node2); Node1 := Node2; end if; loop exit when Token not in Token_Class_Mulop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Multiplying_Operator, Tokptr); + Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); if Style_Check then Style.Check_Binary_Operator; @@ -1901,14 +1849,13 @@ package body Ch4 is Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor); - Set_Op_Name (Node2); Node1 := Node2; end loop; loop exit when Token not in Token_Class_Binary_Addop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Binary_Adding_Operator, Tokptr); + Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); if Style_Check then Style.Check_Binary_Operator; @@ -1917,7 +1864,6 @@ package body Ch4 is Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Term); - Set_Op_Name (Node2); Node1 := Node2; end loop; @@ -1931,7 +1877,7 @@ package body Ch4 is if Token in Token_Class_Unary_Addop then Tokptr := Token_Ptr; - Node1 := New_Node (P_Unary_Adding_Operator, Tokptr); + Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr); if Style_Check then Style.Check_Unary_Plus_Or_Minus; @@ -1939,7 +1885,6 @@ package body Ch4 is Scan; -- past operator Set_Right_Opnd (Node1, P_Term); - Set_Op_Name (Node1); else Node1 := P_Term; end if; @@ -1981,12 +1926,11 @@ package body Ch4 is loop exit when Token not in Token_Class_Binary_Addop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Binary_Adding_Operator, Tokptr); + Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Node1 := P_Term; Set_Right_Opnd (Node2, Node1); - Set_Op_Name (Node2); -- Check if we're still concatenating string literals @@ -2214,11 +2158,10 @@ package body Ch4 is loop exit when Token not in Token_Class_Mulop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Multiplying_Operator, Tokptr); + Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor); - Set_Op_Name (Node2); Node1 := Node2; end loop; @@ -2239,7 +2182,7 @@ package body Ch4 is begin if Token = Tok_Abs then - Node1 := New_Node (N_Op_Abs, Token_Ptr); + Node1 := New_Op_Node (N_Op_Abs, Token_Ptr); if Style_Check then Style.Check_Abs_Not; @@ -2247,11 +2190,10 @@ package body Ch4 is Scan; -- past ABS Set_Right_Opnd (Node1, P_Primary); - Set_Op_Name (Node1); return Node1; elsif Token = Tok_Not then - Node1 := New_Node (N_Op_Not, Token_Ptr); + Node1 := New_Op_Node (N_Op_Not, Token_Ptr); if Style_Check then Style.Check_Abs_Not; @@ -2259,18 +2201,16 @@ package body Ch4 is Scan; -- past NOT Set_Right_Opnd (Node1, P_Primary); - Set_Op_Name (Node1); return Node1; else Node1 := P_Primary; if Token = Tok_Double_Asterisk then - Node2 := New_Node (N_Op_Expon, Token_Ptr); + Node2 := New_Op_Node (N_Op_Expon, Token_Ptr); Scan; -- past ** Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Primary); - Set_Op_Name (Node2); return Node2; else return Node1; diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb index 8e0d5627a67..3728c9e44b0 100644 --- a/gcc/ada/prj-err.adb +++ b/gcc/ada/prj-err.adb @@ -23,8 +23,9 @@ -- -- ------------------------------------------------------------------------------ -with Output; use Output; -with Stringt; use Stringt; +with Err_Vars; +with Output; use Output; +with Stringt; use Stringt; package body Prj.Err is @@ -117,7 +118,13 @@ package body Prj.Err is if Flags.Report_Error /= null then Flags.Report_Error (Project, - Is_Warning => Msg (Msg'First) = '?' or else Msg (Msg'First) = '<'); + Is_Warning => + Msg (Msg'First) = '?' + or else (Msg (Msg'First) = '<' + and then Err_Vars.Error_Msg_Warn) + or else (Msg (Msg'First) = '\' + and then Msg (Msg'First + 1) = '<' + and then Err_Vars.Error_Msg_Warn)); end if; end Error_Msg; diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index 9c9707c1cfa..8c7a5d95d96 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -26,6 +26,7 @@ with System.OS_Lib; use System.OS_Lib; with Hostparm; with Makeutl; use Makeutl; +with Opt; with Osint; use Osint; with Prj.Tree; use Prj.Tree; with Sdefault; @@ -212,7 +213,9 @@ package body Prj.Ext is declare New_Dir : constant String := - Normalize_Pathname (Name_Buffer (First .. Last)); + Normalize_Pathname + (Name_Buffer (First .. Last), + Resolve_Links => Opt.Follow_Links_For_Dirs); begin -- If the absolute path was resolved and is different from diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index cec5e6b0a59..5e76bce58ac 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -4707,121 +4707,82 @@ package body Prj.Nmsc is Removed : Boolean := False) is Directory : constant String := Get_Name_String (From); - Element : String_Element; + + procedure Add_To_Or_Remove_From_List + (Path_Id : Name_Id; + Display_Path_Id : Name_Id); + -- When Removed = False, the directory Path_Id to the list of + -- source_dirs if not already in the list. When Removed = True, + -- removed directory Path_Id if in the list. procedure Recursive_Find_Dirs (Path : Name_Id); -- Find all the subdirectories (recursively) of Path and add them -- to the list of source directories of the project. - ------------------------- - -- Recursive_Find_Dirs -- - ------------------------- - - procedure Recursive_Find_Dirs (Path : Name_Id) is - Dir : Dir_Type; - Name : String (1 .. 250); - Last : Natural; - List : String_List_Id; - Prev : String_List_Id; - Rank_List : Number_List_Index; - Prev_Rank : Number_List_Index; - Element : String_Element; - Found : Boolean := False; - - Non_Canonical_Path : Name_Id := No_Name; - Canonical_Path : Name_Id := No_Name; - - The_Path : constant String := - Normalize_Pathname - (Get_Name_String (Path), - Directory => - Get_Name_String (Project.Directory.Display_Name), - Resolve_Links => Opt.Follow_Links_For_Dirs) & - Directory_Separator; - - The_Path_Last : constant Natural := - Compute_Directory_Last (The_Path); + -------------------------------- + -- Add_To_Or_Remove_From_List -- + -------------------------------- + + procedure Add_To_Or_Remove_From_List + (Path_Id : Name_Id; + Display_Path_Id : Name_Id) + is + List : String_List_Id; + Prev : String_List_Id; + Rank_List : Number_List_Index; + Prev_Rank : Number_List_Index; + Element : String_Element; begin - Name_Len := The_Path_Last - The_Path'First + 1; - Name_Buffer (1 .. Name_Len) := - The_Path (The_Path'First .. The_Path_Last); - Non_Canonical_Path := Name_Find; - Canonical_Path := - Name_Id (Canonical_Case_File_Name (Non_Canonical_Path)); - - -- To avoid processing the same directory several times, check - -- if the directory is already in Recursive_Dirs. If it is, then - -- there is nothing to do, just return. If it is not, put it there - -- and continue recursive processing. - - if not Removed then - if Recursive_Dirs.Get (Visited, Canonical_Path) then - return; - else - Recursive_Dirs.Set (Visited, Canonical_Path, True); - end if; - end if; - - -- Check if directory is already in list - - List := Project.Source_Dirs; - Prev := Nil_String; - Rank_List := Project.Source_Dir_Ranks; + Prev := Nil_String; Prev_Rank := No_Number_List; + List := Project.Source_Dirs; + Rank_List := Project.Source_Dir_Ranks; while List /= Nil_String loop Element := Data.Tree.String_Elements.Table (List); - - if Element.Value /= No_Name then - Found := Element.Value = Canonical_Path; - exit when Found; - end if; - + exit when Element.Value = Path_Id; Prev := List; List := Element.Next; Prev_Rank := Rank_List; - Rank_List := Data.Tree.Number_Lists.Table (Rank_List).Next; + Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next; end loop; - -- If directory is not already in list, put it there + -- The directory is in the list if List is not Nil_String - if (not Removed) and (not Found) then + if not Removed and then List = Nil_String then if Current_Verbosity = High then - Write_Str (" "); - Write_Line (The_Path (The_Path'First .. The_Path_Last)); + Write_Str (" Adding Source Dir="); + Write_Line (Get_Name_String (Path_Id)); end if; String_Element_Table.Increment_Last (Data.Tree.String_Elements); Element := - (Value => Canonical_Path, - Display_Value => Non_Canonical_Path, + (Value => Path_Id, + Index => 0, + Display_Value => Display_Path_Id, Location => No_Location, Flag => False, - Next => Nil_String, - Index => 0); + Next => Nil_String); Number_List_Table.Increment_Last (Data.Tree.Number_Lists); - -- Case of first source directory - if Last_Source_Dir = Nil_String then + + -- This is the first source directory + Project.Source_Dirs := String_Element_Table.Last (Data.Tree.String_Elements); Project.Source_Dir_Ranks := Number_List_Table.Last (Data.Tree.Number_Lists); - -- Here we already have source directories - else - -- Link the previous last to the new one + -- We already have source directories, link the previous + -- last to the new one. - Data.Tree.String_Elements.Table - (Last_Source_Dir).Next := + Data.Tree.String_Elements.Table (Last_Source_Dir).Next := String_Element_Table.Last (Data.Tree.String_Elements); - Data.Tree.Number_Lists.Table - (Last_Src_Dir_Rank).Next := + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next := Number_List_Table.Last (Data.Tree.Number_Lists); - end if; -- And register this source directory as the new last @@ -4834,12 +4795,16 @@ package body Prj.Nmsc is Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) := (Number => Rank, Next => No_Number_List); - elsif Removed and Found then + elsif Removed and then List /= Nil_String then + + -- Remove source dir, if present + if Prev = Nil_String then Project.Source_Dirs := Data.Tree.String_Elements.Table (List).Next; Project.Source_Dir_Ranks := Data.Tree.Number_Lists.Table (Rank_List).Next; + else Data.Tree.String_Elements.Table (Prev).Next := Data.Tree.String_Elements.Table (List).Next; @@ -4847,10 +4812,59 @@ package body Prj.Nmsc is Data.Tree.Number_Lists.Table (Rank_List).Next; end if; end if; + end Add_To_Or_Remove_From_List; + + ------------------------- + -- Recursive_Find_Dirs -- + ------------------------- + + procedure Recursive_Find_Dirs (Path : Name_Id) is + Dir : Dir_Type; + Name : String (1 .. 250); + Last : Natural; - -- Now look for subdirectories. We do that even when this - -- directory is already in the list, because some of its - -- subdirectories may not be in the list yet. + Non_Canonical_Path : Name_Id := No_Name; + Canonical_Path : Name_Id := No_Name; + + The_Path : constant String := + Normalize_Pathname + (Get_Name_String (Path), + Directory => + Get_Name_String (Project.Directory.Display_Name), + Resolve_Links => Opt.Follow_Links_For_Dirs) & + Directory_Separator; + + The_Path_Last : constant Natural := + Compute_Directory_Last (The_Path); + + begin + Name_Len := The_Path_Last - The_Path'First + 1; + Name_Buffer (1 .. Name_Len) := + The_Path (The_Path'First .. The_Path_Last); + Non_Canonical_Path := Name_Find; + Canonical_Path := + Name_Id (Canonical_Case_File_Name (Non_Canonical_Path)); + + -- To avoid processing the same directory several times, check + -- if the directory is already in Recursive_Dirs. If it is, then + -- there is nothing to do, just return. If it is not, put it there + -- and continue recursive processing. + + if not Removed then + if Recursive_Dirs.Get (Visited, Canonical_Path) then + return; + else + Recursive_Dirs.Set (Visited, Canonical_Path, True); + end if; + end if; + + Add_To_Or_Remove_From_List + (Path_Id => Canonical_Path, + Display_Path_Id => Non_Canonical_Path); + + -- Now look for subdirectories. Do that even when this directory + -- is already in the list, because some of its subdirectories may + -- not be in the list yet. Open (Dir, The_Path (The_Path'First .. The_Path_Last)); @@ -4870,12 +4884,14 @@ package body Prj.Nmsc is declare Path_Name : constant String := - Normalize_Pathname - (Name => Name (1 .. Last), - Directory => - The_Path (The_Path'First .. The_Path_Last), - Resolve_Links => Opt.Follow_Links_For_Dirs, - Case_Sensitive => True); + Normalize_Pathname + (Name => Name (1 .. Last), + Directory => + The_Path + (The_Path'First .. The_Path_Last), + Resolve_Links => + Opt.Follow_Links_For_Dirs, + Case_Sensitive => True); begin if Is_Directory (Path_Name) then @@ -4945,7 +4961,8 @@ package body Prj.Nmsc is Directory => Get_Name_String (Project.Directory.Display_Name), - Resolve_Links => False, + Resolve_Links => + Opt.Follow_Links_For_Dirs, Case_Sensitive => True); begin @@ -4987,10 +5004,6 @@ package body Prj.Nmsc is else declare Path_Name : Path_Information; - List : String_List_Id; - Prev : String_List_Id; - Rank_List : Number_List_Index; - Prev_Rank : Number_List_Index; Dir_Exists : Boolean; begin @@ -5019,8 +5032,16 @@ package body Prj.Nmsc is else declare - Path : constant String := - Get_Name_String (Path_Name.Name); + Path : constant String := + Normalize_Pathname + (Name => + Get_Name_String (Path_Name.Name), + Directory => + Get_Name_String (Project.Directory.Name), + Resolve_Links => Opt.Follow_Links_For_Dirs, + Case_Sensitive => True) & + Directory_Separator; + Last_Path : constant Natural := Compute_Directory_Last (Path); Path_Id : Name_Id; @@ -5036,113 +5057,16 @@ package body Prj.Nmsc is Name_Len := 0; Add_Str_To_Name_Buffer (Path (Path'First .. Last_Path)); Path_Id := Name_Find; + Name_Len := 0; Add_Str_To_Name_Buffer (Display_Path (Display_Path'First .. Last_Display_Path)); Display_Path_Id := Name_Find; - -- Check if the directory is already in the list - - Prev := Nil_String; - Prev_Rank := No_Number_List; - - -- Look for source dir in current list - - List := Project.Source_Dirs; - Rank_List := Project.Source_Dir_Ranks; - while List /= Nil_String loop - Element := Data.Tree.String_Elements.Table (List); - exit when Element.Value = Path_Id; - Prev := List; - List := Element.Next; - Prev_Rank := Rank_List; - Rank_List := - Data.Tree.Number_Lists.Table (Prev_Rank).Next; - end loop; - - -- The directory is in the list if List is not Nil_String - - if not Removed then - - -- As it is an existing directory, we add it to the - -- list of directories, if not already in the list. - - if List = Nil_String then - String_Element_Table.Increment_Last - (Data.Tree.String_Elements); - Element := - (Value => Path_Id, - Index => 0, - Display_Value => Display_Path_Id, - Location => No_Location, - Flag => False, - Next => Nil_String); - Number_List_Table.Increment_Last - (Data.Tree.Number_Lists); - - if Last_Source_Dir = Nil_String then - - -- This is the first source directory - - Project.Source_Dirs := - String_Element_Table.Last - (Data.Tree.String_Elements); - Project.Source_Dir_Ranks := - Number_List_Table.Last - (Data.Tree.Number_Lists); - - else - -- We already have source directories, link the - -- previous last to the new one. - - Data.Tree.String_Elements.Table - (Last_Source_Dir).Next := - String_Element_Table.Last - (Data.Tree.String_Elements); - Data.Tree.Number_Lists.Table - (Last_Src_Dir_Rank).Next := - Number_List_Table.Last - (Data.Tree.Number_Lists); - - end if; - - -- And register this source directory as the new - -- last. - - Last_Source_Dir := - String_Element_Table.Last - (Data.Tree.String_Elements); - Data.Tree.String_Elements.Table - (Last_Source_Dir) := Element; - Last_Src_Dir_Rank := - Number_List_Table.Last - (Data.Tree.Number_Lists); - Data.Tree.Number_Lists.Table - (Last_Src_Dir_Rank) := - (Number => Rank, Next => No_Number_List); - end if; - - else - -- Remove source dir, if present - - if List /= Nil_String then - -- Source dir was found, remove it from the list - - if Prev = Nil_String then - Project.Source_Dirs := - Data.Tree.String_Elements.Table (List).Next; - Project.Source_Dir_Ranks := - Data.Tree.Number_Lists.Table (Rank_List).Next; - - else - Data.Tree.String_Elements.Table (Prev).Next := - Data.Tree.String_Elements.Table (List).Next; - Data.Tree.Number_Lists.Table (Prev_Rank).Next := - Data.Tree.Number_Lists.Table (Rank_List).Next; - end if; - end if; - end if; + Add_To_Or_Remove_From_List + (Path_Id => Path_Id, + Display_Path_Id => Display_Path_Id); end; end if; end; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 1ed78ab227b..7702f540930 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -485,19 +485,27 @@ package body Prj.Part is return; end if; - Parse_Single_Project - (In_Tree => In_Tree, - Project => Project, - Extends_All => Dummy, - Path_Name => Path_Name, - Extended => False, - From_Extended => None, - In_Limited => False, - Packages_To_Check => Packages_To_Check, - Depth => 0, - Current_Dir => Current_Directory, - Is_Config_File => Is_Config_File, - Flags => Flags); + begin + Parse_Single_Project + (In_Tree => In_Tree, + Project => Project, + Extends_All => Dummy, + Path_Name => Path_Name, + Extended => False, + From_Extended => None, + In_Limited => False, + Packages_To_Check => Packages_To_Check, + Depth => 0, + Current_Dir => Current_Directory, + Is_Config_File => Is_Config_File, + Flags => Flags); + + exception + when Types.Unrecoverable_Error => + -- Unrecoverable_Error is raised when a line is too long. + -- A meaningful error message will be displayed later. + Project := Empty_Node; + end; -- If Project is an extending-all project, create the eventual -- virtual extending projects and check that there are no illegally diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 4823a988d6c..df6e5acb6cf 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -23,10 +23,11 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Deallocation; with Osint; use Osint; with Prj.Err; +with Ada.Unchecked_Deallocation; + package body Prj.Tree is Node_With_Comments : constant array (Project_Node_Kind) of Boolean := @@ -1000,6 +1001,8 @@ package body Prj.Tree is if Proj /= null then Project_Node_Table.Free (Proj.Project_Nodes); Projects_Htable.Reset (Proj.Projects_HT); + Name_To_Name_HTable.Reset (Proj.External_References); + Free (Proj.Project_Path); Unchecked_Free (Proj); end if; end Free; diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 1d9efb93b7f..3589bc5dfd1 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -56,6 +56,14 @@ typedef char bool; #include "adaint.h" #include "raise.h" +#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 + /* The names of a couple of "standard" routines for unwinding/propagation actually vary depending on the underlying GCC scheme for exception handling (SJLJ or DWARF). We need a consistently named interface to import from @@ -501,7 +509,14 @@ typedef struct static void db_region_for (region_descriptor *region, _Unwind_Context *uw_context) { - _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1; + 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 + if (!ip_before_insn) + ip--; if (! (db_accepted_codes () & DB_REGIONS)) return; @@ -631,7 +646,14 @@ typedef struct static void db_action_for (action_descriptor *action, _Unwind_Context *uw_context) { - _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1; + 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 + if (!ip_before_insn) + ip--; db (DB_ACTIONS, "For ip @ 0x%08x => ", ip); @@ -670,14 +692,6 @@ db_action_for (action_descriptor *action, _Unwind_Context *uw_context) There are two variants of this routine, depending on the underlying 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__ #define __builtin_eh_return_data_regno(x) x diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 5a9902dd657..f013a418fcb 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -202,4 +202,7 @@ package System.CRTL is function write (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, write, "write"); + function strerror (errno : int) return chars; + pragma Import (C, strerror, "strerror"); + end System.CRTL; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index df45003cd1a..f93fee25e33 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -31,7 +31,10 @@ with Ada.Finalization; use Ada.Finalization; with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Unchecked_Conversion; + with Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; with Interfaces.C_Streams; use Interfaces.C_Streams; with System.CRTL; @@ -48,7 +51,7 @@ package body System.File_IO is package SSL renames System.Soft_Links; use type Interfaces.C.int; - use type System.CRTL.size_t; + use type CRTL.size_t; ---------------------- -- Global Variables -- @@ -126,6 +129,23 @@ package body System.File_IO is -- call to fopen or freopen. Amethod is the character designating -- the access method from the Access_Method field of the FCB. + function Errno_Message + (Errno : Integer := OS_Lib.Errno) return String; + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String; + -- Return a message suitable for "raise ... with Errno_Message (...)". + -- Errno defaults to the current errno, but should be passed explicitly if + -- there is significant code in between the call that sets errno and the + -- call to Errno_Message, in case that code also sets errno. The version + -- with Name includes that file name in the message. + + procedure Raise_Device_Error + (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno); + pragma No_Return (Raise_Device_Error); + -- Clear error indication on File and raise Device_Error with an exception + -- message providing errno information. + ---------------- -- Append_Set -- ---------------- @@ -134,7 +154,7 @@ package body System.File_IO is begin if File.Mode = Append_File then if fseek (File.Stream, 0, SEEK_END) /= 0 then - raise Device_Error; + Raise_Device_Error (File); end if; end if; end Append_Set; @@ -174,7 +194,7 @@ package body System.File_IO is procedure Check_File_Open (File : AFCB_Ptr) is begin if File = null then - raise Status_Error; + raise Status_Error with "file not open"; end if; end Check_File_Open; @@ -185,9 +205,9 @@ package body System.File_IO is procedure Check_Read_Status (File : AFCB_Ptr) is begin if File = null then - raise Status_Error; + raise Status_Error with "file not open"; elsif File.Mode > Inout_File then - raise Mode_Error; + raise Mode_Error with "file not readable"; end if; end Check_Read_Status; @@ -198,9 +218,9 @@ package body System.File_IO is procedure Check_Write_Status (File : AFCB_Ptr) is begin if File = null then - raise Status_Error; + raise Status_Error with "file not open"; elsif File.Mode = In_File then - raise Mode_Error; + raise Mode_Error with "file not writable"; end if; end Check_Write_Status; @@ -212,6 +232,7 @@ package body System.File_IO is Close_Status : int := 0; Dup_Strm : Boolean := False; File : AFCB_Ptr renames File_Ptr.all; + Errno : Integer; begin -- Take a task lock, to protect the global data value Open_Files @@ -223,15 +244,14 @@ package body System.File_IO is -- Sever the association between the given file and its associated -- external file. The given file is left closed. Do not perform system - -- closes on the standard input, output and error files and also do - -- not attempt to close a stream that does not exist (signalled by a - -- null stream value -- happens in some error situations). + -- closes on the standard input, output and error files and also do not + -- attempt to close a stream that does not exist (signalled by a null + -- stream value -- happens in some error situations). - if not File.Is_System_File - and then File.Stream /= NULL_Stream - then - -- Do not do an fclose if this is a shared file and there is - -- at least one other instance of the stream that is open. + if not File.Is_System_File and then File.Stream /= NULL_Stream then + + -- Do not do an fclose if this is a shared file and there is at least + -- one other instance of the stream that is open. if File.Shared_Status = Yes then declare @@ -240,9 +260,7 @@ package body System.File_IO is begin P := Open_Files; while P /= null loop - if P /= File - and then File.Stream = P.Stream - then + if P /= File and then File.Stream = P.Stream then Dup_Strm := True; exit; end if; @@ -256,6 +274,10 @@ package body System.File_IO is if not Dup_Strm then Close_Status := fclose (File.Stream); + + if Close_Status /= 0 then + Errno := OS_Lib.Errno; + end if; end if; end if; @@ -284,7 +306,7 @@ package body System.File_IO is File := null; if Close_Status /= 0 then - raise Device_Error; + Raise_Device_Error (null, Errno); end if; SSL.Unlock_Task.all; @@ -301,11 +323,12 @@ package body System.File_IO is procedure Delete (File_Ptr : access AFCB_Ptr) is File : AFCB_Ptr renames File_Ptr.all; + begin Check_File_Open (File); if not File.Is_Regular_File then - raise Use_Error; + raise Use_Error with "cannot delete non-regular file"; end if; declare @@ -314,12 +337,12 @@ package body System.File_IO is begin Close (File_Ptr); - -- Now unlink the external file. Note that we use the full name - -- in this unlink, because the working directory may have changed - -- since we did the open, and we want to unlink the right file! + -- Now unlink the external file. Note that we use the full name in + -- this unlink, because the working directory may have changed since + -- we did the open, and we want to unlink the right file! if unlink (Filename'Address) = -1 then - raise Use_Error; + raise Use_Error with Errno_Message; end if; end; end Delete; @@ -347,13 +370,45 @@ package body System.File_IO is end if; end End_Of_File; + ------------------- + -- Errno_Message -- + ------------------- + + function Errno_Message (Errno : Integer := OS_Lib.Errno) return String is + pragma Warnings (Off); + function To_Chars_Ptr is + new Ada.Unchecked_Conversion (System.Address, chars_ptr); + -- On VMS, the compiler warns because System.Address is 64 bits, but + -- chars_ptr is 32 bits. It should be safe, though, because strerror + -- will return a 32-bit pointer. + pragma Warnings (On); + + Message : constant chars_ptr := + To_Chars_Ptr (CRTL.strerror (Errno)); + + begin + if Message = Null_Ptr then + return "errno =" & Errno'Img; + else + return Value (Message); + end if; + end Errno_Message; + + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String + is + begin + return Name & ": " & String'(Errno_Message (Errno)); + end Errno_Message; + -------------- -- Finalize -- -------------- - -- Note: we do not need to worry about locking against multiple task - -- access in this routine, since it is called only from the environment - -- task just before terminating execution. + -- Note: we do not need to worry about locking against multiple task access + -- in this routine, since it is called only from the environment task just + -- before terminating execution. procedure Finalize (V : in out File_IO_Clean_Up_Type) is pragma Warnings (Off, V); @@ -369,8 +424,8 @@ package body System.File_IO is SSL.Lock_Task.all; - -- First close all open files (the slightly complex form of this loop - -- is required because Close as a side effect nulls out its argument) + -- First close all open files (the slightly complex form of this loop is + -- required because Close as a side effect nulls out its argument). Fptr1 := Open_Files; while Fptr1 /= null loop @@ -379,9 +434,9 @@ package body System.File_IO is Fptr1 := Fptr2; end loop; - -- Now unlink all temporary files. We do not bother to free the - -- blocks because we are just about to terminate the program. We - -- also ignore any errors while attempting these unlink operations. + -- Now unlink all temporary files. We do not bother to free the blocks + -- because we are just about to terminate the program. We also ignore + -- any errors while attempting these unlink operations. while Temp_Files /= null loop Discard := unlink (Temp_Files.Name'Address); @@ -404,10 +459,8 @@ package body System.File_IO is begin Check_Write_Status (File); - if fflush (File.Stream) = 0 then - return; - else - raise Device_Error; + if fflush (File.Stream) /= 0 then + Raise_Device_Error (File); end if; end Flush; @@ -429,20 +482,20 @@ package body System.File_IO is -- you can reset to earlier points in the file. The caller must use the -- Append_Set routine to deal with the necessary positioning. - -- Note: in several cases, the fopen mode used allows reading and - -- writing, but the setting of the Ada mode is more restrictive. For - -- instance, Create in In_File mode uses "w+" which allows writing, - -- but the Ada mode In_File will cause any write operations to be - -- rejected with Mode_Error in any case. + -- Note: in several cases, the fopen mode used allows reading and writing, + -- but the setting of the Ada mode is more restrictive. For instance, + -- Create in In_File mode uses "w+" which allows writing, but the Ada mode + -- In_File will cause any write operations to be rejected with Mode_Error + -- in any case. - -- Note: for the Out_File/Open cases for other than the Direct_IO case, - -- an initial call will be made by the caller to first open the file in - -- "r" mode to be sure that it exists. The real open, in "w" mode, will - -- then destroy this file. This is peculiar, but that's what Ada semantics - -- require and the ACVT tests insist on! + -- Note: for the Out_File/Open cases for other than the Direct_IO case, an + -- initial call will be made by the caller to first open the file in "r" + -- mode to be sure that it exists. The real open, in "w" mode, will then + -- destroy this file. This is peculiar, but that's what Ada semantics + -- require and the ACATS tests insist on! - -- If text file translation is required, then either b or t is - -- added to the mode, depending on the setting of Text. + -- If text file translation is required, then either "b" or "t" is appended + -- to the mode, depending on the setting of Text. procedure Fopen_Mode (Mode : File_Mode; @@ -510,7 +563,7 @@ package body System.File_IO is function Form (File : AFCB_Ptr) return String is begin if File = null then - raise Status_Error; + raise Status_Error with "Form: file not open"; else return File.Form.all (1 .. File.Form'Length - 1); end if; @@ -523,8 +576,7 @@ package body System.File_IO is function Form_Boolean (Form : String; Keyword : String; - Default : Boolean) - return Boolean + Default : Boolean) return Boolean is V1, V2 : Natural; pragma Unreferenced (V2); @@ -542,7 +594,7 @@ package body System.File_IO is return False; else - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end Form_Boolean; @@ -553,8 +605,7 @@ package body System.File_IO is function Form_Integer (Form : String; Keyword : String; - Default : Integer) - return Integer + Default : Integer) return Integer is V1, V2 : Natural; V : Integer; @@ -570,13 +621,13 @@ package body System.File_IO is for J in V1 .. V2 loop if Form (J) not in '0' .. '9' then - raise Use_Error; + raise Use_Error with "invalid Form"; else V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); end if; if V > 999_999 then - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end loop; @@ -593,11 +644,9 @@ package body System.File_IO is Keyword : String; Start : out Natural; Stop : out Natural) - is + is Klen : constant Integer := Keyword'Length; - -- Start of processing for Form_Parameter - begin for J in Form'First + Klen .. Form'Last - 1 loop if Form (J) = '=' @@ -663,6 +712,7 @@ package body System.File_IO is begin status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); + -- No error checking??? end Make_Line_Buffered; --------------------- @@ -675,6 +725,7 @@ package body System.File_IO is begin status := setvbuf (File.Stream, Null_Address, IONBF, 0); + -- No error checking??? end Make_Unbuffered; ---------- @@ -684,7 +735,7 @@ package body System.File_IO is function Mode (File : AFCB_Ptr) return File_Mode is begin if File = null then - raise Status_Error; + raise Status_Error with "Mode: file not open"; else return File.Mode; end if; @@ -697,7 +748,7 @@ package body System.File_IO is function Name (File : AFCB_Ptr) return String is begin if File = null then - raise Status_Error; + raise Status_Error with "Name: file not open"; else return File.Name.all (1 .. File.Name'Length - 1); end if; @@ -724,7 +775,7 @@ package body System.File_IO is procedure Tmp_Name (Buffer : Address); pragma Import (C, Tmp_Name, "__gnat_tmp_name"); - -- set buffer (a String address) with a temporary filename + -- Set buffer (a String address) with a temporary filename Stream : FILEs := C_Stream; -- Stream which we open in response to this request @@ -744,9 +795,9 @@ package body System.File_IO is -- Indicates temporary file case Namelen : constant Integer := max_path_len; - -- Length required for file name, not including final ASCII.NUL - -- Note that we used to reference L_tmpnam here, which is not - -- reliable since __gnat_tmp_name does not always use tmpnam. + -- Length required for file name, not including final ASCII.NUL. + -- Note that we used to reference L_tmpnam here, which is not reliable + -- since __gnat_tmp_name does not always use tmpnam. Namestr : aliased String (1 .. Namelen + 1); -- Name as given or temporary file name with ASCII.NUL appended @@ -758,12 +809,12 @@ package body System.File_IO is Full_Name_Len : Integer; -- Length of name actually stored in Fullname - Encoding : System.CRTL.Filename_Encoding; + Encoding : CRTL.Filename_Encoding; -- Filename encoding specified into the form parameter begin if File_Ptr /= null then - raise Status_Error; + raise Status_Error with "file already open"; end if; -- Acquire form string, setting required NUL terminator @@ -797,7 +848,7 @@ package body System.File_IO is Shared := No; else - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end; @@ -810,16 +861,16 @@ package body System.File_IO is Form_Parameter (Formstr, "encoding", V1, V2); if V1 = 0 then - Encoding := System.CRTL.Unspecified; + Encoding := CRTL.Unspecified; elsif Formstr (V1 .. V2) = "utf8" then - Encoding := System.CRTL.UTF8; + Encoding := CRTL.UTF8; elsif Formstr (V1 .. V2) = "8bits" then - Encoding := System.CRTL.ASCII_8bits; + Encoding := CRTL.ASCII_8bits; else - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end; @@ -851,13 +902,13 @@ package body System.File_IO is if Tempfile then if not Creat then - raise Name_Error; + raise Name_Error with "opening temp file without creating it"; end if; Tmp_Name (Namestr'Address); if Namestr (1) = ASCII.NUL then - raise Use_Error; + raise Use_Error with "invalid temp file name"; end if; -- Chain to temp file list, ensuring thread safety with a lock @@ -878,7 +929,7 @@ package body System.File_IO is else if Name'Length > Namelen then - raise Name_Error; + raise Name_Error with "file name too long"; end if; Namestr (1 .. Name'Length) := Name; @@ -890,7 +941,7 @@ package body System.File_IO is full_name (Namestr'Address, Fullname'Address); if Fullname (1) = ASCII.NUL then - raise Use_Error; + raise Use_Error with Errno_Message (Name); end if; Full_Name_Len := 1; @@ -902,7 +953,7 @@ package body System.File_IO is -- Fullname is generated by calling system's full_name. The problem -- is, full_name does nothing about the casing, so a file name - -- comparison may generally speaking not be valid on non-case + -- comparison may generally speaking not be valid on non-case- -- sensitive systems, and in particular we get unexpected failures -- on Windows/Vista because of this. So we use s-casuti to force -- the name to lower case. @@ -911,8 +962,8 @@ package body System.File_IO is To_Lower (Fullname (1 .. Full_Name_Len)); end if; - -- If Shared=None or Shared=Yes, then check for the existence - -- of another file with exactly the same full name. + -- If Shared=None or Shared=Yes, then check for the existence of + -- another file with exactly the same full name. if Shared /= No then declare @@ -937,7 +988,7 @@ package body System.File_IO is if Shared = None or else P.Shared_Status = None then - raise Use_Error; + raise Use_Error with "reopening shared file"; -- If both files have Shared=Yes, then we acquire the -- stream from the located file to use as our stream. @@ -983,7 +1034,7 @@ package body System.File_IO is if not Creat and then Fopstr (1) /= 'r' then if file_exists (Namestr'Address) = 0 then - raise Name_Error; + raise Name_Error with Errno_Message (Name); end if; end if; @@ -1007,10 +1058,8 @@ package body System.File_IO is -- Should we raise Device_Error for ENOSPC??? declare - subtype Cint is Interfaces.C.int; - function Is_File_Not_Found_Error - (Errno_Value : Cint) return Cint; + (Errno_Value : Integer) return Integer; -- Non-zero when the given errno value indicates a non- -- existing file. @@ -1018,13 +1067,13 @@ package body System.File_IO is (C, Is_File_Not_Found_Error, "__gnat_is_file_not_found_error"); + Errno : constant Integer := OS_Lib.Errno; + Message : constant String := Errno_Message (Name, Errno); begin - if - Is_File_Not_Found_Error (Cint (System.OS_Lib.Errno)) /= 0 - then - raise Name_Error; + if Is_File_Not_Found_Error (Errno) /= 0 then + raise Name_Error with Message; else - raise Use_Error; + raise Use_Error with Message; end if; end; end if; @@ -1032,8 +1081,8 @@ package body System.File_IO is end if; -- Stream has been successfully located or opened, so now we are - -- committed to completing the opening of the file. Allocate block - -- on heap and fill in its fields. + -- committed to completing the opening of the file. Allocate block on + -- heap and fill in its fields. File_Ptr := AFCB_Allocate (Dummy_FCB); @@ -1053,6 +1102,23 @@ package body System.File_IO is Append_Set (File_Ptr); end Open; + ------------------------ + -- Raise_Device_Error -- + ------------------------ + + procedure Raise_Device_Error + (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno) + is + begin + -- Clear error status so that the same error is not reported twice + + if File /= null then + clearerr (File.Stream); + end if; + + raise Device_Error with Errno_Message (Errno); + end Raise_Device_Error; + -------------- -- Read_Buf -- -------------- @@ -1067,13 +1133,13 @@ package body System.File_IO is return; elsif ferror (File.Stream) /= 0 then - raise Device_Error; + Raise_Device_Error (File); elsif Nread = 0 then raise End_Error; else -- 0 < Nread < Siz - raise Data_Error; + raise Data_Error with "not enough data read"; end if; end Read_Buf; @@ -1088,7 +1154,7 @@ package body System.File_IO is Count := fread (Buf, 1, Siz, File.Stream); if Count = 0 and then ferror (File.Stream) /= 0 then - raise Device_Error; + Raise_Device_Error (File); end if; end Read_Buf; @@ -1105,9 +1171,9 @@ package body System.File_IO is Reset (File_Ptr, File.Mode); end Reset; - -- The reset with a change in mode is done using freopen, and is - -- not permitted except for regular files (since otherwise there - -- is no name for the freopen, and in any case it seems meaningless) + -- The reset with a change in mode is done using freopen, and is not + -- permitted except for regular files (since otherwise there is no name for + -- the freopen, and in any case it seems meaningless). procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is File : AFCB_Ptr renames File_Ptr.all; @@ -1120,25 +1186,29 @@ package body System.File_IO is -- file that is not a regular file, or for a system file. Note that we -- allow the "change" of mode if it is not in fact doing a change. - if Mode /= File.Mode - and then (File.Shared_Status = Yes - or else File.Name'Length <= 1 - or else File.Is_System_File - or else not File.Is_Regular_File) - then - raise Use_Error; + if Mode /= File.Mode then + if File.Shared_Status = Yes then + raise Use_Error with "cannot change mode of shared file"; + elsif File.Name'Length <= 1 then + raise Use_Error with "cannot change mode of temp file"; + elsif File.Is_System_File then + raise Use_Error with "cannot change mode of system file"; + elsif not File.Is_Regular_File then + raise Use_Error with "cannot change mode of non-regular file"; + end if; + end if; - -- For In_File or Inout_File for a regular file, we can just do a - -- rewind if the mode is unchanged, which is more efficient than - -- doing a full reopen. + -- For In_File or Inout_File for a regular file, we can just do a rewind + -- if the mode is unchanged, which is more efficient than doing a full + -- reopen. - elsif Mode = File.Mode + if Mode = File.Mode and then Mode <= Inout_File then rewind (File.Stream); - -- Here the change of mode is permitted, we do it by reopening the - -- file in the new mode and replacing the stream with a new stream. + -- Here the change of mode is permitted, we do it by reopening the file + -- in the new mode and replacing the stream with a new stream. else Fopen_Mode @@ -1164,17 +1234,17 @@ package body System.File_IO is procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is begin - -- Note: for most purposes, the Siz and 1 parameters in the fwrite - -- call could be reversed, but on VMS, this is a better choice, since - -- for some file formats, reversing the parameters results in records - -- of one byte each. + -- Note: for most purposes, the Siz and 1 parameters in the fwrite call + -- could be reversed, but on VMS, this is a better choice, since for + -- some file formats, reversing the parameters results in records of one + -- byte each. SSL.Abort_Defer.all; if fwrite (Buf, Siz, 1, File.Stream) /= 1 then if Siz /= 0 then SSL.Abort_Undefer.all; - raise Device_Error; + Raise_Device_Error (File); end if; end if; diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads index e3a9abe0980..5ee0c5b99d9 100644 --- a/gcc/ada/s-fileio.ads +++ b/gcc/ada/s-fileio.ads @@ -125,8 +125,8 @@ package System.File_IO is -- if used with temporary files or standard files. function Form (File : FCB.AFCB_Ptr) return String; - -- Returns the form as supplied by create, open or reset - -- The string is normalized to all lower case letters. + -- Returns the form as supplied by create, open or reset The string is + -- normalized to all lower case letters. function Is_Open (File : FCB.AFCB_Ptr) return Boolean; -- Determines if file is open or not @@ -145,25 +145,25 @@ package System.File_IO is -- not opened in the normal manner. Note that the caller is responsible -- for task lock out to protect the global data structures if this is -- necessary (it is needed for the calls from within this unit itself, - -- but not required for the calls from Text_IO and Wide_Text_IO that - -- are made during elaboration of the environment task). + -- but not required for the calls from Text_IO and [Wide_]Wide_Text_IO + -- that are made during elaboration of the environment task). procedure Check_File_Open (File : FCB.AFCB_Ptr); - -- If the current file is not open, then Status_Error is raised. - -- Otherwise control returns normally (with File pointing to the - -- control block for the open file. + -- If the current file is not open, then Status_Error is raised. Otherwise + -- control returns normally (with File pointing to the control block for + -- the open file. procedure Check_Read_Status (File : FCB.AFCB_Ptr); - -- If the current file is not open, then Status_Error is raised. If - -- the file is open, then the mode is checked to ensure that reading - -- is permitted, and if not Mode_Error is raised, otherwise control - -- returns normally. + -- If the current file is not open, then Status_Error is raised. If the + -- file is open, then the mode is checked to make sure that reading is + -- permitted, and if not Mode_Error is raised, otherwise control returns + -- normally. procedure Check_Write_Status (File : FCB.AFCB_Ptr); - -- If the current file is not open, then Status_Error is raised. If - -- the file is open, then the mode is checked to ensure that writing - -- is permitted, and if not Mode_Error is raised, otherwise control - -- returns normally. + -- If the current file is not open, then Status_Error is raised. If the + -- file is open, then the mode is checked to ensure that writing is + -- permitted, and if not Mode_Error is raised, otherwise control returns + -- normally. function End_Of_File (File : FCB.AFCB_Ptr) return Boolean; -- File must be opened in read mode. True is returned if the stream is @@ -171,30 +171,28 @@ package System.File_IO is -- The position of the stream is not affected. procedure Flush (File : FCB.AFCB_Ptr); - -- Flushes the stream associated with the given file. The file must be - -- open and in write mode (if not, an appropriate exception is raised) + -- Flushes the stream associated with the given file. The file must be open + -- and in write mode (if not, an appropriate exception is raised) function Form_Boolean (Form : String; Keyword : String; - Default : Boolean) - return Boolean; - -- Searches form string for an entry of the form Keyword=xx where xx is - -- either Yes/No or y/n. Returns True if Yes or Y is found, False if No - -- or N is found. If the keyword parameter is not found, returns the - -- value given as Default. May raise Use_Error if a form string syntax - -- error is detected. Keyword and Form must be in lower case. + Default : Boolean) return Boolean; + -- Searches form string for an entry of the form keyword=xx where xx is + -- either yes/no or y/n. Returns True if yes or y is found, False if no or + -- n is found. If the keyword parameter is not found, returns the value + -- given as Default. May raise Use_Error if a form string syntax error is + -- detected. Keyword and Form must be in lower case. function Form_Integer (Form : String; Keyword : String; - Default : Integer) - return Integer; - -- Searches form string for an entry of the form Keyword=xx where xx is - -- an unsigned decimal integer in the range 0 to 999_999. Returns this - -- integer value if it is found. If the keyword parameter is not found, - -- returns the value given as Default. Raise Use_Error if a form string - -- syntax error is detected. Keyword and Form must be in lower case. + Default : Integer) return Integer; + -- Searches form string for an entry of the form Keyword=xx where xx is an + -- unsigned decimal integer in the range 0 to 999_999. Returns this integer + -- value if it is found. If the keyword parameter is not found, returns the + -- value given as Default. Raise Use_Error if a form string syntax error is + -- detected. Keyword and Form must be in lower case. procedure Form_Parameter (Form : String; @@ -221,22 +219,22 @@ package System.File_IO is Buf : Address; Siz : Interfaces.C_Streams.size_t; Count : out Interfaces.C_Streams.size_t); - -- Reads Siz bytes from File.Stream into Buf. The caller has checked - -- that the file is open in read mode. Device Error is raised if an error + -- Reads Siz bytes from File.Stream into Buf. The caller has checked that + -- the file is open in read mode. Device Error is raised if an error -- occurs. Count is the actual number of bytes read, which may be less -- than Siz if the end of file is encountered. procedure Append_Set (File : FCB.AFCB_Ptr); - -- If the mode of the file is Append_File, then the file is positioned - -- at the end of file using fseek, otherwise this call has no effect. + -- If the mode of the file is Append_File, then the file is positioned at + -- the end of file using fseek, otherwise this call has no effect. procedure Write_Buf (File : FCB.AFCB_Ptr; Buf : Address; Siz : Interfaces.C_Streams.size_t); - -- Writes size_t bytes to File.Stream from Buf. The caller has checked - -- that the file is open in write mode. Raises Device_Error if the - -- complete buffer cannot be written. + -- Writes size_t bytes to File.Stream from Buf. The caller has checked that + -- the file is open in write mode. Raises Device_Error if the complete + -- buffer cannot be written. procedure Make_Unbuffered (File : FCB.AFCB_Ptr); diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 0f2081a0e87..f7341367688 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -77,8 +77,17 @@ package body System.OS_Lib is ----------------------- function Args_Length (Args : Argument_List) return Natural; - -- Returns total number of characters needed to create a string - -- of all Args terminated by ASCII.NUL characters + -- Returns total number of characters needed to create a string of all Args + -- terminated by ASCII.NUL characters. + + procedure Create_Temp_File_Internal + (FD : out File_Descriptor; + Name : out String_Access; + Stdout : Boolean); + -- Internal routine to implement two Create_Temp_File routines. If Stdout + -- is set to True the created descriptor is stdout-compatible, otherwise + -- it might not be depending on the OS (VMS is one example). The first two + -- parameters are as in Create_Temp_File. function C_String_Length (S : Address) return Integer; -- Returns the length of a C string. Does check for null address @@ -749,10 +758,57 @@ package body System.OS_Lib is (FD : out File_Descriptor; Name : out String_Access) is + begin + Create_Temp_File_Internal (FD, Name, Stdout => False); + end Create_Temp_File; + + procedure Create_Temp_Output_File + (FD : out File_Descriptor; + Name : out String_Access) + is + begin + Create_Temp_File_Internal (FD, Name, Stdout => True); + end Create_Temp_Output_File; + + ------------------------------- + -- Create_Temp_File_Internal -- + ------------------------------- + + procedure Create_Temp_File_Internal + (FD : out File_Descriptor; + Name : out String_Access; + Stdout : Boolean) + is Pos : Positive; Attempts : Natural := 0; Current : String (Current_Temp_File_Name'Range); + --------------------------------- + -- Create_New_Output_Text_File -- + --------------------------------- + + function Create_New_Output_Text_File + (Name : String) return File_Descriptor; + -- Similar to Create_Output_Text_File, except it fails if the file + -- already exists. We need this behavior to ensure we don't accidentally + -- open a temp file that has just been created by a concurrently running + -- process. There is no point exposing this function, as it's generally + -- not particularly useful. + + function Create_New_Output_Text_File + (Name : String) return File_Descriptor is + function C_Create_File + (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_New_Output_Text_File; + begin -- Loop until a new temp file can be created @@ -814,7 +870,11 @@ package body System.OS_Lib is -- Attempt to create the file - FD := Create_New_File (Current, Binary); + if Stdout then + FD := Create_New_Output_Text_File (Current); + else + FD := Create_New_File (Current, Binary); + end if; if FD /= Invalid_FD then Name := new String'(Current); @@ -836,7 +896,7 @@ package body System.OS_Lib is end if; end if; end loop File_Loop; - end Create_Temp_File; + end Create_Temp_File_Internal; ----------------- -- Delete_File -- diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index b77b3f01266..341a27953ab 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -245,9 +245,26 @@ package System.OS_Lib is Name : out String_Access); -- Create and open for writing a temporary file in the current working -- directory. The name of the file and the File Descriptor are returned. - -- No mode parameter is provided. Since this is a temporary file, there is - -- no point in doing text translation on it. It is the responsibility of - -- the caller to deallocate the access value returned in Name. + -- It is the responsibility of the caller to deallocate the access value + -- returned in Name. + -- + -- The file is opened in binary mode (no text translation). + -- + -- This procedure will always succeed if the current working directory is + -- writable. If the current working directory is not writable, then + -- Invalid_FD is returned for the file descriptor and null for the Name. + -- There is no race condition problem between processes trying to create + -- temp files at the same time in the same directory. + + procedure Create_Temp_Output_File + (FD : out File_Descriptor; + Name : out String_Access); + -- Create and open for writing a temporary file in the current working + -- directory suitable to redirect standard output. The name of the file and + -- the File Descriptor are returned. It is the responsibility of the caller + -- to deallocate the access value returned in Name. + -- + -- The file is opened in text mode -- -- This procedure will always succeed if the current working directory is -- writable. If the current working directory is not writable, then diff --git a/gcc/ada/s-osinte-rtems.ads b/gcc/ada/s-osinte-rtems.ads index 5e3d9192014..70e4a27e0a4 100644 --- a/gcc/ada/s-osinte-rtems.ads +++ b/gcc/ada/s-osinte-rtems.ads @@ -625,6 +625,7 @@ private process_shared : int; prio_ceiling : int; protocol : int; + mutex_type : int; recursive : int; end record; pragma Convention (C, pthread_mutexattr_t); diff --git a/gcc/ada/s-stchop-rtems.adb b/gcc/ada/s-stchop-rtems.adb index 615950e7fee..ac0cfd0f489 100644 --- a/gcc/ada/s-stchop-rtems.adb +++ b/gcc/ada/s-stchop-rtems.adb @@ -80,8 +80,9 @@ package body System.Stack_Checking.Operations is is pragma Unreferenced (Stack_Address); - -- RTEMS has a routine to check this. So use it. - function rtems_stack_checker_is_blown return Interfaces.C.int; + -- RTEMS has a routine to check if the stack is blown. + -- It returns a C99 bool. + function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; pragma Import (C, rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index af29d9a3fdc..ad01bd18117 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -509,9 +509,8 @@ package body Sem_Aggr is ------------------------ function Array_Aggr_Subtype - (N : Node_Id; - Typ : Entity_Id) - return Entity_Id + (N : Node_Id; + Typ : Entity_Id) return Entity_Id is Aggr_Dimension : constant Pos := Number_Dimensions (Typ); -- Number of aggregate index dimensions @@ -618,7 +617,7 @@ package body Sem_Aggr is -- Array_Aggr_Subtype variables Itype : Entity_Id; - -- the final itype of the overall aggregate + -- The final itype of the overall aggregate Index_Constraints : constant List_Id := New_List; -- The list of index constraints of the aggregate itype @@ -626,8 +625,8 @@ package body Sem_Aggr is -- Start of processing for Array_Aggr_Subtype begin - -- Make sure that the list of index constraints is properly attached - -- to the tree, and then collect the aggregate bounds. + -- Make sure that the list of index constraints is properly attached to + -- the tree, and then collect the aggregate bounds. Set_Parent (Index_Constraints, N); Collect_Aggr_Bounds (N, 1); @@ -672,13 +671,13 @@ package body Sem_Aggr is Itype := Create_Itype (E_Array_Subtype, N); - Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); - Set_Convention (Itype, Convention (Typ)); - Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); - Set_Etype (Itype, Base_Type (Typ)); - Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); - Set_Is_Aliased (Itype, Is_Aliased (Typ)); - Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); + Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); + Set_Convention (Itype, Convention (Typ)); + Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); + Set_Etype (Itype, Base_Type (Typ)); + Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); + Set_Is_Aliased (Itype, Is_Aliased (Typ)); + Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); Copy_Suppress_Status (Index_Check, Typ, Itype); Copy_Suppress_Status (Length_Check, Typ, Itype); @@ -688,22 +687,23 @@ package body Sem_Aggr is Set_Is_Internal (Itype, True); -- A simple optimization: purely positional aggregates of static - -- components should be passed to gigi unexpanded whenever possible, - -- and regardless of the staticness of the bounds themselves. Subse- - -- quent checks in exp_aggr verify that type is not packed, etc. + -- components should be passed to gigi unexpanded whenever possible, and + -- regardless of the staticness of the bounds themselves. Subsequent + -- checks in exp_aggr verify that type is not packed, etc. Set_Size_Known_At_Compile_Time (Itype, Is_Fully_Positional and then Comes_From_Source (N) and then Size_Known_At_Compile_Time (Component_Type (Typ))); - -- We always need a freeze node for a packed array subtype, so that - -- we can build the Packed_Array_Type corresponding to the subtype. - -- If expansion is disabled, the packed array subtype is not built, - -- and we must not generate a freeze node for the type, or else it - -- will appear incomplete to gigi. + -- We always need a freeze node for a packed array subtype, so that we + -- can build the Packed_Array_Type corresponding to the subtype. If + -- expansion is disabled, the packed array subtype is not built, and we + -- must not generate a freeze node for the type, or else it will appear + -- incomplete to gigi. - if Is_Packed (Itype) and then not In_Spec_Expression + if Is_Packed (Itype) + and then not In_Spec_Expression and then Expander_Active then Freeze_Itype (Itype, N); @@ -728,11 +728,10 @@ package body Sem_Aggr is Component_Elmt : Elmt_Id; begin - -- All the components of List are matched against Component and - -- a count is maintained of possible misspellings. When at the - -- end of the analysis there are one or two (not more!) possible - -- misspellings, these misspellings will be suggested as - -- possible correction. + -- All the components of List are matched against Component and a count + -- is maintained of possible misspellings. When at the end of the + -- the analysis there are one or two (not more!) possible misspellings, + -- these misspellings will be suggested as possible correction. Component_Elmt := First_Elmt (Elements); while Nr_Of_Suggestions <= Max_Suggestions @@ -872,7 +871,7 @@ package body Sem_Aggr is Append_To (Exprs, C_Node); P := P + 1; - -- something special for wide strings ??? + -- Something special for wide strings??? end loop; New_N := Make_Aggregate (Loc, Expressions => Exprs); @@ -904,9 +903,9 @@ package body Sem_Aggr is end if; -- Check for aggregates not allowed in configurable run-time mode. - -- We allow all cases of aggregates that do not come from source, - -- since these are all assumed to be small (e.g. bounds of a string - -- literal). We also allow aggregates of types we know to be small. + -- We allow all cases of aggregates that do not come from source, since + -- these are all assumed to be small (e.g. bounds of a string literal). + -- We also allow aggregates of types we know to be small. if not Support_Aggregates_On_Target and then Comes_From_Source (N) @@ -941,10 +940,10 @@ package body Sem_Aggr is -- First a special test, for the case of a positional aggregate -- of characters which can be replaced by a string literal. - -- Do not perform this transformation if this was a string literal - -- to start with, whose components needed constraint checks, or if - -- the component type is non-static, because it will require those - -- checks and be transformed back into an aggregate. + -- Do not perform this transformation if this was a string literal to + -- start with, whose components needed constraint checks, or if the + -- component type is non-static, because it will require those checks + -- and be transformed back into an aggregate. if Number_Dimensions (Typ) = 1 and then Is_Standard_Character_Type (Component_Type (Typ)) @@ -989,10 +988,10 @@ package body Sem_Aggr is Aggr_Resolved : Boolean; Aggr_Typ : constant Entity_Id := Etype (Typ); - -- This is the unconstrained array type, which is the type - -- against which the aggregate is to be resolved. Typ itself - -- is the array type of the context which may not be the same - -- subtype as the subtype for the final aggregate. + -- This is the unconstrained array type, which is the type against + -- which the aggregate is to be resolved. Typ itself is the array + -- type of the context which may not be the same subtype as the + -- subtype for the final aggregate. begin -- In the following we determine whether an others choice is @@ -1002,11 +1001,11 @@ package body Sem_Aggr is -- choice is not allowed. -- If expansion is disabled (generic context, or semantics-only - -- mode) actual subtypes cannot be constructed, and the type of - -- an object may be its unconstrained nominal type. However, if - -- the context is an assignment, we assume that "others" is - -- allowed, because the target of the assignment will have a - -- constrained subtype when fully compiled. + -- mode) actual subtypes cannot be constructed, and the type of an + -- object may be its unconstrained nominal type. However, if the + -- context is an assignment, we assume that "others" is allowed, + -- because the target of the assignment will have a constrained + -- subtype when fully compiled. -- Note that there is no node for Explicit_Actual_Parameter. -- To test for this context we therefore have to test for node @@ -1014,7 +1013,7 @@ package body Sem_Aggr is -- formal parameter. Consequently we also need to test for -- N_Procedure_Call_Statement or N_Function_Call. - Set_Etype (N, Aggr_Typ); -- may be overridden later on + Set_Etype (N, Aggr_Typ); -- May be overridden later on if Is_Constrained (Typ) and then (Pkind = N_Assignment_Statement or else @@ -1080,10 +1079,10 @@ package body Sem_Aggr is Error_Msg_N ("illegal context for aggregate", N); end if; - -- If we can determine statically that the evaluation of the - -- aggregate raises Constraint_Error, then replace the - -- aggregate with an N_Raise_Constraint_Error node, but set the - -- Etype to the right aggregate subtype. Gigi needs this. + -- If we can determine statically that the evaluation of the aggregate + -- raises Constraint_Error, then replace the aggregate with an + -- N_Raise_Constraint_Error node, but set the Etype to the right + -- aggregate subtype. Gigi needs this. if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); @@ -1115,13 +1114,13 @@ package body Sem_Aggr is Index_Typ : constant Entity_Id := Etype (Index); Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ); Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ); - -- The type of the index corresponding to the array sub-aggregate - -- along with its low and upper bounds + -- The type of the index corresponding to the array sub-aggregate along + -- with its low and upper bounds. Index_Base : constant Entity_Id := Base_Type (Index_Typ); Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base); Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base); - -- ditto for the base type + -- Ditto for the base type function Add (Val : Uint; To : Node_Id) return Node_Id; -- Creates a new expression node where Val is added to expression To. @@ -1131,16 +1130,16 @@ package body Sem_Aggr is procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); -- Checks that AH (the upper bound of an array aggregate) is <= BH -- (the upper bound of the index base type). If the check fails a - -- warning is emitted, the Raises_Constraint_Error Flag of N is set, + -- warning is emitted, the Raises_Constraint_Error flag of N is set, -- and AH is replaced with a duplicate of BH. procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); -- Checks that range AL .. AH is compatible with range L .. H. Emits a - -- warning if not and sets the Raises_Constraint_Error Flag in N. + -- warning if not and sets the Raises_Constraint_Error flag in N. procedure Check_Length (L, H : Node_Id; Len : Uint); -- Checks that range L .. H contains at least Len elements. Emits a - -- warning if not and sets the Raises_Constraint_Error Flag in N. + -- warning if not and sets the Raises_Constraint_Error flag in N. function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean; -- Returns True if range L .. H is dynamic or null @@ -1155,11 +1154,10 @@ package body Sem_Aggr is Single_Elmt : Boolean) return Boolean; -- Resolves aggregate expression Expr. Returns False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be - -- used to initialize several array aggregate elements (this can - -- happen for discrete choices such as "L .. H => Expr" or the others - -- choice). In this event we do not resolve Expr unless expansion is - -- disabled. To know why, see the DELAYED COMPONENT RESOLUTION - -- note above. + -- used to initialize several array aggregate elements (this can happen + -- for discrete choices such as "L .. H => Expr" or the others choice). + -- In this event we do not resolve Expr unless expansion is disabled. + -- To know why, see the DELAYED COMPONENT RESOLUTION note above. --------- -- Add -- @@ -1642,8 +1640,8 @@ package body Sem_Aggr is -- discrete association Prev_Nb_Discrete_Choices : Nat; - -- Used to keep track of the number of discrete choices - -- in the current association. + -- Used to keep track of the number of discrete choices in the + -- current association. begin -- STEP 2 (A): Check discrete choices validity @@ -1690,9 +1688,8 @@ package body Sem_Aggr is Check_Non_Static_Context (Choice); -- Do not range check a choice. This check is redundant - -- since this test is already performed when we check - -- that the bounds of the array aggregate are within - -- range. + -- since this test is already done when we check that the + -- bounds of the array aggregate are within range. Set_Do_Range_Check (Choice, False); end if; @@ -1754,13 +1751,13 @@ package body Sem_Aggr is end if; -- Ada 2005 (AI-287): In case of default initialized component - -- we delay the resolution to the expansion phase + -- we delay the resolution to the expansion phase. if Box_Present (Assoc) then - -- Ada 2005 (AI-287): In case of default initialization - -- of a component the expander will generate calls to - -- the corresponding initialization subprogram. + -- Ada 2005 (AI-287): In case of default initialization of a + -- component the expander will generate calls to the + -- corresponding initialization subprogram. null; @@ -1773,8 +1770,8 @@ package body Sem_Aggr is -- We differentiate here two cases because the expression may -- not be decorated. For example, the analysis and resolution - -- of the expression associated with the others choice will - -- be done later with the full aggregate. In such case we + -- of the expression associated with the others choice will be + -- done later with the full aggregate. In such case we -- duplicate the expression tree to analyze the copy and -- perform the required check. @@ -1810,7 +1807,7 @@ package body Sem_Aggr is end loop; -- If aggregate contains more than one choice then these must be - -- static. Sort them and check that they are contiguous + -- static. Sort them and check that they are contiguous. if Nb_Discrete_Choices > 1 then Sort_Case_Table (Table); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d4f4f51dc33..e37b216ca45 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -667,8 +667,8 @@ package body Sem_Attr is end loop; if Present (Q) then - Set_Has_Per_Object_Constraint ( - Defining_Identifier (Q), True); + Set_Has_Per_Object_Constraint + (Defining_Identifier (Q), True); end if; end; @@ -1991,9 +1991,10 @@ package body Sem_Attr is -- entry wrappers, the attributes Count, Caller and AST_Entry require -- a context check - if Aname = Name_Count - or else Aname = Name_Caller - or else Aname = Name_AST_Entry + if Ada_Version >= Ada_05 + and then (Aname = Name_Count + or else Aname = Name_Caller + or else Aname = Name_AST_Entry) then declare Count : Natural := 0; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 5de995d984b..840214d2c64 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -61,17 +61,24 @@ package body Sem_Case is procedure Check_Choices (Choice_Table : in out Sort_Choice_Table_Type; Bounds_Type : Entity_Id; + Subtyp : Entity_Id; Others_Present : Boolean; - Msg_Sloc : Source_Ptr); + Case_Node : Node_Id); -- This is the procedure which verifies that a set of case alternatives -- or record variant choices has no duplicates, and covers the range -- specified by Bounds_Type. Choice_Table contains the discrete choices -- to check. These must start at position 1. + -- -- Furthermore Choice_Table (0) must exist. This element is used by -- the sorting algorithm as a temporary. Others_Present is a flag -- indicating whether or not an Others choice is present. Finally -- Msg_Sloc gives the source location of the construct containing the -- choices in the Choice_Table. + -- + -- Bounds_Type is the type whose range must be covered by the alternatives + -- + -- Subtyp is the subtype of the expression. If its bounds are non-static + -- the alternatives must cover its base type. function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; -- Given a Pos value of enumeration type Ctype, returns the name @@ -94,11 +101,17 @@ package body Sem_Case is ------------------- procedure Check_Choices - (Choice_Table : in out Sort_Choice_Table_Type; + (Choice_Table : in out Sort_Choice_Table_Type; Bounds_Type : Entity_Id; + Subtyp : Entity_Id; Others_Present : Boolean; - Msg_Sloc : Source_Ptr) + Case_Node : Node_Id) is + procedure Explain_Non_Static_Bound; + -- Called when we find a non-static bound, requiring the base type to + -- be covered. Provides where possible a helpful explanation of why the + -- bounds are non-static, since this is not always obvious. + function Lt_Choice (C1, C2 : Natural) return Boolean; -- Comparison routine for comparing Choice_Table entries. Use the lower -- bound of each Choice as the key. @@ -136,6 +149,8 @@ package body Sem_Case is end Issue_Msg; procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is + Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); + begin -- In some situations, we call this with a null range, and -- obviously we don't want to complain in this case! @@ -191,17 +206,65 @@ package body Sem_Case is Choice_Table (Nat (To)) := Choice_Table (Nat (From)); end Move_Choice; + ------------------------------ + -- Explain_Non_Static_Bound -- + ------------------------------ + + procedure Explain_Non_Static_Bound is + Expr : Node_Id; + + begin + if Nkind (Case_Node) = N_Variant_Part then + Expr := Name (Case_Node); + else + Expr := Expression (Case_Node); + end if; + + if Bounds_Type /= Subtyp then + + -- If the case is a variant part, the expression is given by + -- the discriminant itself, and the bounds are the culprits. + + if Nkind (Case_Node) = N_Variant_Part then + Error_Msg_NE + ("bounds of & are not static," & + " alternatives must cover base type", Expr, Expr); + + -- If this is a case statement, the expression may be + -- non-static or else the subtype may be at fault. + + elsif Is_Entity_Name (Expr) then + Error_Msg_NE + ("bounds of & are not static," & + " alternatives must cover base type", Expr, Expr); + + else + Error_Msg_N ("subtype of expression is not static," & + " alternatives must cover base type!", Expr); + end if; + + -- Otherwise the expression is not static, even if the bounds of the + -- type are, or else there are missing alternatives. If both, the + -- additional information may be redundant but harmless. + + elsif not Is_Entity_Name (Expr) then + Error_Msg_N + ("subtype of expression is not static, " & + "alternatives must cover base type!", Expr); + end if; + end Explain_Non_Static_Bound; + -- Variables local to Check_Choices - Choice : Node_Id; - Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); - Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); + Choice : Node_Id; + Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); + Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); Prev_Choice : Node_Id; - Hi : Uint; - Lo : Uint; - Prev_Hi : Uint; + Hi : Uint; + Lo : Uint; + Prev_Hi : Uint; -- Start of processing for Check_Choices @@ -216,6 +279,7 @@ package body Sem_Case is if not Others_Present then Issue_Msg (Bounds_Lo, Bounds_Hi); end if; + return; end if; @@ -227,6 +291,13 @@ package body Sem_Case is if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then Issue_Msg (Bounds_Lo, Lo - 1); + + -- If values are missing outside of the subtype, add explanation. + -- No additional message if only one value is missing. + + if Expr_Value (Bounds_Lo) < Lo - 1 then + Explain_Non_Static_Bound; + end if; end if; for J in 2 .. Choice_Table'Last loop @@ -254,6 +325,10 @@ package body Sem_Case is if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then Issue_Msg (Hi + 1, Bounds_Hi); + + if Expr_Value (Bounds_Hi) > Hi + 1 then + Explain_Non_Static_Bound; + end if; end if; end Check_Choices; @@ -546,27 +621,27 @@ package body Sem_Case is Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices); Choice_Type : constant Entity_Id := Base_Type (Subtyp); - -- The actual type against which the discrete choices are - -- resolved. Note that this type is always the base type not the - -- subtype of the ruling expression, index or discriminant. + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. Bounds_Type : Entity_Id; - -- The type from which are derived the bounds of the values - -- covered by the discrete choices (see 3.8.1 (4)). If a discrete - -- choice specifies a value outside of these bounds we have an error. + -- The type from which are derived the bounds of the values covered + -- by the discrete choices (see 3.8.1 (4)). If a discrete choice + -- specifies a value outside of these bounds we have an error. Bounds_Lo : Uint; Bounds_Hi : Uint; -- The actual bounds of the above type Expected_Type : Entity_Id; - -- The expected type of each choice. Equal to Choice_Type, except - -- if the expression is universal, in which case the choices can - -- be of any integer type. + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. Alt : Node_Id; -- A case statement alternative or a variant in a record type - -- declaration + -- declaration. Choice : Node_Id; Kind : Node_Kind; @@ -576,9 +651,9 @@ package body Sem_Case is -- Remember others choice if it is present (empty otherwise) procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); - -- Checks the validity of the bounds of a choice. When the bounds - -- are static and no error occurred the bounds are entered into - -- the choices table so that they can be sorted later on. + -- Checks the validity of the bounds of a choice. When the bounds + -- are static and no error occurred the bounds are entered into the + -- choices table so that they can be sorted later on. ----------- -- Check -- @@ -628,10 +703,10 @@ package body Sem_Case is if Lo_Val < Bounds_Lo then - -- If the choice is an entity name, then it is a type, and - -- we want to post the message on the reference to this - -- entity. Otherwise we want to post it on the lower bound - -- of the range. + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise we want to post it on the lower bound of the + -- range. if Is_Entity_Name (Choice) then Enode := Choice; @@ -654,10 +729,9 @@ package body Sem_Case is if Hi_Val > Bounds_Hi then - -- If the choice is an entity name, then it is a type, and - -- we want to post the message on the reference to this - -- entity. Otherwise we want to post it on the upper bound - -- of the range. + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise post it on the upper bound of the range. if Is_Entity_Name (Choice) then Enode := Choice; @@ -678,9 +752,9 @@ package body Sem_Case is -- Store bounds in the table - -- Note: we still store the bounds, even if they are out of - -- range, since this may prevent unnecessary cascaded errors - -- for values that are covered by such an excessive range. + -- Note: we still store the bounds, even if they are out of range, + -- since this may prevent unnecessary cascaded errors for values + -- that are covered by such an excessive range. Last_Choice := Last_Choice + 1; Sort_Choice_Table (Last_Choice).Lo := Lo; @@ -695,9 +769,9 @@ package body Sem_Case is Raises_CE := False; Others_Present := False; - -- If Subtyp is not a static subtype Ada 95 requires then we use - -- the bounds of its base type to determine the values covered by - -- the discrete choices. + -- If Subtyp is not a static subtype Ada 95 requires then we use the + -- bounds of its base type to determine the values covered by the + -- discrete choices. if Is_OK_Static_Subtype (Subtyp) then Bounds_Type := Subtyp; @@ -848,8 +922,9 @@ package body Sem_Case is Check_Choices (Sort_Choice_Table (0 .. Last_Choice), Bounds_Type, + Subtyp, Others_Present or else (Choice_Type = Universal_Integer), - Sloc (N)); + N); -- Now copy the sorted discrete choices diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 75b24952200..174811bb81a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -540,12 +540,9 @@ package body Sem_Ch12 is -- initialized before call to Check_Generic_Child_Unit. procedure Install_Formal_Packages (Par : Entity_Id); - -- If any of the formals of the parent are formal packages with box, - -- their formal parts are visible in the parent and thus in the child - -- unit as well. Analogous to what is done in Check_Generic_Actuals - -- for the unit itself. This procedure is also used in an instance, to - -- make visible the proper entities of the actual for a formal package - -- declared with a box. + -- Install the visible part of any formal of the parent that is a formal + -- package. Note that for the case of a formal package with a box, this + -- includes the formal part of the formal package (12.7(10/2)). procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); -- When compiling an instance of a child unit the parent (which is @@ -1701,18 +1698,18 @@ package body Sem_Ch12 is Lo := Make_Attribute_Reference (Loc, Attribute_Name => Name_First, - Prefix => New_Reference_To (T, Loc)); + Prefix => New_Reference_To (T, Loc)); Set_Etype (Lo, T); Hi := Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, - Prefix => New_Reference_To (T, Loc)); + Prefix => New_Reference_To (T, Loc)); Set_Etype (Hi, T); Set_Scalar_Range (T, Make_Range (Loc, - Low_Bound => Lo, + Low_Bound => Lo, High_Bound => Hi)); Set_Ekind (Base, E_Enumeration_Type); @@ -5217,11 +5214,10 @@ package body Sem_Ch12 is elsif In_Open_Scopes (Inst_Par) then - -- If the parent is already installed verify that the - -- actuals for its formal packages declared with a box - -- are already installed. This is necessary when the - -- child instance is a child of the parent instance. - -- In this case the parent is placed on the scope stack + -- If the parent is already installed, install the actuals + -- for its formal packages. This is necessary when the + -- child instance is a child of the parent instance: + -- in this case, the parent is placed on the scope stack -- but the formal packages are not made visible. Install_Formal_Packages (Inst_Par); @@ -7191,24 +7187,20 @@ package body Sem_Ch12 is if Renamed_Object (E) = Par then exit; - -- The visibility of a formal of an enclosing generic is - -- already correct. + -- The visibility of a formal of an enclosing generic is already + -- correct. elsif Denotes_Formal_Package (E) then null; - elsif Present (Associated_Formal_Package (E)) - and then Box_Present (Parent (Associated_Formal_Package (E))) - then + elsif Present (Associated_Formal_Package (E)) then Check_Generic_Actuals (Renamed_Object (E), True); Set_Is_Hidden (E, False); -- Find formal package in generic unit that corresponds to -- (instance of) formal package in instance. - while Present (Gen_E) - and then Chars (Gen_E) /= Chars (E) - loop + while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop Next_Entity (Gen_E); end loop; @@ -8365,7 +8357,7 @@ package body Sem_Ch12 is "with volatile actual", Actual); end if; - -- formal in-parameter + -- Formal in-parameter else -- The instantiation of a generic formal in-parameter is constant diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c514206c00d..7dd9629da6a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -784,7 +784,7 @@ package body Sem_Ch3 is Anon_Type := Create_Itype - (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); + (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); if All_Present (N) and then Ada_Version >= Ada_05 @@ -825,8 +825,7 @@ package body Sem_Ch3 is Find_Type (Subtype_Mark (N)); Desig_Type := Entity (Subtype_Mark (N)); - Set_Directly_Designated_Type - (Anon_Type, Desig_Type); + Set_Directly_Designated_Type (Anon_Type, Desig_Type); Set_Etype (Anon_Type, Anon_Type); -- Make sure the anonymous access type has size and alignment fields @@ -2883,12 +2882,11 @@ package body Sem_Ch3 is Apply_Length_Check (E, T); end if; - -- If the type is limited unconstrained with defaulted discriminants - -- and there is no expression, then the object is constrained by the + -- If the type is limited unconstrained with defaulted discriminants and + -- there is no expression, then the object is constrained by the -- defaults, so it is worthwhile building the corresponding subtype. - elsif (Is_Limited_Record (T) - or else Is_Concurrent_Type (T)) + elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) and then not Is_Constrained (T) and then Has_Discriminants (T) then diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 18853d72729..6e06e8353ae 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5018,7 +5018,7 @@ package body Sem_Eval is if Attribute_Name (N) = Name_Size then Error_Msg_N - ("size attribute is only static for scalar type " & + ("size attribute is only static for static scalar type " & "(RM 4.9(7,8))", N); -- Flag array cases diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 902cb30e825..4d56d36ee39 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3459,6 +3459,15 @@ package body Sem_Prag is else Set_Imported (Def_Id); + if Is_Subprogram (Def_Id) + and then Is_Abstract_Subprogram (Def_Id) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE + ("cannot import abstract subprogram& declared#", + Arg2, Def_Id); + end if; + -- Special processing for Convention_Intrinsic if C = Convention_Intrinsic then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c6a5a5ace59..96a295cd218 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2935,10 +2935,8 @@ package body Sem_Res is -- anomalies: the subtype was first built in the subprogram -- declaration, and the current call may be nested. - if Nkind (Actval) = N_Aggregate - and then Has_Discriminants (Etype (Actval)) - then - Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); + if Nkind (Actval) = N_Aggregate then + Analyze_And_Resolve (Actval, Etype (F)); else Analyze_And_Resolve (Actval, Etype (Actval)); end if; @@ -5390,6 +5388,7 @@ package body Sem_Res is Eval_Call (N); Check_Elab_Call (N); + Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; ------------------------------- @@ -8255,8 +8254,8 @@ package body Sem_Res is ----------------------------- procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is - Conv_OK : constant Boolean := Conversion_OK (N); - Operand : constant Node_Id := Expression (N); + Conv_OK : constant Boolean := Conversion_OK (N); + Operand : constant Node_Id := Expression (N); Operand_Typ : constant Entity_Id := Etype (Operand); Target_Typ : constant Entity_Id := Etype (N); Rop : Node_Id; @@ -8401,9 +8400,25 @@ package body Sem_Res is (Ekind (Entity (Orig_N)) = E_Loop_Parameter and then Covers (Orig_T, Etype (Entity (Orig_N))))) then - Error_Msg_Node_2 := Orig_T; - Error_Msg_NE -- CODEFIX - ("?redundant conversion, & is of type &!", N, Entity (Orig_N)); + -- One more check, do not give warning if the analyzed conversion + -- has an expression with non-static bounds, and the bounds of the + -- target are static. This avoids junk warnings in cases where the + -- conversion is necessary to establish staticness, for example in + -- a case statement. + + if not Is_OK_Static_Subtype (Operand_Typ) + and then Is_OK_Static_Subtype (Target_Typ) + then + null; + + -- Here we give the redundant conversion warning + + else + Error_Msg_Node_2 := Orig_T; + Error_Msg_NE -- CODEFIX + ("?redundant conversion, & is of type &!", + N, Entity (Orig_N)); + end if; end if; end if; diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index f47d1288f81..cd4e66be554 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -285,6 +285,14 @@ package body Sem_SCIL is return Found_Node; end if; + -- Actions in handled sequence of statements + + when + N_Handled_Sequence_Of_Statements => + if Find_SCIL_Node (Statements (P)) then + return Found_Node; + end if; + -- Conditions of while expression or elsif. when N_Iteration_Scheme | @@ -505,7 +513,6 @@ package body Sem_SCIL is N_Function_Call | N_Function_Specification | N_Generic_Association | - N_Handled_Sequence_Of_Statements | N_Identifier | N_In | N_Index_Or_Discriminant_Constraint | diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 931112c472d..d35326e1a50 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -732,7 +732,7 @@ package body Sem_Type is begin -- If either operand missing, then this is an error, but ignore it (and -- pretend we have a cover) if errors already detected, since this may - -- simply mean we have malformed trees. + -- simply mean we have malformed trees or a semantic error upstream. if No (T1) or else No (T2) then if Total_Errors_Detected /= 0 then @@ -791,7 +791,7 @@ package body Sem_Type is or else Scope (T1) /= Scope (T2)); end if; - -- Literals are compatible with types in a given "class" + -- Literals are compatible with types in a given "class" elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) or else (T2 = Universal_Real and then Is_Real_Type (T1)) @@ -803,7 +803,8 @@ package body Sem_Type is then return True; - -- The context may be class wide + -- The context may be class wide, and a class-wide type is + -- compatible with any member of the class. elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) @@ -816,8 +817,8 @@ package body Sem_Type is then return True; - -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a - -- task_type or protected_type implementing T1 + -- Ada 2005 (AI-345): A class-wide abstract interface type covers a + -- task_type or protected_type that implements the interface. elsif Ada_Version >= Ada_05 and then Is_Class_Wide_Type (T1) @@ -884,7 +885,10 @@ package body Sem_Type is then return True; - -- Some contexts require a class of types rather than a specific type + -- Some contexts require a class of types rather than a specific type. + -- For example, conditions require any boolean type, fixed point + -- attributes require some real type, etc. The built-in types Any_XXX + -- represent these classes. elsif (T1 = Any_Integer and then Is_Integer_Type (T2)) or else (T1 = Any_Boolean and then Is_Boolean_Type (T2)) @@ -963,6 +967,8 @@ package body Sem_Type is then return Covers (Corresponding_Remote_Type (T1), T2); + -- and conversely. + elsif Is_Record_Type (T2) and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2)) @@ -970,9 +976,30 @@ package body Sem_Type is then return Covers (Corresponding_Remote_Type (T2), T1); + -- Synchronized types are represented at run time by their corresponding + -- record type. During expansion one is replaced with the other, but + -- they are compatible views of the same type. + + elsif Is_Record_Type (T1) + and then Is_Concurrent_Type (T2) + and then Present (Corresponding_Record_Type (T2)) + then + return Covers (T1, Corresponding_Record_Type (T2)); + + elsif Is_Concurrent_Type (T1) + and then Present (Corresponding_Record_Type (T1)) + and then Is_Record_Type (T2) + then + return Covers (Corresponding_Record_Type (T1), T2); + + -- During analysis, an attribute reference 'Access has a special type + -- kind: Access_Attribute_Type, to be replaced eventually with the type + -- imposed by context. + elsif Ekind (T2) = E_Access_Attribute_Type and then (Ekind (BT1) = E_General_Access_Type - or else Ekind (BT1) = E_Access_Type) + or else + Ekind (BT1) = E_Access_Type) and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access @@ -984,6 +1011,8 @@ package body Sem_Type is return True; + -- Ditto for allocators, which eventually resolve to the context type + elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then @@ -1008,7 +1037,7 @@ package body Sem_Type is -- A packed array type covers its corresponding non-packed type. This is -- not legitimate Ada, but allows the omission of a number of otherwise -- useless unchecked conversions, and since this can only arise in - -- (known correct) expanded code, no harm is done + -- (known correct) expanded code, no harm is done. elsif Is_Array_Type (T2) and then Is_Packed (T2) @@ -1065,7 +1094,7 @@ package body Sem_Type is return True; -- Ada 2005 (AI-50217): Additional branches to make the shadow entity - -- compatible with its real entity. + -- obtained through a limited_with compatible with its real entity. elsif From_With_Type (T1) then @@ -1087,7 +1116,7 @@ package body Sem_Type is -- If units in the context have Limited_With clauses on each other, -- either type might have a limited view. Checks performed elsewhere - -- verify that the context type is the non-limited view. + -- verify that the context type is the nonlimited view. if Is_Incomplete_Type (T2) then return Covers (T1, Get_Full_View (Non_Limited_View (T2))); @@ -1111,7 +1140,7 @@ package body Sem_Type is -- Ada 2005 (AI-423): Coverage of formal anonymous access types -- and actual anonymous access types in the context of generic - -- instantiation. We have the following situation: + -- instantiations. We have the following situation: -- generic -- type Formal is private; @@ -1133,7 +1162,7 @@ package body Sem_Type is then return True; - -- Otherwise it doesn't cover! + -- Otherwise, types are not compatible! else return False; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 37965afb69a..5baf60c8dea 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2137,6 +2137,181 @@ package body Sem_Util is end Denotes_Discriminant; + ------------------------- + -- Denotes_Same_Object -- + ------------------------- + + function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is + begin + -- If we have entity names, then must be same entity + + if Is_Entity_Name (A1) then + if Is_Entity_Name (A2) then + return Entity (A1) = Entity (A2); + else + return False; + end if; + + -- No match if not same node kind + + elsif Nkind (A1) /= Nkind (A2) then + return False; + + -- For selected components, must have same prefix and selector + + elsif Nkind (A1) = N_Selected_Component then + return Denotes_Same_Object (Prefix (A1), Prefix (A2)) + and then + Entity (Selector_Name (A1)) = Entity (Selector_Name (A2)); + + -- For explicit dereferences, prefixes must be same + + elsif Nkind (A1) = N_Explicit_Dereference then + return Denotes_Same_Object (Prefix (A1), Prefix (A2)); + + -- For indexed components, prefixes and all subscripts must be the same + + elsif Nkind (A1) = N_Indexed_Component then + if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then + declare + Indx1 : Node_Id; + Indx2 : Node_Id; + + begin + Indx1 := First (Expressions (A1)); + Indx2 := First (Expressions (A2)); + while Present (Indx1) loop + + -- Shouldn't we be checking that values are the same??? + + if not Denotes_Same_Object (Indx1, Indx2) then + return False; + end if; + + Next (Indx1); + Next (Indx2); + end loop; + + return True; + end; + else + return False; + end if; + + -- For slices, prefixes must match and bounds must match + + elsif Nkind (A1) = N_Slice + and then Denotes_Same_Object (Prefix (A1), Prefix (A2)) + then + declare + Lo1, Lo2, Hi1, Hi2 : Node_Id; + + begin + Get_Index_Bounds (Etype (A1), Lo1, Hi1); + Get_Index_Bounds (Etype (A2), Lo2, Hi2); + + -- Check whether bounds are statically identical. There is no + -- attempt to detect partial overlap of slices. + + -- What about an array and a slice of an array??? + + return Denotes_Same_Object (Lo1, Lo2) + and then Denotes_Same_Object (Hi1, Hi2); + end; + + -- Literals will appear as indices. Isn't this where we should check + -- Known_At_Compile_Time at least if we are generating warnings ??? + + elsif Nkind (A1) = N_Integer_Literal then + return Intval (A1) = Intval (A2); + + else + return False; + end if; + end Denotes_Same_Object; + + ------------------------- + -- Denotes_Same_Prefix -- + ------------------------- + + function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is + + begin + if Is_Entity_Name (A1) then + if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then + return Denotes_Same_Object (A1, Prefix (A2)) + or else Denotes_Same_Prefix (A1, Prefix (A2)); + else + return False; + end if; + + elsif Is_Entity_Name (A2) then + return Denotes_Same_Prefix (A2, A1); + + elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) + and then + Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) + then + declare + Root1, Root2 : Node_Id; + Depth1, Depth2 : Int := 0; + + begin + Root1 := Prefix (A1); + while not Is_Entity_Name (Root1) loop + if not Nkind_In + (Root1, N_Selected_Component, N_Indexed_Component) + then + return False; + else + Root1 := Prefix (Root1); + end if; + + Depth1 := Depth1 + 1; + end loop; + + Root2 := Prefix (A2); + while not Is_Entity_Name (Root2) loop + if not Nkind_In + (Root2, N_Selected_Component, N_Indexed_Component) + then + return False; + else + Root2 := Prefix (Root2); + end if; + + Depth2 := Depth2 + 1; + end loop; + + -- If both have the same depth and they do not denote the same + -- object, they are disjoint and not warning is needed. + + if Depth1 = Depth2 then + return False; + + elsif Depth1 > Depth2 then + Root1 := Prefix (A1); + for I in 1 .. Depth1 - Depth2 - 1 loop + Root1 := Prefix (Root1); + end loop; + + return Denotes_Same_Object (Root1, A2); + + else + Root2 := Prefix (A2); + for I in 1 .. Depth2 - Depth1 - 1 loop + Root2 := Prefix (Root2); + end loop; + + return Denotes_Same_Object (A1, Root2); + end if; + end; + + else + return False; + end if; + end Denotes_Same_Prefix; + ---------------------- -- Denotes_Variable -- ---------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0e3dde668e6..623a72b2782 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -251,6 +251,15 @@ package Sem_Util is -- components of protected types, and constraint checks on entry -- families constrained by discriminants. + function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; + function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; + -- Functions to detect suspicious overlapping between actuals in a call, + -- when one of them is writable. The predicates are those proposed in + -- AI05-0144, to detect dangerous order dependence in complex calls. + -- I would add a parameter Warn which enables more extensive testing of + -- cases as we find appropriate when we are only warning ??? Or perhaps + -- return an indication of (Error, Warn, OK) ??? + function Denotes_Variable (N : Node_Id) return Boolean; -- Returns True if node N denotes a single variable without parentheses diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 407171f1d7b..abfdf1ff668 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2991,6 +2991,7 @@ package body Sem_Warn is Warn_On_Non_Local_Exception := True; Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; + Warn_On_Overlap := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; Warn_On_Unchecked_Conversion := True; @@ -3001,6 +3002,12 @@ package body Sem_Warn is when 'g' => Set_GNAT_Mode_Warnings; + when 'i' => + Warn_On_Overlap := True; + + when 'I' => + Warn_On_Overlap := False; + when 'm' => Warn_On_Suspicious_Modulus_Value := True; @@ -3139,6 +3146,7 @@ package body Sem_Warn is Warn_On_No_Value_Assigned := False; Warn_On_Non_Local_Exception := False; Warn_On_Obsolescent_Feature := False; + Warn_On_Overlap := False; Warn_On_All_Unread_Out_Parameters := False; Warn_On_Parameter_Order := False; Warn_On_Questionable_Missing_Parens := False; @@ -3535,6 +3543,136 @@ package body Sem_Warn is or else Warn_On_All_Unread_Out_Parameters; end Warn_On_Modified_As_Out_Parameter; + --------------------------------- + -- Warn_On_Overlapping_Actuals -- + --------------------------------- + + procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is + Act1, Act2 : Node_Id; + Form1, Form2 : Entity_Id; + + begin + if not Warn_On_Overlap then + return; + end if; + + -- Exclude calls rewritten as enumeration literals + + if not Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) then + return; + end if; + + -- Exclude calls to library subprograms. Container operations specify + -- safe behavior when source and target coincide. + + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (Subp)))) + then + return; + end if; + + Form1 := First_Formal (Subp); + Act1 := First_Actual (N); + while Present (Form1) and then Present (Act1) loop + if Ekind (Form1) = E_In_Out_Parameter then + Form2 := First_Formal (Subp); + Act2 := First_Actual (N); + while Present (Form2) and then Present (Act2) loop + if Form1 /= Form2 + and then Ekind (Form2) /= E_Out_Parameter + and then + (Denotes_Same_Object (Act1, Act2) + or else + Denotes_Same_Prefix (Act1, Act2)) + then + -- Exclude generic types and guard against previous errors. + + if Error_Posted (N) + or else No (Etype (Act1)) + or else No (Etype (Act2)) + then + null; + + elsif Is_Generic_Type (Etype (Act1)) + or else + Is_Generic_Type (Etype (Act2)) + then + null; + + -- If the actual is a function call in prefix notation, + -- there is no real overlap. + + elsif Nkind (Act2) = N_Function_Call then + null; + + -- If either type is elementary the aliasing is harmless. + + elsif Is_Elementary_Type (Underlying_Type (Etype (Form1))) + or else + Is_Elementary_Type (Underlying_Type (Etype (Form2))) + then + null; + + else + declare + Act : Node_Id; + Form : Entity_Id; + + begin + -- Find matching actual + + Act := First_Actual (N); + Form := First_Formal (Subp); + while Act /= Act2 loop + Next_Formal (Form); + Next_Actual (Act); + end loop; + + -- If the call was written in prefix notation, and + -- thus its prefix before rewriting was a selected + -- component, count only visible actuals in the call. + + if Is_Entity_Name (First_Actual (N)) + and then Nkind (Original_Node (N)) = Nkind (N) + and then Nkind (Name (Original_Node (N))) = + N_Selected_Component + and then + Is_Entity_Name (Prefix (Name (Original_Node (N)))) + and then + Entity (Prefix (Name (Original_Node (N)))) = + Entity (First_Actual (N)) + then + if Act1 = First_Actual (N) then + Error_Msg_FE + ("`IN OUT` prefix overlaps with actual for&?", + Act1, Form); + else + Error_Msg_FE + ("writable actual overlaps with actual for&?", + Act1, Form); + end if; + + else + Error_Msg_FE + ("writable actual overlaps with actual for&?", + Act1, Form); + end if; + end; + end if; + + return; + end if; + + Next_Formal (Form2); + Next_Actual (Act2); + end loop; + end if; + + Next_Formal (Form1); + Next_Actual (Act1); + end loop; + end Warn_On_Overlapping_Actuals; + ------------------------------ -- Warn_On_Suspicious_Index -- ------------------------------ diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index 4ab97be7d67..365ad397d1b 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -210,6 +210,11 @@ package Sem_Warn is -- as an out parameter. True if either Warn_On_Modified_Unread is set for -- an only OUT parameter, or if Warn_On_All_Unread_Out_Parameters is set. + procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id); + -- Called on a subprogram call. Checks whether an IN OUT actual that is + -- not by-copy may overlap with another actual, thus leading to aliasing + -- in the body of the called subprogram. + procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id); -- This is called after resolving an indexed component or a slice. Name -- is the entity for the name of the indexed array, and X is the subscript diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 8bd9f2ee2bd..bf72722cc88 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -813,12 +813,17 @@ package body Styleg is -- Check_Right_Paren -- ----------------------- - -- In check tokens mode (-gnatyt), right paren must never be preceded by + -- In check tokens mode (-gnatyt), right paren must not be immediately + -- followed by an identifier character, and must never be preceded by -- a space unless it is the initial non-blank character on the line. procedure Check_Right_Paren is begin if Style_Check_Tokens then + if Identifier_Char (Source (Token_Ptr + 1)) then + Error_Space_Required (Token_Ptr + 1); + end if; + Check_No_Space_Before; end if; end Check_Right_Paren; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 316b77e702b..a7a8d192626 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -656,6 +656,7 @@ package body Switch.M is else Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; end if; -- Processing for eS switch diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 7273fde6703..3da3c611198 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -33,7 +33,6 @@ with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Sem_Aux; use Sem_Aux; -with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -626,6 +625,58 @@ package body Tbuild is return Occurrence; end New_Occurrence_Of; + ----------------- + -- New_Op_Node -- + ----------------- + + function New_Op_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id + is + type Name_Of_Type is array (N_Op) of Name_Id; + Name_Of : constant Name_Of_Type := Name_Of_Type'( + N_Op_And => Name_Op_And, + N_Op_Or => Name_Op_Or, + N_Op_Xor => Name_Op_Xor, + N_Op_Eq => Name_Op_Eq, + N_Op_Ne => Name_Op_Ne, + N_Op_Lt => Name_Op_Lt, + N_Op_Le => Name_Op_Le, + N_Op_Gt => Name_Op_Gt, + N_Op_Ge => Name_Op_Ge, + N_Op_Add => Name_Op_Add, + N_Op_Subtract => Name_Op_Subtract, + N_Op_Concat => Name_Op_Concat, + N_Op_Multiply => Name_Op_Multiply, + N_Op_Divide => Name_Op_Divide, + N_Op_Mod => Name_Op_Mod, + N_Op_Rem => Name_Op_Rem, + N_Op_Expon => Name_Op_Expon, + N_Op_Plus => Name_Op_Add, + N_Op_Minus => Name_Op_Subtract, + N_Op_Abs => Name_Op_Abs, + N_Op_Not => Name_Op_Not, + + -- We don't really need these shift operators, since they never + -- appear as operators in the source, but the path of least + -- resistance is to put them in (the aggregate must be complete) + + N_Op_Rotate_Left => Name_Rotate_Left, + N_Op_Rotate_Right => Name_Rotate_Right, + N_Op_Shift_Left => Name_Shift_Left, + N_Op_Shift_Right => Name_Shift_Right, + N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); + + Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc); + + begin + if New_Node_Kind in Name_Of'Range then + Set_Chars (Nod, Name_Of (New_Node_Kind)); + end if; + + return Nod; + end New_Op_Node; + ---------------------- -- New_Reference_To -- ---------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 261776df78f..0b73a53d220 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -27,6 +27,7 @@ -- building specific types of tree nodes. with Namet; use Namet; +with Sinfo; use Sinfo; with Types; use Types; package Tbuild is @@ -196,6 +197,12 @@ package Tbuild is -- "raise Constraint_Error" and returns the root of this tree, -- the N_Raise_Statement node. + function New_Op_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id; + -- Create node using New_Node and, if its kind is in N_Op, set its Chars + -- field accordingly. + function New_External_Name (Related_Id : Name_Id; Suffix : Character := ' '; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 7340f64129e..cc3603aafa0 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -31,7 +31,7 @@ -- This package contains host independent type definitions which are used -- in more than one unit in the compiler. They are gathered here for easy --- reference, though in some cases the full description is found in the +-- reference, although in some cases the full description is found in the -- relevant module which implements the definition. The main reason that they -- are not in their "natural" specs is that this would cause a lot of inter- -- spec dependencies, and in particular some awkward circular dependencies diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 6d704403da9..541496c5df8 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -424,6 +424,8 @@ begin Write_Line (" H* turn off warnings for hiding variable"); Write_Line (" i* turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); + Write_Line (" .i turn on warnings for overlapping actuals"); + Write_Line (" .I* turn off warnings for overlapping actuals"); Write_Line (" j turn on warnings for obsolescent " & "(annex J) feature"); Write_Line (" J* turn off warnings for obsolescent " & diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb index c4c386bd6c8..7dd3ca29883 100644 --- a/gcc/ada/xsnamest.adb +++ b/gcc/ada/xsnamest.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,10 +24,10 @@ ------------------------------------------------------------------------------ -- This utility is used to make a new version of the Snames package when new --- names are added. This version reads a template file from snames.adt in --- which the numbers are all written as $, and generates a new version of --- the spec file snames.ads (written to snames.ns). It also reads snames.adb --- and generates an updated body (written to snames.nb), and snames.h and +-- names are added. This version reads a template file from snames.ads-tmpl in +-- which the numbers are all written as $, and generates a new version of the +-- spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl +-- and generates an updated body (written to snames.nb), and snames.h-tmpl and -- generates an updated C header file (written to snames.nh). with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; |