diff options
| author | H.J. Lu <hongjiu.lu@intel.com> | 2008-05-28 00:19:39 +0000 |
|---|---|---|
| committer | H.J. Lu <hongjiu.lu@intel.com> | 2008-05-28 00:19:39 +0000 |
| commit | 2794ddc7953821fa600ed261270679dc640604e9 (patch) | |
| tree | 84f577071f85f247aadf238916bde74c8c30593d | |
| parent | 4c47b85b21b9af07a0c400095ba190948763adf5 (diff) | |
Merged with trunk at revision 136060.
git-svn-id: https://gcc.gnu.org/svn/gcc/branches/ix86/avx@136066 138bc75d-0d04-0410-961f-82ee72b054a4
170 files changed, 4829 insertions, 2671 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index a6fad4f55ef..c25c4380cb4 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,166 @@ +2008-05-27 H.J. Lu <hongjiu.lu@intel.com> + + PR target/35767 + PR target/35771 + * config/i386/i386.c (ix86_function_arg_boundary): Use + alignment of canonical type. + (ix86_expand_vector_move): Check unaligned memory access for + all SSE modes. + +2008-05-27 H.J. Lu <hongjiu.lu@intel.com> + + * dwarf2out.c (current_fde): Change return type to dw_fde_ref. + Moved to the front of file. + +2008-05-27 Xuepeng Guo <xuepeng.guo@intel.com> + H.J. Lu <hongjiu.lu@intel.com> + + * dwarf2out.c (current_fde): New. + (add_cfi): Use it. + (lookup_cfa:): Likewise. + (dwarf2out_end_epilogue): Likewise. + (dwarf2out_note_section_used): Likewise. + +2008-05-27 Michael Matz <matz@suse.de> + + PR c++/27975 + * c.opt (Wenum-compare): New warning option. + * doc/invoke.texi (Warning Options): Document -Wenum-compare. + +2008-05-27 Michael Matz <matz@suse.de> + + PR middle-end/36326 + * tree-gimple.c (is_gimple_mem_rhs): Remove work-around for + non-BLKmode types. + * tree-tailcall.c (find_tail_calls): Don't mark calls storing + into memory as tail calls. + +2008-05-27 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36339 + * tree-ssa-alias.c (set_initial_properties): Escaped pt_anything + pointers cause all addressable variables to be call clobbered. + +2008-05-27 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36245 + * tree-ssa-address.c (add_to_parts): Deal with non-pointer + bases. + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * config/s390/s390.md: Replace all occurences of the 'm' + constraint with 'RT'. + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * config/s390/s390.md ("cpu_facility", "enabled"): Attribute + definitions added. + ("*movdi_64dfp", "*movdi_64extimm", "*movdi_64"): Merged into + "*movdi_64". + ("*anddi3_extimm", "*anddi3"): Merged into "*anddi3". + ("*iordi3_extimm", "*iordi3"): Merged into "*iordi3". + ("*xordi3_extimm", "*xordi3"): Merged into "*xordi3". + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * reload.c: (find_reloads): Skip alternatives according to the + "enabled" attribute. Constify the constraint variable. + * recog.c (get_attr_enabled): Add default implementation. + (extract_insn): Set the alternative_enabled_p array + in the recog_data struct. + (preprocess_constraints, constrain_operands): Skip + alternatives according to the "enabled" attribute + * recog.h (struct recog_data): New field alternative_enabled_p. + (skip_alternative): New inline function. + * regclass.c: (record_operand_costs): Check the "enabled" + attribute. + (record_reg_classes): Skip alternative according to the + "enabled" attribute. + + * doc/md.texi: Add documention for the "enabled" attribute. + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * defaults.h (TARGET_MEM_CONSTRAINT): New target macro added. + * postreload.c (reload_cse_simplify_operands): Replace 'm' + constraint with TARGET_MEM_CONSTRAINT. + * recog.c (asm_operand_ok, preprocess_constraints, + constrain_operands): Likewise. + * regclass.c (record_reg_classes): Likewise. + * reload.c (find_reloads, alternative_allows_const_pool_ref): + Likewise. + * reload1.c (maybe_fix_stack_asms): Likewise. + * stmt.c (parse_output_constraint, parse_input_constraint): + Likewise. + * recog.h: Adjust comment. + * genpreds.c (generic_constraint_letters): Remove 'm' constraint. + * genoutput.c (note_constraint): Don't emit error for 'm' + constraint. + * doc/md.texi: Add a note to description of 'm' constraint. + * doc/tm.texi: Document the new TARGET_MEM_CONSTRAINT macro. + +2008-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * tree-sra.c (sra_type_can_be_decomposed_p) <RECORD_TYPE>: Make sure + that the bitfield is of integral type before testing its precision. + +2008-05-27 Trevor Smigiel <trevor_smigiel@playstation.sony.com> + Sa Liu <saliu@de.ibm.com> + + * config/spu/spu.c (spu_init_libfuncs): Add __multi3, __divti3, + __modti3, __udivti3, __umodti3 and __udivmodti4. + * config/spu/t-spu-elf (LIB2FUNCS_STATIC_EXTRA): Add files + that implement TImode mul and div functions. + * config/spu/multi3.c: New. Implement __multi3. + * config/spu/divmodti4.c: New. Implement _udivmodti4 and others. + * testsuite/gcc.target/spu/muldivti3.c: New. Test TImode mul and div + functions on SPU. + +2008-05-26 Steven Bosscher <stevenb.gcc@gmail.com> + + * config/rs6000/rs6000.c (rs6000_legitimize_tls_address): Generate + new tls_gd_* and tls_ld_* insns instead of an insn sequence. + * config/rs6000/rs6000.md (TLSmode, tls_abi_suffix, tls_insn_suffix, + tls_sysv_suffix): New mode and mode attribute iterators. + (tls_gd_32, tls_gd_64, tls_ld_32, tls_ld_64): Remove. + (lts_gd_aix*, tls_gd_sysv*, tls_ld_aix*, tls_ld_sysv*): New patterns. + (tls_dtprel_*, tls_dtprel_ha_*, tls_dtprel_lo_*, tls_got_dtprel_*, + tls_tprel_*, tls_tprel_ha_*, tls_tprel_lo_*, tls_got_tprel_*, + tls_tls_*): Merge 32 bit and 64 bit variants using aforementioned + iterators. + +2008-05-26 Eric Botcazou <ebotcazou@adacore.com> + + PR tree-optimization/36329 + * tree.h (CALL_CANNOT_INLINE_P): Add access check. + * tree-gimple.h (CALL_STMT_CANNOT_INLINE_P): New macro. + * cgraphbuild.c (initialize_inline_failed): Use the latter + macro in lieu of the former. + * ipa-inline.c (cgraph_mark_inline): Likewise. + (cgraph_decide_inlining_of_small_function): Likewise. + (cgraph_decide_inlining): Likewise. + (cgraph_decide_inlining_incrementally): Likewise. + +2008-05-26 Tristan Gingold <gingold@adacore.com> + Anatoly Sokolov <aesok@post.ru> + + * config/avr/avr.md ("call_prologue_saves"): Use hi8(gs())/lo8(gs()) + instead of pm_lo8/pm_hi8 to makes this call working on avr6. + * config/avr/avr.c (expand_prologue): Tune "call_prologue" + optimization for 'avr6' architecture. + +2008-05-26 Andy Hutchinson <hutchinsonandy@aim.com> + + PR target/34932 + * config/avr/avr.md (*addhi3_zero_extend2): Remove. + +2008-05-26 Richard Guenther <rguenther@suse.de> + + * tree-ssa-sccvn.c (expr_has_constants): Declare. + (visit_reference_op_load): Initialize VN_INFO->has_constants + properly. + 2008-05-26 H.J. Lu <hongjiu.lu@intel.com> PR middle-end/36253 diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index a16ce1aa6f6..088da966f17 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20080526 +20080527 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 32d47aaaa87..411f7fc149f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,368 @@ +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * a-ststio.adb, s-direio.adb: + Further code clean up of previous change. + Update comments. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: Minor reformatting + +2008-05-27 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Build_Incomplete_Type_Declaration): In the case of an + untagged private type with a tagged full type, where the full type has + a self reference, create the corresponding class-wide type early, in + case the self reference is "access T'Class". + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Build_Array_Aggr_Code): If component type includes + tasks and context is an object declaration. create master entity before + expansion. + +2008-05-27 Robert Dewar <dewar@adacore.com> + + * mlib-prj.adb: Minor reformatting + + * prj-part.adb: Minor reformatting + + * prj.ads: Minor reformatting + + * exp_ch3.adb: Minor reformatting. + + * sem_ch3.ads: Minor reformatting + + * sem_eval.adb: Minor reformatting + +2008-05-27 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb: + <prefix>-gnat stack spawns gnatstack, not <prefix>-gnatstack + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate): If the aggregate contains + tasks, create an activation chain now, before the expansion into + assignments and build-in-place calls that require the presence of an + activation chain. + (Backend_Processing_Possible): If the component type is inherently + limited, the aggregate must be expanded into individual built-in-place + assignments. + + * sem_ch6.adb (Build_Extra_Formals): Use underlying type of result to + determine whether an allocation extra parameter must be built, to + handle case of a private type whose full type is a discriminated type + with defaults. + +2008-05-27 Bob Duff <duff@adacore.com> + + * gnat_rm.texi: + Document the new behavior regarding trampolines. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * a-direio.adb, a-sequio.adb: Replace address clause by + unrestricted_access, simpler and compatible with .NET. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-part.adb: + (Project_Path_Name_Of.Try_Path): Do not use Locate_Regular_File to find + a project file, so that symbolic links are not resolved. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * a-ztexio.adb, a-textio.adb, a-witeio.adb, s-direio.adb: + Replace heavy address clause by 'Unrestricted_Access, cleaner and more + portable across GNAT targets, since this kind of address clause is not + supported by VM back-ends (.NET/JGNAT). + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * bindgen.adb: Update comments. + + * s-tasinf-mingw.adb: Add "with" of System.OS_Interface + +2008-05-27 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, + prj.ads, makegpr.adb, makeutl.adb, clean.adb, prj-nmsc.adb, + mlib-tgt.adb, prj-env.adb, prj-env.ads: + (Path_Information): New record type + Use component of type Path_Information when there are two paths, one in + canonical format and one in display format. + Update the project manager to these new components. + +2008-05-27 Robert Dewar <dewar@adacore.com> + + * makeutl.adb: Minor reformatting + * prj-nmsc.adb: Minor reformatting + * s-stausa.adb: Minor reformatting + * s-stausa.ads: Minor reformatting + * sem_ch6.adb: Minor reformatting + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb: Minor comment fixes + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * makeutl.adb: Minor code reorganization + + * exp_aggr.adb: Add ??? comment + Fix typo + + * exp_ch6.adb: Minor reformatting + +2008-05-27 Quentin Ochem <ochem@adacore.com> + + * s-stausa.adb (Initialize): Updated result initialization, and + initialization of environment stack. + (Fill_Stack): Improved computation of the pattern zone, taking into + account already filled at the calling point. + (Get_Usage_Range): Now uses Min_Measure and Max_Measure instead of + Measure and Overflow_Guard. + (Report_Result): Fixed computation of the result using new fields of + Stack_Analyzer. + + * s-stausa.ads (Initialize_Analyzer): Replaced Size / Overflow_Guard + params by more explicit Stack_Size / Max_Pattern_Size params. + (Stack_Analyzer): Added distinct Stack_Size & Pattern_Size fields. + Added Stack_Used_When_Filling field. + (Task_Result): Replaced Measure / Overflow_Guard by more explicit + Min_Measure and Max_Measure fields. + + * s-tassta.adb (Task_Wrapper): Updated call to Initialize_Analyzer. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Check_File): Make sure that a unit that replaces the same unit in a + project being extended is properly processed. + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: + (Get_Discr_Value): Remove obsolete code that failed to find the value + of a discriminant for an inherited task component appearing in a type + extension. + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + (System.File_IO.{Close, Delete, Reset}): + Change File parameter from "in out AFCB_Ptr" to "access AFCB_Ptr". + + (Ada.*_IO.{Close, Delete, Reset, Set_Mode}): + Pass File parameter by reference. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Process_Sources_In_Multi_Language_Mode): Check that there are not two + sources of the same project that have the same object file name. + (Find_Explicit_Sources): Always remove a source exception that was not + found. + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb: Minor reformatting + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: + (Is_Interface_Conformant): Handle properly a primitive operation that + overrides an interface function with a controlling access result. + (Type_Conformance): If Skip_Controlling_Formals is true, when matching + inherited and overriding operations, omit as well the conformance check + on result types, to prevent spurious errors. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * makeutl.ads, makeutl.adb: + (Set_Location): New procedure + (Get_Location): New function + (Update_Main): New procedure + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Check_Library): Allow standard project to be extended as a static + library project. + (Get_Mains): Do not inherit attribute Main in an extending library + project. + +2008-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * system-darwin-ppc.ads (Always_Compatible_Rep): Set to False. + * system-darwin-x86.ads (Always_Compatible_Rep): Likewise. + * system-freebsd-x86.ads (Always_Compatible_Rep): Likewise. + * system-linux-ppc.ads (Always_Compatible_Rep): Likewise. + * system-linux-x86_64.ads (Always_Compatible_Rep): Likewise. + * system-linux-x86.ads (Always_Compatible_Rep): Likewise. + * system-mingw.ads (Always_Compatible_Rep): Likewise. + * system-solaris-sparc.ads (Always_Compatible_Rep): Likewise. + * system-solaris-sparcv9.ads (Always_Compatible_Rep): Likewise. + * system-solaris-x86.ads (Always_Compatible_Rep): Likewise. + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: add guard to previous patch. + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_disp.adb (Build_Dispatch_Tables): For a private type completed by + a synchronized tagged type, do not attempt to build dispatch table for + full view. The table is built for the corresponding record type, which + has its own declaration. + +2008-05-27 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Fixup_Bad_Constraint): Set the Etype on the bad subtype + to the known type entity E, rather than setting it to Any_Type. Fixes + possible blowup in function Base_Init_Proc, as called from Freeze_Entity + for objects whose type had an illegal constraint. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: + Add succinct documentation for attribute Excluded_Source_List_File + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: Add new project level attribute Map_File_Option + + * prj-nmsc.adb (Process_Linker): Process new attribute Map_File_Option + + * prj.ads: Minor reformatting and comment update + (Project_Configuration): New component Map_File_Option + + * snames.adb: New standard name Map_File_Option + + * snames.ads: New standard name Map_File_Option + +2008-05-27 Vincent Celier <celier@adacore.com> + + * xsnames.adb: Remove unused variable Oname + +2008-05-27 Doug Rupp <rupp@adacore.com> + + * exp_ch6.adb: + (Expand_N_Function_Call): Fix comments. Minor reformatting. + + * exp_vfpt.ads: + (Expand_Vax_Foreign_Return): Fix comments. + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb: Minor reformating + +2008-05-26 Gary Dismukes <dismukes@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): Remove checks for + No_Default_Initialization, which is now delayed until the freeze point + of the object. Add a comment about deferral of the check. + + * freeze.adb (Freeze_Entity): The check for No_Default_Initialization + on objects is moved here. + +2008-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * s-casi16.adb (Uhalf): Rewrite it as integer with small alignment. + (Compare_Array_S16): Adjust for above change. + * s-casi32.adb (Uword): Likewise. + (Compare_Array_S32): Likewise. + * s-casi64.adb (Uword): Likewise. + (Compare_Array_S64): Likewise. + * s-caun16.adb (Uhalf): Likewise. + (Compare_Array_U16): Likewise. + * s-caun32.adb (Uword): Likewise. + (Compare_Array_U32): Likewise. + * s-caun64.adb (Uword): Likewise. + (Compare_Array_U64): Likewise. + +2008-05-26 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb: Add ??? comment for previous change + + * exp_vfpt.adb: Minor reformatting + + * exp_vfpt.ads: Add ??? comment for last change + + * sem_attr.adb: Add some ??? comments for previous change + + * s-vaflop.ads: Add comments for previous change + +2008-05-26 Doug Rupp <rupp@adacore.com> + + * s-vaflop-vms-alpha.adb: + Remove System.IO use clause, to prevent spurious ambiguities when + package is access through rtsfind. + +2008-05-26 Sergey Rybin <rybin@adacore.com> + + * tree_io.ads (ASIS_Version_Number): Update because of the changes + made in front-end + +2008-05-26 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: + (Resolve_Attribute, case 'address): S (A .. B)' address can be safely + converted to S (A)'address only if A .. B is known to be a non-null + range. + +2008-05-26 Doug Rupp <rupp@adacore.com> + + * s-vaflop.adb: + (Return_D, Return_F, Return_G): New functions. + + * s-vaflop.ads: + (Return_D, Return_F, Return_G): New functions. + + * exp_vfpt.adb: + (Expand_Vax_Foreign_Return): New procedure + + * exp_vfpt.ads: + (Expand_Vax_Foreign_Return): New procedure + + * rtsfind.ads: + (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Ids + (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Unit_Table elements + + * exp_ch6.adb: + Import Exp_Vfpt + (Expand_N_Function_Call): Call Expand_Vax_Foreign_Return. + + * s-vaflop-vms-alpha.adb: + (Return_D, Return_F, Return_G): New functions. + +2008-05-26 Gary Dismukes <dismukes@adacore.com> + + * exp_ch3.adb (Build_Array_Init_Proc): Only set Init_Proc to a dummy + init proc entity when there is actual default initialization associated + with the component type, to avoid spurious errors on objects of scalar + array types that are marked Is_Public when No_Default_Initialization + applies. + +2008-05-26 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads, rtsfind.adb: + (RE_Get_RACW): New runtime library entity provided by PolyORB s-parint. + (Check_RPC): Support per-PCS-kind API versioning. + + exp_dist.ads, exp_dist.adb: + (Build_Stub_Tag, Get_Stub_Elements): New utility subprograms. + (PolyORB_Support.Add_RACW_From_Any): Offload common code to new runtime + library function Get_RACW. + (PolyORB_Support.Add_RACW_To_Any): Offload common code to new runtime + library function Get_Reference. + (PolyORB_Support.Add_RACW_Read_Attribute): Use Get_RACW instead of going + through an intermediate Any. + (PolyORB_Support.Add_RACW_Write_Attribute): Use Get_Reference instead of + going through an intermediate Any. + + * sem_dist.adb: Minor reformatting. + 2008-05-26 Javier Miranda <miranda@adacore.com> * einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias. diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb index 44479efedfd..9d315c88c5b 100644 --- a/gcc/ada/a-direio.adb +++ b/gcc/ada/a-direio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -74,7 +74,7 @@ package body Ada.Direct_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ @@ -98,7 +98,7 @@ package body Ada.Direct_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads index 6ac1a8a95b6..70ff5ed3ca9 100644 --- a/gcc/ada/a-direio.ads +++ b/gcc/ada/a-direio.ads @@ -138,6 +138,32 @@ package Ada.Direct_IO is Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + type File_Type is new System.Direct_IO.File_Type; Bytes : constant Interfaces.C_Streams.size_t := diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb index eb9e989c65b..0c80b4062a7 100644 --- a/gcc/ada/a-sequio.adb +++ b/gcc/ada/a-sequio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -67,7 +67,7 @@ package body Ada.Sequential_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ @@ -90,7 +90,7 @@ package body Ada.Sequential_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -240,12 +240,12 @@ package body Ada.Sequential_IO is procedure Reset (File : in out File_Type; Mode : File_Mode) is begin - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); end Reset; procedure Reset (File : in out File_Type) is begin - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); end Reset; ----------- diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads index ece3ee13ea6..bd685c22e48 100644 --- a/gcc/ada/a-sequio.ads +++ b/gcc/ada/a-sequio.ads @@ -114,6 +114,32 @@ package Ada.Sequential_IO is Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + type File_Type is new System.Sequential_IO.File_Type; -- All subprograms are inlined diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb index 6b8376489ad..9c3bd31af58 100644 --- a/gcc/ada/a-ststio.adb +++ b/gcc/ada/a-ststio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -102,7 +102,7 @@ package body Ada.Streams.Stream_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ @@ -138,7 +138,7 @@ package body Ada.Streams.Stream_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -362,7 +362,7 @@ package body Ada.Streams.Stream_IO is if ((File.Mode = FCB.In_File) /= (Mode = In_File)) and then not File.Update_Mode then - FIO.Reset (AP (File), FCB.Inout_File); + FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); File.Update_Mode := True; end if; diff --git a/gcc/ada/a-ststio.ads b/gcc/ada/a-ststio.ads index edcec9a139a..cc2a6d4e24a 100644 --- a/gcc/ada/a-ststio.ads +++ b/gcc/ada/a-ststio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -144,6 +144,36 @@ package Ada.Streams.Stream_IO is Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + pragma Export_Procedure + (Internal => Set_Mode, + External => "", + Mechanism => (File => Reference)); + package FCB renames System.File_Control_Block; ----------------------------- diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index 9247ba7f7aa..cc5a93bb076 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -148,7 +148,7 @@ package body Ada.Text_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- @@ -247,7 +247,7 @@ package body Ada.Text_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -1585,7 +1585,7 @@ package body Ada.Text_IO is end if; Terminate_Line (File); - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; @@ -1598,7 +1598,7 @@ package body Ada.Text_IO is procedure Reset (File : in out File_Type) is begin Terminate_Line (File); - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads index 45f422f7bf1..35cb5162f71 100644 --- a/gcc/ada/a-textio.ads +++ b/gcc/ada/a-textio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -301,6 +301,32 @@ package Ada.Text_IO is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + ----------------------------------- -- Handling of Format Characters -- ----------------------------------- diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index 25d265c218e..1a4b0f5e0e7 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -134,7 +134,7 @@ package body Ada.Wide_Text_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- @@ -233,7 +233,7 @@ package body Ada.Wide_Text_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -1320,7 +1320,7 @@ package body Ada.Wide_Text_IO is end if; Terminate_Line (File); - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; @@ -1333,7 +1333,7 @@ package body Ada.Wide_Text_IO is procedure Reset (File : in out File_Type) is begin Terminate_Line (File); - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads index 0ea32ce2b0c..d35de1327d2 100644 --- a/gcc/ada/a-witeio.ads +++ b/gcc/ada/a-witeio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -301,6 +301,32 @@ package Ada.Wide_Text_IO is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + package WCh_Con renames System.WCh_Con; ----------------------------------- diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb index a85cdb30998..4bf70405c67 100644 --- a/gcc/ada/a-ztexio.adb +++ b/gcc/ada/a-ztexio.adb @@ -134,7 +134,7 @@ package body Ada.Wide_Wide_Text_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- @@ -233,7 +233,7 @@ package body Ada.Wide_Wide_Text_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -1320,7 +1320,7 @@ package body Ada.Wide_Wide_Text_IO is end if; Terminate_Line (File); - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; @@ -1333,7 +1333,7 @@ package body Ada.Wide_Wide_Text_IO is procedure Reset (File : in out File_Type) is begin Terminate_Line (File); - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads index f91599295a4..b1b50fc59a7 100644 --- a/gcc/ada/a-ztexio.ads +++ b/gcc/ada/a-ztexio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -301,6 +301,32 @@ package Ada.Wide_Wide_Text_IO is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + package WCh_Con renames System.WCh_Con; ----------------------------------- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 475edd513f5..d29857fb5fc 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -3260,14 +3260,17 @@ package body Bindgen is for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); - -- The procedure of looking for specific packages and setting - -- flags is somewhat dubious, but there isn't a good alternative - -- at the current time ??? + -- This is not a perfect approach, but is the current protocol + -- between the run-time and the binder to indicate that tasking + -- is used: system.os_interface should always be used by any + -- tasking application. if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; end if; + -- Ditto for declib and the "dec" package + if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then With_DECGNAT := True; end if; diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 876ec5a19a3..5db4c4efc67 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -346,7 +346,7 @@ package body Clean is -- The name of the archive dependency file for this project Obj_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); begin Change_Dir (Obj_Dir); @@ -551,10 +551,10 @@ package body Clean is Unit : Unit_Data; begin - if Data.Library and then Data.Library_Src_Dir /= No_Path then + if Data.Library and then Data.Library_Src_Dir /= No_Path_Information then declare Directory : constant String := - Get_Name_String (Data.Display_Library_Src_Dir); + Get_Name_String (Data.Library_Src_Dir.Display_Name); begin Change_Dir (Directory); @@ -663,10 +663,11 @@ package body Clean is declare Lib_Directory : constant String := - Get_Name_String (Data.Display_Library_Dir); + Get_Name_String + (Data.Library_Dir.Display_Name); Lib_ALI_Directory : constant String := Get_Name_String - (Data.Display_Library_ALI_Dir); + (Data.Library_ALI_Dir.Display_Name); begin Canonical_Case_File_Name (Archive_Name); @@ -863,10 +864,11 @@ package body Clean is Processed_Projects.Increment_Last; Processed_Projects.Table (Processed_Projects.Last) := Project; - if Data.Object_Directory /= No_Path then + if Data.Object_Directory /= No_Path_Information then declare Obj_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String + (Data.Object_Directory.Display_Name); begin Change_Dir (Obj_Dir); @@ -1089,16 +1091,16 @@ package body Clean is if not Compile_Only then Clean_Library_Directory (Project); - if Data.Library_Src_Dir /= No_Path then + if Data.Library_Src_Dir /= No_Path_Information then Clean_Interface_Copy_Directory (Project); end if; end if; if Data.Standalone_Library and then - Data.Object_Directory /= No_Path + Data.Object_Directory /= No_Path_Information then Delete_Binder_Generated_Files - (Get_Name_String (Data.Display_Object_Dir), + (Get_Name_String (Data.Object_Directory.Display_Name), File_Name_Type (Data.Library_Name)); end if; end if; @@ -1156,10 +1158,12 @@ package body Clean is -- The executables are deleted only if switch -c is not specified - if Project = Main_Project and then Data.Exec_Directory /= No_Path then + if Project = Main_Project + and then Data.Exec_Directory /= No_Path_Information + then declare Exec_Dir : constant String := - Get_Name_String (Data.Display_Exec_Dir); + Get_Name_String (Data.Exec_Directory.Display_Name); begin Change_Dir (Exec_Dir); @@ -1193,9 +1197,9 @@ package body Clean is end; end if; - if Data.Object_Directory /= No_Path then + if Data.Object_Directory /= No_Path_Information then Delete_Binder_Generated_Files - (Get_Name_String (Data.Display_Object_Dir), + (Get_Name_String (Data.Object_Directory.Display_Name), Strip_Suffix (Main_Source_File)); end if; end loop; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 34b5644d6d2..40ff3796671 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -544,6 +544,13 @@ package body Exp_Aggr is return False; end if; + -- If component is limited, aggregate must be expanded because each + -- component assignment must be built in place. + + if Is_Inherently_Limited_Type (Component_Type (Typ)) then + return False; + end if; + -- Checks 4 (array must not be multi-dimensional Fortran case) if Convention (Typ) = Convention_Fortran @@ -1514,6 +1521,16 @@ package body Exp_Aggr is Make_Integer_Literal (Loc, Uint_0)))); end if; + -- If the component type contains tasks, we need to build a Master + -- entity in the current scope, because it will be needed if build- + -- in-place functions are called in the expanded code. + + if Nkind (Parent (N)) = N_Object_Declaration + and then Has_Task (Typ) + then + Build_Master_Entity (Defining_Identifier (Parent (N))); + end if; + -- STEP 1: Process component associations -- For those associations that may generate a loop, initialize @@ -4041,7 +4058,7 @@ package body Exp_Aggr is -- Aggr_Lo <= Aggr_Hi and then -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] - -- As an optimization try to see if some tests are trivially vacuos + -- As an optimization try to see if some tests are trivially vacuous -- because we are comparing an expression against itself. if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then @@ -4672,6 +4689,8 @@ package body Exp_Aggr is Make_Raise_Constraint_Error (Loc, Condition => Cond, Reason => CE_Length_Check_Failed)); + -- Questionable reason code, shouldn't that be a + -- CE_Range_Check_Failed ??? end if; -- Now look inside the sub-aggregate to see if there is more work @@ -4953,6 +4972,13 @@ package body Exp_Aggr is and then In_Place_Assign_OK); end if; + -- If this is an array of tasks, it will be expanded into build-in- + -- -place assignments. Build an activation chain for the tasks now + + if Has_Task (Etype (N)) then + Build_Activation_Chain_Entity (N); + end if; + if not Has_Default_Init_Comps (N) and then Comes_From_Source (Parent (N)) and then Nkind (Parent (N)) = N_Object_Declaration diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index c1195518c97..b110121bc5e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -533,11 +533,12 @@ package body Exp_Ch3 is --------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is - Loc : constant Source_Ptr := Sloc (Nod); - Comp_Type : constant Entity_Id := Component_Type (A_Type); - Index_List : List_Id; - Proc_Id : Entity_Id; - Body_Stmts : List_Id; + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Index_List : List_Id; + Proc_Id : Entity_Id; + Body_Stmts : List_Id; + Has_Default_Init : Boolean; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated @@ -671,14 +672,16 @@ package body Exp_Ch3 is -- the issue arises) in a special manner anyway which does not need an -- init_proc. - if Has_Non_Null_Base_Init_Proc (Comp_Type) - or else Needs_Simple_Initialization (Comp_Type) - or else Has_Task (Comp_Type) + Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Needs_Simple_Initialization (Comp_Type) + or else Has_Task (Comp_Type); + + if Has_Default_Init or else (not Restriction_Active (No_Initialize_Scalars) - and then Is_Public (A_Type) - and then Root_Type (A_Type) /= Standard_String - and then Root_Type (A_Type) /= Standard_Wide_String - and then Root_Type (A_Type) /= Standard_Wide_Wide_String) + and then Is_Public (A_Type) + and then Root_Type (A_Type) /= Standard_String + and then Root_Type (A_Type) /= Standard_Wide_String + and then Root_Type (A_Type) /= Standard_Wide_Wide_String) then Proc_Id := Make_Defining_Identifier (Loc, @@ -688,9 +691,16 @@ package body Exp_Ch3 is -- want to build an init_proc, but we need to mark that an init_proc -- would be needed if this restriction was not active (so that we can -- detect attempts to call it), so set a dummy init_proc in place. + -- This is only done though when actual default initialization is + -- needed, so we exclude the setting in the Is_Public case, such + -- as for arrays of scalars, since otherwise such objects would be + -- wrongly flagged as violating the restriction. if Restriction_Active (No_Default_Initialization) then - Set_Init_Proc (A_Type, Proc_Id); + if Has_Default_Init then + Set_Init_Proc (A_Type, Proc_Id); + end if; + return; end if; @@ -4268,7 +4278,11 @@ package body Exp_Ch3 is and then not Suppress_Init_Proc (Typ) then - Check_Restriction (No_Default_Initialization, N); + -- Return without initializing when No_Default_Initialization + -- applies. Note that the actual restriction check occurs later, + -- when the object is frozen, because we don't know yet whether + -- the object is imported, which is a case where the check does + -- not apply. if Restriction_Active (No_Default_Initialization) then return; @@ -4314,7 +4328,6 @@ package body Exp_Ch3 is and then not Is_Internal (Def_Id) and then not Has_Init_Expression (N) then - Check_Restriction (No_Default_Initialization, N); Set_No_Initialization (N, False); Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); @@ -7347,7 +7360,7 @@ package body Exp_Ch3 is -- return False; -- end if; - -- or a null statement if the list L is empty. + -- or a null statement if the list L is empty function Make_Eq_If (E : Entity_Id; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9b471853552..3afb7696770 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -41,6 +41,7 @@ with Exp_Intr; use Exp_Intr; with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; with Fname; use Fname; with Freeze; use Freeze; with Inline; use Inline; @@ -3963,6 +3964,21 @@ package body Exp_Ch6 is procedure Expand_N_Function_Call (N : Node_Id) is begin Expand_Call (N); + + -- If the return value of a foreign compiled function is + -- VAX Float then expand the return (adjusts the location + -- of the return value on Alpha/VMS, noop everywere else). + -- Comes_From_Source intercepts recursive expansion. + + if Vax_Float (Etype (N)) + and then Nkind (N) = N_Function_Call + and then Present (Name (N)) + and then Present (Entity (Name (N))) + and then Has_Foreign_Convention (Entity (Name (N))) + and then Comes_From_Source (Parent (N)) + then + Expand_Vax_Foreign_Return (N); + end if; end Expand_N_Function_Call; --------------------------------------- @@ -5166,9 +5182,9 @@ package body Exp_Ch6 is end if; end Make_Build_In_Place_Call_In_Anonymous_Context; - --------------------------------------------------- + -------------------------------------------- -- Make_Build_In_Place_Call_In_Assignment -- - --------------------------------------------------- + -------------------------------------------- procedure Make_Build_In_Place_Call_In_Assignment (Assign : Node_Id; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 860fd17352c..864206951f6 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -173,25 +173,28 @@ package body Exp_Disp is -- Handle private types of library level tagged types. We must -- exchange the private and full-view to ensure the correct - -- expansion. + -- expansion. If the full view is a synchronized type ignore + -- the type because the table will be built for the corresponding + -- record type, that has its own declaration. elsif (Nkind (D) = N_Private_Type_Declaration or else Nkind (D) = N_Private_Extension_Declaration) and then Present (Full_View (Defining_Entity (D))) - and then Is_Library_Level_Tagged_Type - (Full_View (Defining_Entity (D))) - and then Ekind (Full_View (Defining_Entity (D))) - /= E_Record_Subtype then declare E1 : constant Entity_Id := Defining_Entity (D); - E2 : constant Entity_Id := Full_View (Defining_Entity (D)); + E2 : constant Entity_Id := Full_View (E1); begin - Exchange_Declarations (E1); - Insert_List_After_And_Analyze (Last (Target_List), - Make_DT (E1)); - Exchange_Declarations (E2); + if Is_Library_Level_Tagged_Type (E2) + and then Ekind (E2) /= E_Record_Subtype + and then not Is_Concurrent_Type (E2) + then + Exchange_Declarations (E1); + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (E1)); + Exchange_Declarations (E2); + end if; end; end if; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 47e193fb8bc..973948c4287 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -43,7 +43,6 @@ with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; -with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; @@ -184,6 +183,12 @@ package body Exp_Dist is -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id; + -- Return an expression denoting the tag of the stub type associated with + -- RACW_Type. + function Build_Subprogram_Calling_Stubs (Vis_Decl : Node_Id; Subp_Id : Node_Id; @@ -382,6 +387,9 @@ package body Exp_Dist is Equal => "="); -- Mapping between a RCI subprogram and the corresponding calling stubs + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; + -- Return the stub information associated with the given RACW type + procedure Add_Stub_Type (Designated_Type : Entity_Id; RACW_Type : Entity_Id; @@ -1247,6 +1255,7 @@ package body Exp_Dist is RPC_Receiver := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('P')); + Specific_Build_RPC_Receiver_Body (RPC_Receiver => RPC_Receiver, Request => RPC_Receiver_Request, @@ -1388,13 +1397,14 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), Make_String_Literal (Loc, Subp_Str))), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of ( RPC_Receiver_Subp_Index, Loc), Expression => Make_Integer_Literal (Loc, - Current_Primitive_Number))))); + Intval => Current_Primitive_Number))))); end if; Append_To (RPC_Receiver_Case_Alternatives, @@ -1465,10 +1475,6 @@ package body Exp_Dist is RAS_Type : constant Entity_Id := Defining_Identifier (N); Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); - Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); - - Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); RACW_Primitive_Name : Node_Id; @@ -1642,17 +1648,16 @@ package body Exp_Dist is Subp_Name : constant Entity_Id := Defining_Unit_Name (Specification (Vis_Decl)); - Pkg_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subp_Name), 'P', -1)); + Pkg_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); Proxy_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => - New_External_Name ( - Related_Id => Chars (Subp_Name), - Suffix => 'P')); + New_External_Name + (Related_Id => Chars (Subp_Name), + Suffix => 'P')); Proxy_Type_Full_View : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -1698,12 +1703,9 @@ package body Exp_Dist is Append_To (Vis_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Proxy_Object_Addr, - Constant_Present => - True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); + Defining_Identifier => Proxy_Object_Addr, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); -- private @@ -1714,8 +1716,7 @@ package body Exp_Dist is Append_To (Pvt_Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Proxy_Type_Full_View, + Defining_Identifier => Proxy_Type_Full_View, Type_Definition => Build_Remote_Subprogram_Proxy_Type (Loc, New_Occurrence_Of (All_Calls_Remote_E, Loc)))); @@ -1743,19 +1744,15 @@ package body Exp_Dist is if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then Perform_Call := Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Subp_Name, Loc), - Parameter_Associations => - Actuals); + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals); else Perform_Call := Make_Simple_Return_Statement (Loc, Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Subp_Name, Loc), - Parameter_Associations => - Actuals)); + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals)); end if; Formal := First (Parameter_Specifications (Subp_Decl_Spec)); @@ -1771,31 +1768,23 @@ package body Exp_Dist is Append_To (Pvt_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Name_uO), - Aliased_Present => - True, - Object_Definition => - New_Occurrence_Of (Proxy_Type, Loc))); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); -- A : constant System.Address := O'Address; Append_To (Pvt_Decls, Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars (Proxy_Object_Addr)), - Constant_Present => - True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc), + Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Last (Pvt_Decls)), Loc), - Attribute_Name => - Name_Address))); + Attribute_Name => Name_Address))); Append_To (Decls, Make_Package_Declaration (Loc, @@ -1809,12 +1798,10 @@ package body Exp_Dist is Append_To (Decls, Make_Package_Body (Loc, Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars (Pkg_Name)), + Make_Defining_Identifier (Loc, Chars (Pkg_Name)), Declarations => New_List ( Make_Subprogram_Body (Loc, - Specification => - Subp_Body_Spec, + Specification => Subp_Body_Spec, Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -2058,10 +2045,8 @@ package body Exp_Dist is Chars => Name_Address, Expression => Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Constant_Object, Loc), - Attribute_Name => - Name_Address))); + Prefix => New_Occurrence_Of (Constant_Object, Loc), + Attribute_Name => Name_Address))); end; end if; @@ -2077,8 +2062,7 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Object, Constant_Present => Present (Expr) and then not Variable, - Object_Definition => - New_Occurrence_Of (Etyp, Loc), + Object_Definition => New_Occurrence_Of (Etyp, Loc), Expression => Expr)); if Constant_Present (Last (Decls)) then @@ -2110,17 +2094,14 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), + Prefix => New_Occurrence_Of (Pointer, Loc), Selector_Name => New_Occurrence_Of (First_Tag_Component (Designated_Type (Etype (Pointer))), Loc)), Expression => Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stub_Type, Loc), - Attribute_Name => - Name_Tag))); + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag))); -- Note: The assignment to Pointer._Tag is safe here because -- we carefully ensured that Stub_Type has exactly the same layout @@ -2227,8 +2208,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version))); + Attribute_Name => Name_Version))); Append_To (L, Reg); Analyze (Reg); end Build_Passive_Partition_Stub; @@ -2302,6 +2282,22 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); end Build_Remote_Subprogram_Proxy_Type; + -------------------- + -- Build_Stub_Tag -- + -------------------- + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id + is + Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag); + end Build_Stub_Tag; + ------------------------------------ -- Build_Subprogram_Calling_Stubs -- ------------------------------------ @@ -2689,8 +2685,7 @@ package body Exp_Dist is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_NVList_Create), Loc), + Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (NVList, Loc)))); end Declare_Create_NVList; @@ -2818,7 +2813,9 @@ package body Exp_Dist is declare HSS_Stmts : constant List_Id := Statements (Handled_Statement_Sequence (Unit_Node)); + First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); + begin if No (First_HSS_Stmt) then Append_List_To (HSS_Stmts, Stubs_Stmts); @@ -2878,7 +2875,8 @@ package body Exp_Dist is (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; - Stub_Elements : Stub_Structure) is + Stub_Elements : Stub_Structure) + is begin -- The RPC receiver body should not be the completion of the -- declaration recorded in the stub structure, because then the @@ -2931,18 +2929,18 @@ package body Exp_Dist is Attribute_Name => Name_Address); end if; - Add_RACW_Write_Attribute ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - RPC_Receiver, - Body_Decls); - - Add_RACW_Read_Attribute ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - Body_Decls); + Add_RACW_Write_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver, + Body_Decls); + + Add_RACW_Read_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + Body_Decls); end Add_RACW_Features; ----------------------------- @@ -3001,6 +2999,7 @@ package body Exp_Dist is Insert_After (Proc_Decl, Attr_Decl); if No (Body_Decls) then + -- Case of processing an RACW type from another unit than the -- main one: do not generate a body. @@ -3273,35 +3272,31 @@ package body Exp_Dist is -- a remote object. Remote_Statements := New_List ( - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => + Stream => Stream_Parameter, + Object => Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Origin)), - Etyp => RTE (RE_Partition_ID)), + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)), + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), Etyp => RTE (RE_Unsigned_64)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Addr)), + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Addr)), Etyp => RTE (RE_Unsigned_64))); -- Build code fragment corresponding to marshalling of a null object @@ -3328,7 +3323,9 @@ package body Exp_Dist is Make_Op_Eq (Loc, Left_Opnd => Object, Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( Make_Elsif_Part (Loc, Condition => @@ -3337,6 +3334,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => Object, Attribute_Name => Name_Tag), + Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stub_Type, Loc), @@ -3451,7 +3449,7 @@ package body Exp_Dist is begin Proc_Decls := New_List ( - -- Common declarations + -- Common declarations Make_Object_Declaration (Loc, Defining_Identifier => Origin, @@ -3465,15 +3463,15 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc)))), - -- Declaration use only in the local case: proxy address + -- Declaration use only in the local case: proxy address Make_Object_Declaration (Loc, Defining_Identifier => Proxy_Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), - -- Declarations used only in the remote case: stub object and - -- stub pointer. + -- Declarations used only in the remote case: stub object and + -- stub pointer. Make_Object_Declaration (Loc, Defining_Identifier => Local_Stub, @@ -3492,7 +3490,8 @@ package body Exp_Dist is Attribute_Name => Name_Unchecked_Access))); Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); - -- Build_Get_Unique_RP_Call needs this information + + -- Build_Get_Unique_RP_Call needs above information -- Note: Here we assume that the Fat_Type is a record -- containing just a pointer to a proxy or stub object. @@ -3509,8 +3508,7 @@ package body Exp_Dist is -- end if; Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), @@ -3527,9 +3525,11 @@ package body Exp_Dist is Make_Function_Call (Loc, New_Occurrence_Of ( RTE (RE_Get_Local_Partition_Id), Loc))), + Right_Opnd => Make_Op_Not (Loc, New_Occurrence_Of (All_Calls_Remote, Loc))), + Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Unchecked_Convert_To (Fat_Type, @@ -3548,12 +3548,12 @@ package body Exp_Dist is Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), - -- E.4.1(9) A remote call is asynchronous if it is a call to - -- a procedure, or a call through a value of an access-to-procedure - -- type, to which a pragma Asynchronous applies. + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure or a call through a value of an access-to-procedure + -- type to which a pragma Asynchronous applies. - -- Parameter Asynch_P is true when the procedure is asynchronous; - -- Expression Asynch_T is true when the type is asynchronous. + -- Asynch_P is true when the procedure is asynchronous; + -- Asynch_T is true when the type is asynchronous. Set_Field (Name_Asynchronous, Make_Or_Else (Loc, @@ -3704,8 +3704,7 @@ package body Exp_Dist is New_List ( Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - Defining_Entity (Stubs), Loc), + New_Occurrence_Of (Defining_Entity (Stubs), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))))); end Append_Stubs_To; @@ -3748,10 +3747,12 @@ package body Exp_Dist is Make_Op_Eq (Loc, New_Occurrence_Of (Subp_Id, Loc), Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Subp_Id, Loc), + Expression => Make_Selected_Component (Loc, Prefix => @@ -3766,6 +3767,7 @@ package body Exp_Dist is Make_Selected_Component (Loc, Prefix => Request_Parameter, Selector_Name => Name_Params))))), + Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); @@ -3787,6 +3789,7 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Current_Declaration); Analyze (Current_Declaration); @@ -3869,6 +3872,7 @@ package body Exp_Dist is Choices => New_List ( Make_Integer_Literal (Loc, Current_Subprogram_Number)), + Expression => Make_Aggregate (Loc, Component_Associations => New_List ( @@ -3880,10 +3884,8 @@ package body Exp_Dist is Proxy_Object_Addr, Loc)))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Stubs => - Current_Stubs, - Subprogram_Number => - Current_Subprogram_Number); + Stubs => Current_Stubs, + Subprogram_Number => Current_Subprogram_Number); end; Current_Subprogram_Number := Current_Subprogram_Number + 1; @@ -3902,15 +3904,12 @@ package body Exp_Dist is Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => - New_List (Make_Null_Statement (Loc)))); + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (Subp_Id, Loc), + Expression => New_Occurrence_Of (Subp_Id, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); Append_To (Decls, @@ -3930,8 +3929,9 @@ package body Exp_Dist is First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))))); + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); -- For a degenerate RCI with no visible subprograms, Subp_Info_List -- has zero length, and the declaration is for an empty array, in @@ -3962,13 +3962,11 @@ package body Exp_Dist is Make_Selected_Component (Loc, Prefix => Make_Indexed_Component (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), Expressions => New_List ( Convert_To (Standard_Integer, Make_Identifier (Loc, Name_Subp_Id)))), - Selector_Name => - Make_Identifier (Loc, Name_Addr)); + Selector_Name => Make_Identifier (Loc, Name_Addr)); -- Case of no visible subprogram: just raise Constraint_Error, we -- know for sure we got junk from a remote partition. @@ -3984,15 +3982,14 @@ package body Exp_Dist is Make_Subprogram_Body (Loc, Specification => Copy_Specification (Loc, Parent (Lookup_RAS_Info)), - Declarations => - No_List, + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => - OK_Convert_To (RTE (RE_Unsigned_64), - Subp_Info_Addr)))))); + OK_Convert_To + (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); end; Analyze (Last (Decls)); @@ -4012,10 +4009,8 @@ package body Exp_Dist is Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Pkg_RPC_Receiver, Loc), - Attribute_Name => - Name_Unrestricted_Access)); + Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Unrestricted_Access)); -- Version @@ -4023,26 +4018,21 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version)); + Attribute_Name => Name_Version)); -- Subp_Info Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Address)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); -- Subp_Info_Len Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Length)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); -- Generate the call @@ -4180,10 +4170,8 @@ package body Exp_Dist is Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), Target_RPC_Receiver))); -- Then put the Subprogram_Id of the subprogram we want to call in @@ -4191,14 +4179,11 @@ package body Exp_Dist is Append_To (Statements, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => - Name_Write, + Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), Subprogram_Id))); @@ -4214,7 +4199,7 @@ package body Exp_Dist is begin if Is_RACW_Controlling_Formal - (Current_Parameter, Stub_Type) + (Current_Parameter, Stub_Type) then -- In the case of a controlling formal argument, we marshall -- its addr field rather than the local stub. @@ -4230,8 +4215,9 @@ package body Exp_Dist is Etyp => RTE (RE_Unsigned_64))); else - Value := New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); -- Access type parameters are transmitted as in out -- parameters. However, a dereference is needed so that @@ -4255,8 +4241,7 @@ package body Exp_Dist is then Append_To (Statements, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etyp, Loc), + Prefix => New_Occurrence_Of (Etyp, Loc), Attribute_Name => Output_From_Constrained (Constrained), Expressions => New_List ( @@ -4302,13 +4287,12 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => - Name_Write, + Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => + New_Occurrence_Of + (Stream_Parameter, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Extra_Parameter, Loc)))); end if; @@ -4334,8 +4318,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access)))); + Attribute_Name => Name_Access)))); else Asynchronous_Statements := No_List; end if; @@ -4354,14 +4337,12 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), + Attribute_Name => Name_Access), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access)))); + Attribute_Name => Name_Access)))); -- Read the exception occurrence from the result stream and -- reraise it. It does no harm if this is a Null_Occurrence since @@ -4372,15 +4353,13 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), - Attribute_Name => - Name_Read, + Attribute_Name => Name_Read, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), + Attribute_Name => Name_Access), New_Occurrence_Of (Exception_Return_Parameter, Loc)))); Append_To (Non_Asynchronous_Statements, @@ -4453,8 +4432,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), + Attribute_Name => Name_Access), Value))); end if; end; @@ -4545,9 +4523,9 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), Attribute_Name => Name_Input, Expressions => New_List ( - Make_Selected_Component (Loc, - Prefix => Request, - Selector_Name => Name_Params))))); + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Params))))); Stmts := New_List; @@ -4785,9 +4763,9 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), Attribute_Name => Name_Write, Expressions => New_List ( - Make_Selected_Component (Loc, - Prefix => Request_Parameter, - Selector_Name => Name_Result), + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); if Dynamically_Asynchronous then @@ -4870,15 +4848,19 @@ package body Exp_Dist is Append_To (Decls, Input_With_Tag_Check (Loc, Var_Type => Etyp, - Stream => Make_Selected_Component (Loc, - Prefix => Request_Parameter, - Selector_Name => Name_Params))); + Stream => + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))); -- Prepare function call expression - Expr := Make_Function_Call (Loc, - New_Occurrence_Of (Defining_Unit_Name - (Specification (Last (Decls))), Loc)); + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (Defining_Unit_Name + (Specification (Last (Decls))), Loc)); end if; end if; @@ -5217,6 +5199,19 @@ package body Exp_Dist is end Get_And_Reset_RACW_Bodies; ----------------------- + -- Get_Stub_Elements -- + ----------------------- + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + return Stub_Elements; + end Get_Stub_Elements; + + ----------------------- -- Get_Subprogram_Id -- ----------------------- @@ -5502,16 +5497,11 @@ package body Exp_Dist is procedure Add_RACW_From_Any (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; Body_Decls : List_Id); -- Add the From_Any TSS for this RACW type procedure Add_RACW_To_Any - (Designated_Type : Entity_Id; - RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; + (RACW_Type : Entity_Id; Body_Decls : List_Id); -- Add the To_Any TSS for this RACW type @@ -5598,21 +5588,12 @@ package body Exp_Dist is begin Add_RACW_From_Any (RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, Body_Decls => Body_Decls); Add_RACW_To_Any - (Designated_Type => Desig, - RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, + (RACW_Type => RACW_Type, Body_Decls => Body_Decls); - -- In the PolyORB case, the RACW 'Read and 'Write attributes are - -- implemented in terms of the From_Any and To_Any TSSs, so these - -- TSSs must be expanded before 'Read and 'Write. - Add_RACW_Write_Attribute (RACW_Type => RACW_Type, Stub_Type => Stub_Type, @@ -5637,8 +5618,6 @@ package body Exp_Dist is procedure Add_RACW_From_Any (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); @@ -5652,28 +5631,12 @@ package body Exp_Dist is Func_Decl : Node_Id; Func_Body : Node_Id; - Decls : List_Id; Statements : List_Id; - Stub_Statements : List_Id; - Local_Statements : List_Id; -- Various parts of the subprogram Any_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_A); - Reference : Entity_Id; - Is_Local : Entity_Id; - Addr : Entity_Id; - Local_Stub : Entity_Id; - Stubbed_Result : Entity_Id; - - Stub_Condition : Node_Id; - -- An expression that determines whether we create a stub for the - -- newly-unpacked RACW. Normally we create a stub only for remote - -- objects, but in the case of an RACW used to implement a RAS, we - -- also create a stub for local subprograms if a pragma - -- All_Calls_Remote applies. - Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); -- The flag object declared in Add_RACW_Asynchronous_Flag @@ -5702,119 +5665,6 @@ package body Exp_Dist is return; end if; - -- Object declarations - - Reference := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Is_Local := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Addr := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Local_Stub := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Stubbed_Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - - Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => - Reference, - Object_Definition => - New_Occurrence_Of (RTE (RE_Object_Ref), Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Any_Parameter, Loc)))), - - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Stubbed_Result, - Object_Definition => - New_Occurrence_Of (Stub_Type_Access, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Local_Stub, Loc), - Attribute_Name => - Name_Unchecked_Access)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Is_Local, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Addr, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); - - -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result - - Set_Etype (Stubbed_Result, Stub_Type_Access); - - -- If the ref Is_Nil, return a null pointer - - Statements := New_List ( - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Is_Nil), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc))), - Then_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Null (Loc))))); - - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - New_Occurrence_Of (Is_Local, Loc), - New_Occurrence_Of (Addr, Loc)))); - - -- If the object is located on another partition, then a stub object - -- will be created with all the information needed to rebuild the - -- real object at the other end. This stanza is always used in the - -- case of RAS types, for which a stub is required even for local - -- subprograms. - - Stub_Statements := New_List ( - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Target), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc)))), - - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), - Parameter_Associations => New_List ( - Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Target))), - - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Asynchronous), - Expression => - New_Occurrence_Of (Asynchronous_Flag, Loc))); - -- ??? Issue with asynchronous calls here: the Asynchronous flag is -- set on the stub type if, and only if, the RACW type has a pragma -- Asynchronous. This is incorrect for RACWs that implement RAS @@ -5825,52 +5675,24 @@ package body Exp_Dist is -- the Asynchronous component in the stub type in the RAS's _From_Any -- TSS. - Append_List_To (Stub_Statements, - Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); - - -- Distinguish between the local and remote cases, and execute the - -- appropriate piece of code. - - Stub_Condition := New_Occurrence_Of (Is_Local, Loc); - - if Is_RAS then - Stub_Condition := Make_And_Then (Loc, - Left_Opnd => - Stub_Condition, - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, - Name_All_Calls_Remote))); - end if; - - Local_Statements := New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Addr, Loc)))); - - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Stub_Condition, - Then_Statements => Local_Statements, - Else_Statements => Stub_Statements)); - - Append_To (Statements, + Statements := New_List ( Make_Simple_Return_Statement (Loc, Expression => Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Stubbed_Result, Loc)))); + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc)))))); Func_Body := Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Func_Spec), - Declarations => Decls, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements)); @@ -5898,21 +5720,24 @@ package body Exp_Dist is Body_Node : Node_Id; - Decls : List_Id; - Statements : constant List_Id := New_List; + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + Reference : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); -- Various parts of the procedure - Pnam : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('R')); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - Source_Ref : Entity_Id; Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); function Stream_Parameter return Node_Id; function Result return Node_Id; + -- Functions to create occurrences of the formal parameter names ------------ @@ -5957,15 +5782,11 @@ package body Exp_Dist is return; end if; - Source_Ref := Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); - - -- Generate object declarations - - Decls := New_List ( + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Source_Ref, - Object_Definition => + Defining_Identifier => + Reference, + Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); Append_List_To (Statements, New_List ( @@ -5975,19 +5796,21 @@ package body Exp_Dist is Attribute_Name => Name_Read, Expressions => New_List ( Stream_Parameter, - New_Occurrence_Of (Source_Ref, Loc))), + New_Occurrence_Of (Reference, Loc))), + Make_Assignment_Statement (Loc, - Name => + Name => Result, Expression => - PolyORB_Support.Helpers.Build_From_Any_Call ( - RACW_Type, + Unchecked_Convert_To (RACW_Type, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), + Name => + New_Occurrence_Of (RTE (RE_Get_RACW), Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Source_Ref, Loc))), - Decls)))); + New_Occurrence_Of (Reference, Loc), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc))))))); Set_Declarations (Body_Node, Decls); Append_To (Body_Decls, Body_Node); @@ -5998,23 +5821,19 @@ package body Exp_Dist is --------------------- procedure Add_RACW_To_Any - (Designated_Type : Entity_Id; - RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; + (RACW_Type : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); - Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (RACW_Type), 'T')); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Designated_Type); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Get_Stub_Elements (RACW_Type); Func_Spec : Node_Id; Func_Decl : Node_Id; @@ -6022,10 +5841,6 @@ package body Exp_Dist is Decls : List_Id; Statements : List_Id; - Null_Statements : List_Id; - Local_Statements : List_Id := No_List; - Stub_Statements : List_Id; - If_Node : Node_Id; -- Various parts of the subprogram RACW_Parameter : constant Entity_Id := @@ -6063,120 +5878,62 @@ package body Exp_Dist is return; end if; - -- Object declarations + -- Generate: + + -- R : constant Object_Ref := + -- Get_Reference + -- (Address!(RACW), + -- "typ", + -- Stub_Type'Tag, + -- Is_RAS, + -- RPC_Receiver'Access); + -- A : Any; Decls := New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => - Reference, - Object_Definition => - New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), - Make_Object_Declaration (Loc, - Defining_Identifier => - Any, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any), Loc))); - - -- If the object is null, nothing to do (Reference is already - -- a Nil ref.) - - Null_Statements := New_List (Make_Null_Statement (Loc)); - - if Is_RAS then - - -- If the object is a RAS designating a local subprogram, we - -- already have a target reference. - - Local_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Ref), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (RACW_Parameter, Loc)), - Selector_Name => Make_Identifier (Loc, Name_Target))))); - - else - -- If the object is a local RACW object, use Get_Reference now to - -- obtain a reference. - - Local_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Reference), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To ( - RTE (RE_Address), - New_Occurrence_Of (RACW_Parameter, Loc)), - Make_String_Literal (Loc, - Full_Qualified_Name (Designated_Type)), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Defining_Identifier ( - Stub_Elements.RPC_Receiver_Decl), Loc), - Attribute_Name => - Name_Access), - New_Occurrence_Of (Reference, Loc)))); - end if; - - -- If the object is located on another partition, use the target from - -- the stub. + Defining_Identifier => Reference, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Occurrence_Of (RACW_Parameter, Loc)), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access)))), - Stub_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Ref), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - New_Occurrence_Of (RACW_Parameter, Loc)), - Selector_Name => - Make_Identifier (Loc, Name_Target))))); + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); - -- Distinguish between the null, local and remote cases, and execute - -- the appropriate piece of code. + -- Generate: - If_Node := - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc), - Right_Opnd => Make_Null (Loc)), - Then_Statements => Null_Statements, - Elsif_Parts => New_List ( - Make_Elsif_Part (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RACW_Parameter, Loc), - Attribute_Name => Name_Tag), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Stub_Type, Loc), - Attribute_Name => Name_Tag)), - Then_Statements => Local_Statements)), - Else_Statements => Stub_Statements); + -- Any := TA_ObjRef (Reference); + -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); + -- return Any; Statements := New_List ( - If_Node, Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Any, Loc), + Name => New_Occurrence_Of (Any, Loc), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Reference, Loc)))), + Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), Make_Selected_Component (Loc, @@ -6184,14 +5941,13 @@ package body Exp_Dist is Defining_Identifier ( Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))), + Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (Any, Loc))); + Expression => New_Occurrence_Of (Any, Loc))); Func_Body := Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Func_Spec), + Specification => Copy_Specification (Loc, Func_Spec), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -6229,9 +5985,8 @@ package body Exp_Dist is Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, - Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); -- NOTE: The usage occurrences of RACW_Parameter must refer to the -- entity in the declaration spec, not those of the body spec. @@ -6246,8 +6001,7 @@ package body Exp_Dist is Func_Body := Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Func_Spec), + Specification => Copy_Specification (Loc, Func_Spec), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -6256,8 +6010,8 @@ package body Exp_Dist is Expression => Make_Selected_Component (Loc, Prefix => - Defining_Identifier ( - Stub_Elements.RPC_Receiver_Decl), + Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))))); Append_To (Body_Decls, Func_Body); @@ -6279,11 +6033,16 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + Body_Node : Node_Id; Proc_Decl : Node_Id; Attr_Decl : Node_Id; - Statements : constant List_Id := New_List; + Statements : constant List_Id := New_List; Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); @@ -6296,15 +6055,8 @@ package body Exp_Dist is ------------ function Object return Node_Id is - Object_Ref : constant Node_Id := - Make_Identifier (Loc, Name_V); - begin - -- Etype must be set for Build_To_Any_Call - - Set_Etype (Object_Ref, RACW_Type); - - return Object_Ref; + return Make_Identifier (Loc, Name_V); end Object; ---------------------- @@ -6346,11 +6098,21 @@ package body Exp_Dist is Stream => Stream_Parameter, Object => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_To_Any_Call - (Object, Body_Decls))), + Unchecked_Convert_To (RTE (RE_Address), Object), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access))), + Etyp => RTE (RE_Object_Ref))); Append_To (Body_Decls, Body_Node); @@ -6388,13 +6150,10 @@ package body Exp_Dist is -- corresponding record type. RACW_Type : constant Entity_Id := - Underlying_RACW_Type (Ras_Type); - Desig : constant Entity_Id := - Etype (Designated_Type (RACW_Type)); + Underlying_RACW_Type (Ras_Type); Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Get_Stub_Elements (RACW_Type); Proc : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -6506,8 +6265,7 @@ package body Exp_Dist is New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), Make_Object_Declaration (Loc, - Defining_Identifier => - Stub_Ptr, + Defining_Identifier => Stub_Ptr, Object_Definition => New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), Expression => @@ -6523,8 +6281,7 @@ package body Exp_Dist is Proc_Statements := New_List ( Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), @@ -6535,8 +6292,7 @@ package body Exp_Dist is -- obtain the local address of its proxy (A). Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc), New_Occurrence_Of (Is_Local, Loc), @@ -6550,8 +6306,7 @@ package body Exp_Dist is -- if L then Make_Implicit_If_Statement (N, - Condition => - New_Occurrence_Of (Is_Local, Loc), + Condition => New_Occurrence_Of (Is_Local, Loc), Then_Statements => New_List ( @@ -6561,12 +6316,11 @@ package body Exp_Dist is Condition => Make_Op_Eq (Loc, Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Local_Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, Name_Target)), + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), Make_Null (Loc)), Then_Statements => New_List ( @@ -6576,32 +6330,29 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Local_Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, Name_Target)), + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (A.Target); Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Local_Addr, Loc)), - Selector_Name => Make_Identifier (Loc, - Name_Target)))))), + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target)))))), -- end if; -- if not All_Calls_Remote then @@ -6611,12 +6362,14 @@ package body Exp_Dist is Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, - New_Occurrence_Of (All_Calls_Remote, Loc)), + Right_Opnd => + New_Occurrence_Of (All_Calls_Remote, Loc)), Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, - Unchecked_Convert_To (Fat_Type, - New_Occurrence_Of (Local_Addr, Loc)))))))); + Expression => + Unchecked_Convert_To + (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); Append_List_To (Proc_Statements, New_List ( @@ -6624,16 +6377,14 @@ package body Exp_Dist is Set_Field (Name_Target, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (Stub.Target); Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Stub_Ptr, @@ -6648,13 +6399,13 @@ package body Exp_Dist is Set_Field (Name_Asynchronous, Make_Or_Else (Loc, - New_Occurrence_Of (Asynch_P, Loc), - New_Occurrence_Of (Boolean_Literals ( - Is_Asynchronous (Ras_Type)), Loc))))); + Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), + Right_Opnd => + New_Occurrence_Of + (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); Append_List_To (Proc_Statements, - Build_Get_Unique_RP_Call (Loc, - Stub_Ptr, Stub_Elements.Stub_Type)); + Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); Append_To (Proc_Statements, Make_Simple_Return_Statement (Loc, @@ -6740,14 +6491,11 @@ package body Exp_Dist is Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, + Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Any_Parameter, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Any), Loc))), + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); Discard_Node ( @@ -6792,36 +6540,30 @@ package body Exp_Dist is Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); Decls := New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => - Any, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any), Loc), - Expression => + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => PolyORB_Support.Helpers.Build_To_Any_Call (RACW_Parameter, No_List))); Statements := New_List ( Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, RAS_Type, Decls))), + Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (Any, Loc))); + Expression => New_Occurrence_Of (Any, Loc))); Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, + Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - RAS_Parameter, - Parameter_Type => - New_Occurrence_Of (RAS_Type, Loc))), + Defining_Identifier => RAS_Parameter, + Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Discard_Node ( @@ -6844,17 +6586,16 @@ package body Exp_Dist is Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Make_TSS_Name (RAS_Type, TSS_TypeCode)); - Func_Spec : Node_Id; - - Decls : constant List_Id := New_List; - Name_String, Repo_Id_String : String_Id; + Func_Spec : Node_Id; + Decls : constant List_Id := New_List; + Name_String : String_Id; + Repo_Id_String : String_Id; begin Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, - Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); PolyORB_Support.Helpers.Build_Name_And_Repository_Id (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); @@ -6869,24 +6610,25 @@ package body Exp_Dist is Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (RTE (RE_TC_Object), Loc), Make_Aggregate (Loc, Expressions => New_List ( Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_TA_String), Loc), + Name => + New_Occurrence_Of + (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Name_String))), Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_TA_String), Loc), + Name => + New_Occurrence_Of + (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, - Repo_Id_String)))))))))))); + Strval => Repo_Id_String)))))))))))); Set_TSS (RAS_Type, Fnam); end Add_RAS_TypeCode; @@ -6905,14 +6647,14 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, New_Internal_Name ('H')); Pkg_RPC_Receiver_Object : Node_Id; - Pkg_RPC_Receiver_Body : Node_Id; Pkg_RPC_Receiver_Decls : List_Id; Pkg_RPC_Receiver_Statements : List_Id; - Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; -- A Pkg_RPC_Receiver is built to decode the request - Request : Node_Id; + Request : Node_Id; -- Request object received from neutral layer Subp_Id : Entity_Id; @@ -6920,16 +6662,19 @@ package body Exp_Dist is -- distribution core. Subp_Index : Entity_Id; - -- Internal index as determined by matching either the - -- method name from the request structure, or the local - -- subprogram address (in case of a RAS). + -- Internal index as determined by matching either the method name + -- from the request structure, or the local subprogram address (in + -- case of a RAS). Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + Local_Address : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - -- Address of a local subprogram designated by a - -- reference corresponding to a RAS. + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + -- Address of a local subprogram designated by a reference + -- corresponding to a RAS. Dispatch_On_Address : constant List_Id := New_List; Dispatch_On_Name : constant List_Id := New_List; @@ -6984,8 +6729,8 @@ package body Exp_Dist is Defining_Entity (Stubs), Loc), Parameter_Associations => New_List (New_Occurrence_Of (Request, Loc)))); - if Nkind (Specification (Declaration)) - = N_Function_Specification + + if Nkind (Specification (Declaration)) = N_Function_Specification or else not Is_Asynchronous (Defining_Entity (Specification (Declaration))) then @@ -6996,8 +6741,7 @@ package body Exp_Dist is Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Integer_Literal (Loc, Subp_Number)), - Statements => - Case_Stmts)); + Statements => Case_Stmts)); Append_To (Dispatch_On_Name, Make_Elsif_Part (Loc, @@ -7008,25 +6752,23 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Id, Loc), New_Occurrence_Of (Subp_Dist_Name, Loc))), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), - Make_Integer_Literal (Loc, - Subp_Number))))); + Make_Integer_Literal (Loc, Subp_Number))))); Append_To (Dispatch_On_Address, Make_Elsif_Part (Loc, Condition => Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Local_Address, Loc), - Right_Opnd => - New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), - Make_Integer_Literal (Loc, - Subp_Number))))); + Make_Integer_Literal (Loc, Subp_Number))))); end Append_Stubs_To; -- Start of processing for Add_Receiving_Stubs_To_Declarations @@ -7064,20 +6806,19 @@ package body Exp_Dist is Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Is_Local, + Defining_Identifier => Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Local_Address, + Defining_Identifier => Local_Address, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Pkg_RPC_Receiver_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Request, @@ -7112,11 +6853,12 @@ package body Exp_Dist is Subp_Val : String_Id; Subp_Dist_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name ( - Related_Id => Chars (Subp_Def), - Suffix => 'D', - Suffix_Index => -1)); + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); Proxy_Object_Addr : Entity_Id; @@ -7137,29 +6879,26 @@ package body Exp_Dist is -- Build RAS proxy Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => - Current_Declaration, - All_Calls_Remote_E => - All_Calls_Remote_E, - Proxy_Object_Addr => - Proxy_Object_Addr); + Vis_Decl => Current_Declaration, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Object_Addr); -- Compute distribution identifier - Assign_Subprogram_Identifier ( - Subp_Def, - Current_Subprogram_Number, - Subp_Val); + Assign_Subprogram_Identifier + (Subp_Def, + Current_Subprogram_Number, + Subp_Val); - pragma Assert (Current_Subprogram_Number = - Get_Subprogram_Id (Subp_Def)); + pragma Assert + (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Subp_Dist_Name, Constant_Present => True, - Object_Definition => New_Occurrence_Of ( - Standard_String, Loc), + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, Subp_Val))); Analyze (Last (Decls)); @@ -7172,21 +6911,21 @@ package body Exp_Dist is Append_To (Subp_Info_List, Make_Component_Association (Loc, Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), + Make_Integer_Literal (Loc, Current_Subprogram_Number)), + Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of ( - Subp_Dist_Name, Loc), + New_Occurrence_Of (Subp_Dist_Name, Loc), Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Subp_Dist_Name, Loc), + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), Attribute_Name => Name_Length), + New_Occurrence_Of (Proxy_Object_Addr, Loc))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, @@ -7216,12 +6955,14 @@ package body Exp_Dist is Make_Index_Or_Discriminant_Constraint (Loc, New_List ( Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id), + Low_Bound => + Make_Integer_Literal (Loc, + Intval => First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))))); + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); if Present (First (Subp_Info_List)) then Set_Expression (Last (Decls), @@ -7247,27 +6988,22 @@ package body Exp_Dist is Make_Implicit_If_Statement (Pkg_Spec, Condition => Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of - (Local_Address, Loc), + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + Then_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, - Condition => - New_Occurrence_Of (Standard_False, Loc), + Condition => New_Occurrence_Of (Standard_False, Loc), Then_Statements => New_List ( Make_Null_Statement (Loc)), - Elsif_Parts => - Dispatch_On_Address)), + Elsif_Parts => Dispatch_On_Address)), Else_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, - Condition => - New_Occurrence_Of (Standard_False, Loc), - Then_Statements => New_List ( - Make_Null_Statement (Loc)), - Elsif_Parts => - Dispatch_On_Name)))); + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List (Make_Null_Statement (Loc)), + Elsif_Parts => Dispatch_On_Name)))); else -- For a degenerate RCI with no visible subprograms, @@ -7295,15 +7031,12 @@ package body Exp_Dist is Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => - New_List (Make_Null_Statement (Loc)))); + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (Subp_Index, Loc), + Expression => New_Occurrence_Of (Subp_Index, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); -- Pkg_RPC_Receiver body is now complete: insert it into the tree and @@ -7317,70 +7050,71 @@ package body Exp_Dist is Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('R')), Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Servant), Loc)); + Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); Append_To (Decls, Pkg_RPC_Receiver_Object); Analyze (Last (Decls)); Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + Append_To (Register_Pkg_Actuals, - -- Name Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + -- Version + Append_To (Register_Pkg_Actuals, - -- Version Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version)); + Attribute_Name => Name_Version)); + + -- Handler Append_To (Register_Pkg_Actuals, - -- Handler Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), Attribute_Name => Name_Access)); + -- Receiver + Append_To (Register_Pkg_Actuals, - -- Receiver Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( - Defining_Identifier ( - Pkg_RPC_Receiver_Object), Loc), - Attribute_Name => - Name_Access)); + Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), + Attribute_Name => Name_Access)); + + -- Subp_Info Append_To (Register_Pkg_Actuals, - -- Subp_Info Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Address)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); + + -- Subp_Info_Len Append_To (Register_Pkg_Actuals, - -- Subp_Info_Len Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Length)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); + + -- Is_All_Calls_Remote Append_To (Register_Pkg_Actuals, - -- Is_All_Calls_Remote New_Occurrence_Of (All_Calls_Remote_E, Loc)); + -- ??? + Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), Parameter_Associations => Register_Pkg_Actuals)); Analyze (Last (Stmts)); - end Add_Receiving_Stubs_To_Declarations; --------------------------------- @@ -7455,8 +7189,7 @@ package body Exp_Dist is begin -- ??? document general form of stub subprograms for the PolyORB case - Request := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Append_To (Decls, Make_Object_Declaration (Loc, @@ -7466,11 +7199,13 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Request_Access), Loc))); Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); if Is_Function then - Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, - Etype (Result_Definition (Spec)), Decls); + Result_TC := + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etype (Result_Definition (Spec)), Decls); else Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); end if; @@ -7485,8 +7220,7 @@ package body Exp_Dist is Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Name)), + Choices => New_List (Make_Identifier (Loc, Name_Name)), Expression => New_Occurrence_Of (RTE (RE_Result_Name), Loc)), Make_Component_Association (Loc, @@ -7494,15 +7228,12 @@ package body Exp_Dist is Make_Identifier (Loc, Name_Argument)), Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Create_Any), Loc), - Parameter_Associations => New_List ( - Result_TC))), + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))), Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( Make_Identifier (Loc, Name_Arg_Modes)), - Expression => - Make_Integer_Literal (Loc, 0)))))); + Expression => Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then Exception_Return_Parameter := @@ -7531,6 +7262,7 @@ package body Exp_Dist is Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; + else Is_Controlling_Formal := False; Is_First_Controlling_Formal := False; @@ -7538,8 +7270,7 @@ package body Exp_Dist is if Is_Controlling_Formal then - -- In the case of a controlling formal argument, we send its - -- reference. + -- For a controlling formal argument, we send its reference Etyp := RACW_Type; @@ -7547,11 +7278,10 @@ package body Exp_Dist is Etyp := Etype (Parameter_Type (Current_Parameter)); end if; - -- The first controlling formal parameter is treated specially: it - -- is used to set the target object of the call. + -- The first controlling formal parameter is treated specially: + -- it is used to set the target object of the call. if not Is_First_Controlling_Formal then - declare Constrained : constant Boolean := Is_Constrained (Etyp) @@ -7584,10 +7314,8 @@ package body Exp_Dist is else Actual_Parameter := OK_Convert_To (Etyp, Make_Attribute_Reference (Loc, - Prefix => - Actual_Parameter, - Attribute_Name => - Name_Unrestricted_Access)); + Prefix => Actual_Parameter, + Attribute_Name => Name_Unrestricted_Access)); end if; end if; @@ -7602,26 +7330,24 @@ package body Exp_Dist is -- parameter (always passed as a reference) other than -- the first one. - Expr := PolyORB_Support.Helpers.Build_To_Any_Call ( - Actual_Parameter, Decls); + Expr := PolyORB_Support.Helpers.Build_To_Any_Call + (Actual_Parameter, Decls); + else Expr := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, - Etyp, Decls))); + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Decls))); end if; Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Any, + Defining_Identifier => Any, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), - Expression => - Expr)); + Expression => Expr)); Append_To (Statements, Add_Parameter_To_NVList (Loc, @@ -7639,10 +7365,10 @@ package body Exp_Dist is New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Expression => - PolyORB_Support.Helpers.Build_From_Any_Call ( - Etype (Parameter_Type (Current_Parameter)), - New_Occurrence_Of (Any, Loc), - Decls))); + PolyORB_Support.Helpers.Build_From_Any_Call + (Etype (Parameter_Type (Current_Parameter)), + New_Occurrence_Of (Any, Loc), + Decls))); end if; end; @@ -7652,8 +7378,8 @@ package body Exp_Dist is -- this status is transmitted as well. -- This should be done for accessibility as well ??? - if Nkind (Parameter_Type (Current_Parameter)) - /= N_Access_Definition + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition and then Need_Extra_Constrained (Current_Parameter) then -- In this block, we do not use the extra formal that has been @@ -7664,28 +7390,27 @@ package body Exp_Dist is declare Extra_Any_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); Parameter_Exp : constant Node_Id := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Attribute_Name => Name_Constrained); + begin Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Extra_Any_Parameter, + Defining_Identifier => Extra_Any_Parameter, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => - PolyORB_Support.Helpers.Build_To_Any_Call ( - Parameter_Exp, - Decls))); + PolyORB_Support.Helpers.Build_To_Any_Call + (Parameter_Exp, Decls))); Append_To (Extra_Formal_Statements, Add_Parameter_To_NVList (Loc, @@ -7707,6 +7432,7 @@ package body Exp_Dist is Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Request_Create), Loc), + Parameter_Associations => New_List ( Target_Object, Subprogram_Id, @@ -7717,14 +7443,18 @@ package body Exp_Dist is Append_To (Parameter_Associations (Last (Statements)), New_Occurrence_Of (Request, Loc)); - pragma Assert ( - not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + pragma Assert + (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then - Asynchronous_P := New_Occurrence_Of ( - Boolean_Literals (Is_Known_Asynchronous), Loc); + Asynchronous_P := + New_Occurrence_Of + (Boolean_Literals (Is_Known_Asynchronous), Loc); + else pragma Assert (Present (Asynchronous)); Asynchronous_P := New_Copy_Tree (Asynchronous); + -- The expression node Asynchronous will be used to build an 'if' -- statement at the end of Build_General_Calling_Stubs: we need to -- make a copy here. @@ -7766,17 +7496,16 @@ package body Exp_Dist is Append_To (Non_Asynchronous_Statements, Make_Tag_Check (Loc, Make_Simple_Return_Statement (Loc, - PolyORB_Support.Helpers.Build_From_Any_Call ( - Etype (Result_Definition (Spec)), - Make_Selected_Component (Loc, - Prefix => Result, - Selector_Name => Name_Argument), - Decls)))); + PolyORB_Support.Helpers.Build_From_Any_Call + (Etype (Result_Definition (Spec)), + Make_Selected_Component (Loc, + Prefix => Result, + Selector_Name => Name_Argument), + Decls)))); end if; end if; - Append_List_To (Non_Asynchronous_Statements, - After_Statements); + Append_List_To (Non_Asynchronous_Statements, After_Statements); if Is_Known_Asynchronous then Append_List_To (Statements, Asynchronous_Statements); @@ -7813,8 +7542,10 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Target_Reference, + Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => Make_Function_Call (Loc, Name => @@ -7823,7 +7554,8 @@ package body Exp_Dist is Make_Selected_Component (Loc, Prefix => Controlling_Parameter, Selector_Name => Name_Target))))); - -- Controlling_Parameter has the same components as + + -- Note: Controlling_Parameter has the same components as -- System.Partition_Interface.RACW_Stub_Type. Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); @@ -7831,11 +7563,11 @@ package body Exp_Dist is else Target_Info.Object := Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Chars (RCI_Locator)), + Prefix => Make_Identifier (Loc, Chars (RCI_Locator)), Selector_Name => Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); end if; + return Target_Info; end Build_Stub_Target; @@ -7871,20 +7603,19 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, Name_Target), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => - False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, Subtype_Indication => - New_Occurrence_Of ( - Standard_Boolean, Loc))))))); + New_Occurrence_Of (Standard_Boolean, Loc))))))); RPC_Receiver_Decl := Make_Object_Declaration (Loc, @@ -8032,8 +7763,8 @@ package body Exp_Dist is New_Occurrence_Of (Parent_Primitive, Loc); else Called_Subprogram := - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Vis_Decl)), Loc); + New_Occurrence_Of + (Defining_Unit_Name (Specification (Vis_Decl)), Loc); end if; Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); @@ -8050,11 +7781,12 @@ package body Exp_Dist is Any : Entity_Id := Empty; Object : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('P')); + Chars => New_Internal_Name ('P')); Expr : Node_Id := Empty; - Is_Controlling_Formal : constant Boolean - := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); Is_First_Controlling_Formal : Boolean := False; @@ -8075,30 +7807,30 @@ package body Exp_Dist is Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; + else Etyp := Etype (Parameter_Type (Current_Parameter)); end if; Constrained := - Is_Constrained (Etyp) - or else Is_Elementary_Type (Etyp); + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if not Is_First_Controlling_Formal then - Any := Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Any := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Any, + Defining_Identifier => Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, - Etyp, Outer_Decls))))); + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Outer_Decls))))); Append_To (Outer_Statements, Add_Parameter_To_NVList (Loc, @@ -8111,34 +7843,34 @@ package body Exp_Dist is if Is_First_Controlling_Formal then declare Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('L')); - begin + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + begin -- Special case: obtain the first controlling formal -- from the target of the remote call, instead of the -- argument list. Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Addr, + Defining_Identifier => Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Is_Local, + Defining_Identifier => Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Get_Local_Address), Loc), + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => @@ -8169,13 +7901,12 @@ package body Exp_Dist is if Constrained then Append_To (Statements, Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Object, Loc), - Expression => - Expr)); + Name => New_Occurrence_Of (Object, Loc), + Expression => Expr)); Expr := Empty; else null; + -- Expr will be used to initialize (and constrain) the -- parameter when it is declared. end if; @@ -8216,13 +7947,11 @@ package body Exp_Dist is then Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), + Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), - PolyORB_Support.Helpers.Build_To_Any_Call ( - New_Occurrence_Of (Object, Loc), - Decls)))); + PolyORB_Support.Helpers.Build_To_Any_Call + (New_Occurrence_Of (Object, Loc), Decls)))); end if; -- For RACW controlling formals, the Etyp of Object is always @@ -8231,25 +7960,27 @@ package body Exp_Dist is if Is_Controlling_Formal then if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition + N_Access_Definition then Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc)))))); + Prefix => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); else Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => Unchecked_Convert_To (RACW_Type, OK_Convert_To (RTE (RE_Address), @@ -8280,21 +8011,22 @@ package body Exp_Dist is Extra_Constrained (Defining_Identifier (Current_Parameter)); + Extra_Any : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('A')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); Formal_Entity : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (Extra_Parameter)); + Make_Defining_Identifier (Loc, + Chars => Chars (Extra_Parameter)); Formal_Type : constant Entity_Id := Etype (Extra_Parameter); + begin Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Extra_Any, + Defining_Identifier => Extra_Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => @@ -8320,13 +8052,12 @@ package body Exp_Dist is Append_To (Statements, Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Formal_Entity, Loc), + Name => New_Occurrence_Of (Formal_Entity, Loc), Expression => - PolyORB_Support.Helpers.Build_From_Any_Call ( - Formal_Type, - New_Occurrence_Of (Extra_Any, Loc), - Decls))); + PolyORB_Support.Helpers.Build_From_Any_Call + (Formal_Type, + New_Occurrence_Of (Extra_Any, Loc), + Decls))); Set_Extra_Constrained (Object, Formal_Entity); end; end if; @@ -8341,24 +8072,23 @@ package body Exp_Dist is Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), + Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), New_Occurrence_Of (Arguments, Loc)))); if Nkind (Specification (Vis_Decl)) = N_Function_Specification then - -- The remote subprogram is a function. We build an inner block to - -- be able to hold a potentially unconstrained result in a - -- variable. + -- The remote subprogram is a function: Build an inner block to be + -- able to hold a potentially unconstrained result in a variable. declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); Result : constant Node_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Chars => New_Internal_Name ('R')); + begin Inner_Decls := New_List ( Make_Object_Declaration (Loc, @@ -8374,7 +8104,7 @@ package body Exp_Dist is -- For a remote call to a function with a class-wide type, -- check that the returned value satisfies the requirements - -- of E.4(18). + -- of (RM E.4(18)). Append_To (Inner_Decls, Make_Transportable_Check (Loc, @@ -8385,13 +8115,12 @@ package body Exp_Dist is Set_Etype (Result, Etyp); Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Result), Loc), + Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), - PolyORB_Support.Helpers.Build_To_Any_Call ( - New_Occurrence_Of (Result, Loc), - Decls)))); + PolyORB_Support.Helpers.Build_To_Any_Call + (New_Occurrence_Of (Result, Loc), Decls)))); + -- A DSA function does not have out or inout arguments end; @@ -8412,8 +8141,7 @@ package body Exp_Dist is Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), + Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))); @@ -8451,7 +8179,6 @@ package body Exp_Dist is Statements => New_List (Make_Null_Statement (Loc)))); else - -- In the other cases, if an exception is raised, then the -- exception occurrence is propagated. @@ -8460,8 +8187,7 @@ package body Exp_Dist is Append_To (Outer_Statements, Make_Block_Statement (Loc, - Declarations => - Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements))); @@ -8622,8 +8348,8 @@ package body Exp_Dist is Fnam : Entity_Id := Empty; Lib_RE : RE_Id := RE_Null; Result : Node_Id; - begin + begin -- First simple case where the From_Any function is present -- in the type's TSS. @@ -8761,24 +8487,22 @@ package body Exp_Dist is if Is_Itype (Typ) then Build_From_Any_Function (Loc => Loc, - Typ => Etype (Typ), - Decl => Decl, - Fnam => Fnam); + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); return; end if; - Fnam := Make_Stream_Procedure_Function_Name (Loc, - Typ, Name_uFrom_Any); + Fnam := + Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uFrom_Any); Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Any_Parameter, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Any), Loc))), + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (Typ, Loc)); -- The following is taken care of by Exp_Dist.Add_RACW_From_Any @@ -8790,7 +8514,7 @@ package body Exp_Dist is if Has_Stream_Attribute_Definition (Typ, TSS_Stream_Output, At_Any_Place => True) - or else + or else Has_Stream_Attribute_Definition (Typ, TSS_Stream_Write, At_Any_Place => True) then @@ -8804,12 +8528,11 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - OK_Convert_To ( - Typ, - Build_From_Any_Call ( - Root_Type (Typ), - New_Occurrence_Of (Any_Parameter, Loc), - Decls)))); + OK_Convert_To (Typ, + Build_From_Any_Call + (Root_Type (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); elsif Is_Record_Type (Typ) and then not Is_Derived_Type (Typ) @@ -8819,19 +8542,20 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - OK_Convert_To ( - Typ, - Build_From_Any_Call ( - Etype (Typ), - New_Occurrence_Of (Any_Parameter, Loc), - Decls)))); + OK_Convert_To (Typ, + Build_From_Any_Call + (Etype (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + else declare - Disc : Entity_Id := Empty; + Disc : Entity_Id := Empty; Discriminant_Associations : List_Id; - Rdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); - Component_Counter : Int := 0; + Rdef : constant Node_Id := + Type_Definition + (Declaration_Node (Typ)); + Component_Counter : Int := 0; -- The returned object @@ -8850,8 +8574,8 @@ package body Exp_Dist is procedure FA_Append_Record_Traversal is new Append_Record_Traversal - (Rec => Res, - Add_Process_Element => FA_Rec_Add_Process_Element); + (Rec => Res, + Add_Process_Element => FA_Rec_Add_Process_Element); -------------------------------- -- FA_Rec_Add_Process_Element -- @@ -8890,7 +8614,7 @@ package body Exp_Dist is -- A variant part declare - Variant : Node_Id; + Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; @@ -8907,16 +8631,16 @@ package body Exp_Dist is begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Struct_Any, - Constant_Present => - True, - Object_Definition => + Defining_Identifier => Struct_Any, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), - Expression => + Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_Extract_Union_Value), Loc), + Name => + New_Occurrence_Of + (RTE (RE_Extract_Union_Value), Loc), + Parameter_Associations => New_List ( Build_Get_Aggregate_Element (Loc, Any => Any, @@ -8935,8 +8659,7 @@ package body Exp_Dist is Append_To (Stmts, Make_Block_Statement (Loc, - Declarations => - Block_Decls, + Declarations => Block_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); @@ -8946,15 +8669,14 @@ package body Exp_Dist is Expression => Make_Selected_Component (Loc, Prefix => Rec, - Selector_Name => - Chars (Name (Field))), - Alternatives => - Alt_List)); + Selector_Name => Chars (Name (Field))), + Alternatives => Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop - Choice_List := New_Copy_List_Tree - (Discrete_Choices (Variant)); + Choice_List := + New_Copy_List_Tree + (Discrete_Choices (Variant)); VP_Stmts := New_List; @@ -8975,12 +8697,12 @@ package body Exp_Dist is Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, - Statements => - VP_Stmts)); + Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; end; end if; + Counter := Counter + 1; end FA_Rec_Add_Process_Element; @@ -9002,11 +8724,11 @@ package body Exp_Dist is begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Disc_Var_Name, - Constant_Present => True, - Object_Definition => + Defining_Identifier => Disc_Var_Name, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Disc_Type, Loc), + Expression => Build_From_Any_Call (Disc_Type, Build_Get_Aggregate_Element (Loc, @@ -9016,6 +8738,7 @@ package body Exp_Dist is Idx => Make_Integer_Literal (Loc, Intval => Component_Counter)), Decls))); + Component_Counter := Component_Counter + 1; Append_To (Discriminant_Associations, @@ -9045,10 +8768,8 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Res, - Object_Definition => - Res_Definition)); + Defining_Identifier => Res, + Object_Definition => Res_Definition)); -- ... then all components @@ -9105,6 +8826,7 @@ package body Exp_Dist is -- sufficient to determine the typecode of Datum -- (which can be a TC_SEQUENCE or TC_ARRAY -- depending on the value of Constrained). + -- Therefore we retrieve the typecode which has -- been constructed in Append_Array_Traversal with -- a call to Get_Any_Type. @@ -9139,10 +8861,8 @@ package body Exp_Dist is New_Occurrence_Of (Counter, Loc), Expression => Make_Op_Add (Loc, - Left_Opnd => - New_Occurrence_Of (Counter, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, 1)))); + Left_Opnd => New_Occurrence_Of (Counter, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); if Nkind (Datum) /= N_Attribute_Reference then @@ -9152,10 +8872,8 @@ package body Exp_Dist is if Etype (Datum) /= RTE (RE_Any) then Set_Expression (Assignment, - Build_From_Any_Call ( - Component_Type (Typ), - Element_Any, - Decls)); + Build_From_Any_Call + (Component_Type (Typ), Element_Any, Decls)); else Set_Expression (Assignment, Element_Any); end if; @@ -9210,32 +8928,36 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), - Constant_Present => - True, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Indt, Loc), Expression => - Build_From_Any_Call ( - Indt, - Build_Get_Aggregate_Element (Loc, - Any => Any_Parameter, - TC => Build_TypeCode_Call (Loc, - Indt, Decls), - Idx => Make_Integer_Literal (Loc, J - 1)), + Build_From_Any_Call + (Indt, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + TC => Build_TypeCode_Call + (Loc, Indt, Decls), + Idx => + Make_Integer_Literal (Loc, J - 1)), Decls))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), - Constant_Present => - True, + + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Indt, Loc), + Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Indt, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => @@ -9244,6 +8966,7 @@ package body Exp_Dist is OK_Convert_To ( Standard_Long_Integer, Make_Identifier (Loc, Lnam)), + Right_Opnd => OK_Convert_To ( Standard_Long_Integer, @@ -9257,7 +8980,8 @@ package body Exp_Dist is New_Occurrence_Of ( Any_Parameter, Loc), Make_Integer_Literal (Loc, - J))))), + Intval => J))))), + Right_Opnd => Make_Integer_Literal (Loc, 1)))))); @@ -9275,8 +8999,7 @@ package body Exp_Dist is Initial_Counter_Value := Ndim; Res_Subtype_Indication := Make_Subtype_Indication (Loc, - Subtype_Mark => - Res_Subtype_Indication, + Subtype_Mark => Res_Subtype_Indication, Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Ranges)); @@ -9300,15 +9023,15 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Component_TC, - Constant_Present => True, - Object_Definition => + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc), - Expression => + Expression => Build_TypeCode_Call (Loc, Component_Type (Typ), Decls))); - Append_From_Any_Array_Iterator (Stms, - Any_Parameter, Counter); + Append_From_Any_Array_Iterator + (Stms, Any_Parameter, Counter); Append_To (Stms, Make_Simple_Return_Statement (Loc, @@ -9319,12 +9042,11 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - Unchecked_Convert_To ( - Typ, - Build_From_Any_Call ( - Find_Numeric_Representation (Typ), - New_Occurrence_Of (Any_Parameter, Loc), - Decls)))); + Unchecked_Convert_To (Typ, + Build_From_Any_Call + (Find_Numeric_Representation (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); else Use_Opaque_Representation := True; @@ -9347,10 +9069,8 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Strm, - Aliased_Present => - True, + Defining_Identifier => Strm, + Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); @@ -9367,8 +9087,7 @@ package body Exp_Dist is Append_To (Stms, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), + Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any_Parameter, Loc), New_Occurrence_Of (Strm, Loc)))); @@ -9385,8 +9104,7 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Res, Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Typ, Loc), + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), @@ -9403,8 +9121,7 @@ package body Exp_Dist is Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => - New_List ( - New_Occurrence_Of (Strm, Loc))), + New_List (New_Occurrence_Of (Strm, Loc))), Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Res, Loc)))))); @@ -9433,8 +9150,7 @@ package body Exp_Dist is begin return Make_Function_Call (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Get_Aggregate_Element), Loc), + New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), TC, @@ -9650,19 +9366,15 @@ package body Exp_Dist is Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Expr_Parameter, - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + Defining_Identifier => Expr_Parameter, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Set_Etype (Expr_Parameter, Typ); Any_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => - Any, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any), Loc)); + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Use_Opaque_Representation := False; @@ -9704,8 +9416,8 @@ package body Exp_Dist is New_Occurrence_Of (Expr_Parameter, Loc)); begin - Set_Expression (Any_Decl, - Build_To_Any_Call (Expr, Decls)); + Set_Expression + (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; -- Comment needed here (and label on declare block ???) @@ -9868,10 +9580,8 @@ package body Exp_Dist is Append_To (Block_Stmts, Make_Case_Statement (Loc, - Expression => - Make_Discriminant_Reference, - Alternatives => - Alt_List)); + Expression => Make_Discriminant_Reference, + Alternatives => Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop @@ -9889,9 +9599,9 @@ package body Exp_Dist is RTE (RE_Add_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Union_Any, Loc), - Build_To_Any_Call ( - Make_Discriminant_Reference, - Block_Decls)))); + Build_To_Any_Call + (Make_Discriminant_Reference, + Block_Decls)))); -- Populate inner struct aggregate @@ -9935,7 +9645,7 @@ package body Exp_Dist is Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, - Statements => VP_Stmts)); + Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; @@ -10204,8 +9914,7 @@ package body Exp_Dist is Append_To (Stms, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), + Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Any, Loc)))); @@ -10215,8 +9924,7 @@ package body Exp_Dist is Append_To (Stms, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), + Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); end; @@ -10239,8 +9947,8 @@ package body Exp_Dist is Decl := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); @@ -10442,8 +10150,7 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_String), Loc), + Name => New_Occurrence_Of (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, S)))); end Add_String_Parameter; @@ -10459,10 +10166,8 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_TC), Loc), - Parameter_Associations => New_List ( - TC_Node))); + Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), + Parameter_Associations => New_List (TC_Node))); end Add_TypeCode_Parameter; ------------------------ @@ -10476,8 +10181,7 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_LI), Loc), + Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc), Parameter_Associations => New_List (Expr_Node))); end Add_Long_Parameter; @@ -10538,7 +10242,7 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - Make_Constructed_TypeCode (Kind, Parameters))); + Make_Constructed_TypeCode (Kind, Parameters))); end Return_Constructed_TypeCode; ------------------ @@ -10577,8 +10281,8 @@ package body Exp_Dist is -- A regular component - Add_TypeCode_Parameter ( - Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); Get_Name_String (Chars (Field)); Add_String_Parameter (String_From_Name_Buffer, Params); @@ -10718,7 +10422,7 @@ package body Exp_Dist is declare Default_Node : constant Node_Id := - Pick (Union_TC_Params, 4); + Pick (Union_TC_Params, 4); New_Default_Node : constant Node_Id := Make_Function_Call (Loc, @@ -10761,7 +10465,7 @@ package body Exp_Dist is declare Exp : constant Node_Id := - New_Copy_Tree (Choice); + New_Copy_Tree (Choice); begin Append_To (Union_TC_Params, Build_To_Any_Call (Exp, Decls)); @@ -10769,14 +10473,13 @@ package body Exp_Dist is Add_Params_For_Variant_Components; end case; + Next (Choice); Choice_Index := Choice_Index + 1; - end loop; Next_Non_Pragma (Variant); end loop; - end; end if; end TC_Rec_Add_Process_Element; @@ -10798,19 +10501,20 @@ package body Exp_Dist is Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => Fnam, + Defining_Unit_Name => Fnam, Parameter_Specifications => Empty_List, - Result_Definition => + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); Build_Name_And_Repository_Id (Typ, Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); + Initialize_Parameter_List (Type_Name_Str, Type_Repo_Id_Str, Parameters); if Has_Stream_Attribute_Definition (Typ, TSS_Stream_Output, At_Any_Place => True) - or else + or else Has_Stream_Attribute_Definition (Typ, TSS_Stream_Write, At_Any_Place => True) then @@ -10875,20 +10579,23 @@ package body Exp_Dist is -- | [VP Name] if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then - Return_Alias_TypeCode ( - Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + Return_Alias_TypeCode + (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + else declare Disc : Entity_Id := Empty; Rdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); + Type_Definition (Declaration_Node (Typ)); Dummy_Counter : Int := 0; + begin -- Construct the discriminants typecodes if Has_Discriminants (Typ) then Disc := First_Discriminant (Typ); end if; + while Present (Disc) loop Add_TypeCode_Parameter ( Build_TypeCode_Call (Loc, Etype (Disc), Decls), @@ -10917,9 +10624,8 @@ package body Exp_Dist is Indx : Node_Id := First_Index (Typ); begin - Inner_TypeCode := Build_TypeCode_Call (Loc, - Component_Type (Typ), - Decls); + Inner_TypeCode := + Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); for J in 1 .. Ndim loop if Constrained then @@ -10928,13 +10634,11 @@ package body Exp_Dist is Build_To_Any_Call ( OK_Convert_To (RTE (RE_Long_Unsigned), Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Typ, Loc), - Attribute_Name => - Name_Length, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Length, Expressions => New_List ( Make_Integer_Literal (Loc, - Ndim - J + 1)))), + Intval => Ndim - J + 1)))), Decls), Build_To_Any_Call (Inner_TypeCode, Decls))); @@ -10981,8 +10685,8 @@ package body Exp_Dist is Decl := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); @@ -11086,7 +10790,6 @@ package body Exp_Dist is Make_Indexed_Component (Loc, New_Occurrence_Of (Arry, Loc), Indices); - begin Set_Etype (Element_Expr, Component_Type (Typ)); Add_Process_Element (Stmts, @@ -11118,8 +10821,8 @@ package body Exp_Dist is declare Loop_Any : Node_Id := Inner_Any; - begin + begin -- For the first dimension of a constrained array, we add -- elements directly in the corresponding Any; there is no -- intervening inner Any. @@ -11169,8 +10872,7 @@ package body Exp_Dist is if Constrained then Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_TC), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc))); else @@ -11185,11 +10887,10 @@ package body Exp_Dist is else Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Content_Type), Loc), + Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, - New_External_Name ('T', Depth - 1)))); + Chars => New_External_Name ('T', Depth - 1)))); end if; Append_To (Decls, @@ -11281,7 +10982,8 @@ package body Exp_Dist is if Is_Tagged_Type (Typ) then return Make_Defining_Identifier (Loc, Nam); else - return Make_Defining_Identifier (Loc, + return + Make_Defining_Identifier (Loc, Chars => New_External_Name (Nam, ' ', Increment_Serial_Number)); end if; @@ -11457,7 +11159,8 @@ package body Exp_Dist is (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; - Stub_Elements : Stub_Structure) is + Stub_Elements : Stub_Structure) + is begin case Get_PCS_Name is when Name_PolyORB_DSA => @@ -11479,25 +11182,26 @@ package body Exp_Dist is Stub_Type : Entity_Id; Stub_Type_Access : Entity_Id; RPC_Receiver_Decl : Node_Id; - Body_Decls : List_Id) is + Body_Decls : List_Id) + is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Add_RACW_Features ( - RACW_Type, - Desig, - Stub_Type, - Stub_Type_Access, - RPC_Receiver_Decl, - Body_Decls); + PolyORB_Support.Add_RACW_Features + (RACW_Type, + Desig, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); when others => - GARLIC_Support.Add_RACW_Features ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - RPC_Receiver_Decl, - Body_Decls); + GARLIC_Support.Add_RACW_Features + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); end case; end Specific_Add_RACW_Features; @@ -11507,7 +11211,8 @@ package body Exp_Dist is procedure Specific_Add_RAST_Features (Vis_Decl : Node_Id; - RAS_Type : Entity_Id) is + RAS_Type : Entity_Id) + is begin case Get_PCS_Name is when Name_PolyORB_DSA => @@ -11529,11 +11234,11 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Add_Receiving_Stubs_To_Declarations ( - Pkg_Spec, Decls, Stmts); + PolyORB_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); when others => - GARLIC_Support.Add_Receiving_Stubs_To_Declarations ( - Pkg_Spec, Decls, Stmts); + GARLIC_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); end case; end Specific_Add_Receiving_Stubs_To_Declarations; @@ -11558,34 +11263,35 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Build_General_Calling_Stubs ( - Decls, - Statements, - Target.Object, - Subprogram_Id, - Asynchronous, - Is_Known_Asynchronous, - Is_Known_Non_Asynchronous, - Is_Function, - Spec, - Stub_Type, - RACW_Type, - Nod); + PolyORB_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Object, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + when others => - GARLIC_Support.Build_General_Calling_Stubs ( - Decls, - Statements, - Target.Partition, - Target.RPC_Receiver, - Subprogram_Id, - Asynchronous, - Is_Known_Asynchronous, - Is_Known_Non_Asynchronous, - Is_Function, - Spec, - Stub_Type, - RACW_Type, - Nod); + GARLIC_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Partition, + Target.RPC_Receiver, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); end case; end Specific_Build_General_Calling_Stubs; @@ -11611,6 +11317,7 @@ package body Exp_Dist is Subp_Index, Stmts, Decl); + when others => GARLIC_Support.Build_RPC_Receiver_Body (RPC_Receiver, @@ -11637,6 +11344,7 @@ package body Exp_Dist is when Name_PolyORB_DSA => return PolyORB_Support.Build_Stub_Target (Loc, Decls, RCI_Locator, Controlling_Parameter); + when others => return GARLIC_Support.Build_Stub_Target (Loc, Decls, RCI_Locator, Controlling_Parameter); @@ -11659,6 +11367,7 @@ package body Exp_Dist is PolyORB_Support.Build_Stub_Type ( RACW_Type, Stub_Type, Stub_Type_Decl, RPC_Receiver_Decl); + when others => GARLIC_Support.Build_Stub_Type ( RACW_Type, Stub_Type, @@ -11677,21 +11386,22 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - return PolyORB_Support.Build_Subprogram_Receiving_Stubs ( - Vis_Decl, - Asynchronous, - Dynamically_Asynchronous, - Stub_Type, - RACW_Type, - Parent_Primitive); + return PolyORB_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + when others => - return GARLIC_Support.Build_Subprogram_Receiving_Stubs ( - Vis_Decl, - Asynchronous, - Dynamically_Asynchronous, - Stub_Type, - RACW_Type, - Parent_Primitive); + return GARLIC_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); end case; end Specific_Build_Subprogram_Receiving_Stubs; @@ -11722,10 +11432,12 @@ package body Exp_Dist is end if; return - Etype (Subtype_Indication ( - Component_Definition ( - First (Component_Items (Component_List ( - Type_Definition (Declaration_Node (Record_Type)))))))); + Etype (Subtype_Indication + (Component_Definition + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (Record_Type)))))))); end Underlying_RACW_Type; end Exp_Dist; diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index cc2323f26c0..a1418d3f6bb 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -26,12 +26,16 @@ -- This package contains utility routines used for the generation of the -- stubs relevant to the distribution annex. -with Namet; use Namet; -with Types; use Types; +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; package Exp_Dist is - PCS_Version_Number : constant := 1; + PCS_Version_Number : constant array (PCS_Names) of Int := + (Name_No_DSA => 1, + Name_GARLIC_DSA => 1, + Name_PolyORB_DSA => 2); -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb index 0537cf089d0..9f172566cf5 100644 --- a/gcc/ada/exp_vfpt.adb +++ b/gcc/ada/exp_vfpt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -443,6 +443,41 @@ package body Exp_VFpt is Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); end Expand_Vax_Conversion; + ------------------------------- + -- Expand_Vax_Foreign_Return -- + ------------------------------- + + procedure Expand_Vax_Foreign_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Func : RE_Id; + Args : List_Id; + Atyp : Entity_Id; + Rtyp : constant Entity_Id := Etype (N); + + begin + if Digits_Value (Typ) = VAXFF_Digits then + Func := RE_Return_F; + Atyp := RTE (RE_F); + elsif Digits_Value (Typ) = VAXDF_Digits then + Func := RE_Return_D; + Atyp := RTE (RE_D); + else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); + Func := RE_Return_G; + Atyp := RTE (RE_G); + end if; + + Args := New_List (Convert_To (Atyp, N)); + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Vax_Foreign_Return; + ----------------------------- -- Expand_Vax_Real_Literal -- ----------------------------- diff --git a/gcc/ada/exp_vfpt.ads b/gcc/ada/exp_vfpt.ads index 1652ad84ab5..fdca701cfb1 100644 --- a/gcc/ada/exp_vfpt.ads +++ b/gcc/ada/exp_vfpt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,6 +45,12 @@ package Exp_VFpt is -- The node N is a type conversion node where either the source or the -- target type, or both, are Vax floating-point type. + procedure Expand_Vax_Foreign_Return (N : Node_Id); + -- The node N is a call to a foreign function that returns a Vax float + -- value in a floating point register. Wraps the call in an asm stub + -- that moves the return value to an integer location on Alpha/VMS, + -- noop everywhere else. + procedure Expand_Vax_Real_Literal (N : Node_Id); -- The node N is a real literal node where the type is a Vax floating-point -- type. This procedure rewrites the node to eliminate the occurrence of diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bf4f94677e8..31f93985c44 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -29,6 +29,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; @@ -2651,10 +2652,31 @@ package body Freeze is Validate_Object_Declaration (Declaration_Node (E)); - -- If there is an address clause, check it is valid + -- If there is an address clause, check that it is valid Check_Address_Clause (E); + -- If the object needs any kind of default initialization, an + -- error must be issued if No_Default_Initialization applies. + -- The check doesn't apply to imported objects, which are not + -- ever default initialized, and is why the check is deferred + -- until freezing, at which point we know if Import applies. + + if not Is_Imported (E) + and then not Has_Init_Expression (Declaration_Node (E)) + and then + ((Has_Non_Null_Base_Init_Proc (Etype (E)) + and then not No_Initialization (Declaration_Node (E)) + and then not Is_Value_Type (Etype (E)) + and then not Suppress_Init_Proc (Etype (E))) + or else + (Needs_Simple_Initialization (Etype (E)) + and then not Is_Internal (E))) + then + Check_Restriction + (No_Default_Initialization, Declaration_Node (E)); + end if; + -- For imported objects, set Is_Public unless there is also an -- address clause, which means that there is no external symbol -- needed for the Import (Is_Public may still be set for other diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c048581d662..0d2d0ff28b5 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -8370,6 +8370,7 @@ of composite objects and the Max/Min attributes. @item No_Implicit_Dynamic_Code @findex No_Implicit_Dynamic_Code +@cindex trampoline This restriction prevents the compiler from building ``trampolines''. This is a structure that is built on the stack and contains dynamic code to be executed at run time. On some targets, a trampoline is @@ -8379,6 +8380,17 @@ nested task bodies; primitive operations of nested tagged types. Trampolines do not work on machines that prevent execution of stack data. For example, on windows systems, enabling DEP (data execution protection) will cause trampolines to raise an exception. +Trampolines are also quite slow at run time. + +On many targets, trampolines have been largely eliminated. Look at the +version of system.ads for your target --- if it has +Always_Compatible_Rep equal to False, then trampolines are largely +eliminated. In particular, a trampoline is built for the following +features: @code{Address} of a nested subprogram; +@code{Access} or @code{Unrestricted_Access} of a nested subprogram, +but only if pragma Favor_Top_Level applies, or the access type has a +foreign-language convention; primitive operations of nested tagged +types. @item No_Implicit_Loops @findex No_Implicit_Loops diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 5dce93a7cc3..4f96a2d8ec4 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -12072,7 +12072,9 @@ the inherited body is not part of the sources of the project, otherwise there will be a compilation error when compiling the spec. For that purpose, the attribute @code{Excluded_Source_Files} is used. -Its value is a string list: a list of file names. +Its value is a string list: a list of file names. It is also possible to use +attribute @code{Excluded_Source_List_File}. Its value is a single string: +the file name of a text file containing a list of file names, one per line. @smallexample @c @projectfile project B extends "a" is @@ -12495,6 +12497,8 @@ The following attributes are defined on projects (all are simple attributes): @tab string list @item @code{Excluded_Source_Files} @tab string list +@item @code{Excluded_Source_List_File} +@tab string @item @code{Languages} @tab string list @item @code{Main} diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8135bfc8a4d..2b0c6c4add2 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -349,9 +349,9 @@ procedure GNATCmd is while Main /= Nil_String loop File := new String' - (Get_Name_String (Data.Object_Directory) & - Directory_Separator & - B_Start.all & + (Get_Name_String (Data.Object_Directory.Name) & + Directory_Separator & + B_Start.all & MLib.Fil.Ext_To (Get_Name_String (Project_Tree.String_Elements.Table @@ -375,10 +375,10 @@ procedure GNATCmd is File := new String' - (Get_Name_String (Data.Object_Directory) & - Directory_Separator & - B_Start.all & - Get_Name_String (Data.Library_Name) & + (Get_Name_String (Data.Object_Directory.Name) & + Directory_Separator & + B_Start.all & + Get_Name_String (Data.Library_Name) & ".ci"); if Is_Regular_File (File.all) then @@ -403,7 +403,7 @@ procedure GNATCmd is if Unit_Data.File_Names (Body_Part).Name /= No_File and then - Unit_Data.File_Names (Body_Part).Path /= Slash + Unit_Data.File_Names (Body_Part).Path.Name /= Slash then -- There is a body, check if it is for this project @@ -415,7 +415,8 @@ procedure GNATCmd is if Unit_Data.File_Names (Specification).Name = No_File or else - Unit_Data.File_Names (Specification).Path = Slash + Unit_Data.File_Names + (Specification).Path.Name = Slash then -- We have a body with no spec: we need to check if -- this is a subunit, because gnatls will complain @@ -428,7 +429,7 @@ procedure GNATCmd is Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit_Data.File_Names - (Body_Part).Path)); + (Body_Part).Path.Name)); Subunit := Sinput.P.Source_File_Is_Subunit @@ -449,7 +450,7 @@ procedure GNATCmd is elsif Unit_Data.File_Names (Specification).Name /= No_File and then - Unit_Data.File_Names (Specification).Path /= Slash + Unit_Data.File_Names (Specification).Path.Name /= Slash then -- We have a spec with no body; check if it is for this -- project. @@ -475,7 +476,7 @@ procedure GNATCmd is if Unit_Data.File_Names (Body_Part).Name /= No_File and then - Unit_Data.File_Names (Body_Part).Path /= Slash + Unit_Data.File_Names (Body_Part).Path.Name /= Slash then -- There is a body. Check if .ci files for this project -- must be added. @@ -489,7 +490,8 @@ procedure GNATCmd is if Unit_Data.File_Names (Specification).Name = No_File or else - Unit_Data.File_Names (Specification).Path = Slash + Unit_Data.File_Names + (Specification).Path.Name = Slash then -- We have a body with no spec: we need to check -- if this is a subunit, because .ci files are not @@ -501,7 +503,8 @@ procedure GNATCmd is begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String - (Unit_Data.File_Names (Body_Part).Path)); + (Unit_Data.File_Names + (Body_Part).Path.Name)); Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind); @@ -516,7 +519,7 @@ procedure GNATCmd is (Project_Tree.Projects.Table (Unit_Data.File_Names (Body_Part).Project). - Object_Directory) & + Object_Directory.Name) & Directory_Separator & MLib.Fil.Ext_To (Get_Name_String @@ -529,7 +532,7 @@ procedure GNATCmd is elsif Unit_Data.File_Names (Specification).Name /= No_File and then - Unit_Data.File_Names (Specification).Path /= Slash + Unit_Data.File_Names (Specification).Path.Name /= Slash then -- We have a spec with no body. Check if it is for this -- project. @@ -546,7 +549,7 @@ procedure GNATCmd is (Project_Tree.Projects.Table (Unit_Data.File_Names (Specification).Project). - Object_Directory) & + Object_Directory.Name) & Dir_Separator & MLib.Fil.Ext_To (Get_Name_String @@ -565,14 +568,14 @@ procedure GNATCmd is if Check_Project (Unit_Data.File_Names (Kind).Project, Project) and then Unit_Data.File_Names (Kind).Name /= No_File - and then Unit_Data.File_Names (Kind).Path /= Slash + and then Unit_Data.File_Names (Kind).Path.Name /= Slash then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String' (Get_Name_String (Unit_Data.File_Names - (Kind).Display_Path)); + (Kind).Path.Display_Name)); end if; end loop; end if; @@ -688,7 +691,7 @@ procedure GNATCmd is end loop; Get_Name_String (Project_Tree.Projects.Table - (Project).Exec_Directory); + (Project).Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -870,7 +873,7 @@ procedure GNATCmd is Get_Name_String (Udata.File_Names (Specification).Name) = Line (1 .. Last) then - Path := Udata.File_Names (Specification).Path; + Path := Udata.File_Names (Specification).Path.Name; exit; elsif Udata.File_Names (Body_Part).Name /= No_File @@ -878,7 +881,7 @@ procedure GNATCmd is Get_Name_String (Udata.File_Names (Body_Part).Name) = Line (1 .. Last) then - Path := Udata.File_Names (Body_Part).Path; + Path := Udata.File_Names (Body_Part).Path.Name; exit; end if; end loop; @@ -1103,7 +1106,7 @@ procedure GNATCmd is Dir : constant String := Get_Name_String (Project_Tree.Projects.Table - (Prj).Object_Directory); + (Prj).Object_Directory.Name); begin if Is_Regular_File (Dir & @@ -1184,7 +1187,7 @@ procedure GNATCmd is new String'("-o"); Get_Name_String (Project_Tree.Projects.Table - (Project).Exec_Directory); + (Project).Exec_Directory.Name); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len) & @@ -1222,7 +1225,7 @@ procedure GNATCmd is new String'("-L" & Get_Name_String (Project_Tree.Projects.Table - (Project).Library_Dir)); + (Project).Library_Dir.Name)); -- Add the -l switch @@ -1244,7 +1247,7 @@ procedure GNATCmd is Library_Paths.Table (Library_Paths.Last) := new String'(Get_Name_String (Project_Tree.Projects.Table - (Project).Library_Dir)); + (Project).Library_Dir.Name)); end if; end if; end Set_Library_For; @@ -1336,7 +1339,14 @@ procedure GNATCmd is Put (To_Lower (Command_List (C).Cname.all)); Set_Col (25); - Put (Program_Name (Command_List (C).Unixcmd.all).all); + + -- Never call gnatstack with a prefix + + if C = Stack then + Put (Command_List (C).Unixcmd.all); + else + Put (Program_Name (Command_List (C).Unixcmd.all).all); + end if; declare Sws : Argument_List_Access renames Command_List (C).Unixsws; @@ -1560,18 +1570,26 @@ begin end if; declare - Program : constant String := - Program_Name (Command_List (The_Command).Unixcmd.all).all; - + Program : String_Access; Exec_Path : String_Access; begin + if The_Command = Stack then + -- Never call gnatstack with a prefix + + Program := new String'(Command_List (The_Command).Unixcmd.all); + + else + Program := + Program_Name (Command_List (The_Command).Unixcmd.all); + end if; + -- Locate the executable for the command - Exec_Path := Locate_Exec_On_Path (Program); + Exec_Path := Locate_Exec_On_Path (Program.all); if Exec_Path = null then - Put_Line (Standard_Error, "could not locate " & Program); + Put_Line (Standard_Error, "could not locate " & Program.all); raise Error_Exit; end if; @@ -1978,7 +1996,7 @@ begin Change_Dir (Get_Name_String (Project_Tree.Projects.Table - (Project).Object_Directory)); + (Project).Object_Directory.Name)); end if; -- Set up the env vars for project path files @@ -2191,7 +2209,7 @@ begin end loop; Get_Name_String - (Project_Tree.Projects.Table (Project).Directory); + (Project_Tree.Projects.Table (Project).Directory.Name); declare Project_Dir : constant String := Name_Buffer (1 .. Name_Len); @@ -2291,7 +2309,8 @@ begin if The_Command = Metric and then - Project_Tree.Projects.Table (Project).Object_Directory /= No_Path + Project_Tree.Projects.Table (Project).Object_Directory /= + No_Path_Information then First_Switches.Increment_Last; First_Switches.Table (2 .. First_Switches.Last) := @@ -2300,7 +2319,7 @@ begin new String'("-d=" & Get_Name_String (Project_Tree.Projects.Table - (Project).Object_Directory)); + (Project).Object_Directory.Name)); end if; -- For gnat check, -rules and the following switches need to be the diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 304f15556ca..c1737b7ed47 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1068,7 +1068,7 @@ package body Make is else Get_Name_String - (Project_Tree.Projects.Table (Main_Project).Display_Directory); + (Project_Tree.Projects.Table (Main_Project).Directory.Display_Name); Add_Lib_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; @@ -1120,7 +1120,7 @@ package body Make is else Get_Name_String - (Project_Tree.Projects.Table (Main_Project).Display_Directory); + (Project_Tree.Projects.Table (Main_Project).Directory.Display_Name); Add_Src_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; @@ -1391,7 +1391,7 @@ package body Make is if Project_Of_Current_Object_Directory /= Actual_Project then Project_Of_Current_Object_Directory := Actual_Project; Object_Directory := - Project_Tree.Projects.Table (Actual_Project).Object_Directory; + Project_Tree.Projects.Table (Actual_Project).Object_Directory.Name; -- Set the working directory to the object directory of the actual -- project. @@ -1415,7 +1415,7 @@ package body Make is Make_Failed ("unable to change to object directory """ & Path_Or_File_Name (Project_Tree.Projects.Table - (Actual_Project).Object_Directory) & + (Actual_Project).Object_Directory.Name) & """ of project " & Get_Name_String (Project_Tree.Projects.Table (Actual_Project).Display_Name)); @@ -1938,7 +1938,7 @@ package body Make is while ALI_Project /= No_Project and then Obj_Dir /= Project_Tree.Projects.Table - (ALI_Project).Object_Directory + (ALI_Project).Object_Directory.Name loop ALI_Project := Project_Tree.Projects.Table (ALI_Project).Extended_By; @@ -2330,7 +2330,7 @@ package body Make is if Data.Dir_Path = null then Data.Dir_Path := - new String'(Get_Name_String (Data.Display_Directory)); + new String'(Get_Name_String (Data.Directory.Display_Name)); Project_Tree.Projects.Table (Arguments_Project) := Data; end if; @@ -3580,7 +3580,8 @@ package body Make is Udata.File_Names (Body_Part).Name /= No_File and then - Udata.File_Names (Body_Part).Path /= Slash + Udata.File_Names (Body_Part).Path.Name /= + Slash then Sfile := Udata.File_Names (Body_Part).Name; Source_Index := @@ -3590,8 +3591,8 @@ package body Make is Udata.File_Names (Specification).Name /= No_File and then - Udata.File_Names (Specification).Path /= - Slash + Udata.File_Names + (Specification).Path.Name /= Slash then Sfile := Udata.File_Names (Specification).Name; @@ -3796,7 +3797,7 @@ package body Make is Parent_Directory : constant String := Get_Name_String (Project_Tree.Projects.Table - (Project).Display_Directory); + (Project).Directory.Display_Name); begin if Parent_Directory (Parent_Directory'Last) = @@ -4538,9 +4539,9 @@ package body Make is -- for other projects, use the object directory. if PD.Library then - Get_Name_String (PD.Library_Dir); + Get_Name_String (PD.Library_Dir.Name); else - Get_Name_String (PD.Object_Directory); + Get_Name_String (PD.Object_Directory.Name); end if; if Name_Buffer (Name_Len) /= @@ -4987,7 +4988,7 @@ package body Make is if Main_Project /= No_Project then if Project_Tree.Projects.Table - (Main_Project).Object_Directory /= No_Path + (Main_Project).Object_Directory /= No_Path_Information then -- Change current directory to object directory of main project @@ -5264,7 +5265,7 @@ package body Make is -- impossible to build the library. So fail immediately. if Project_Tree.Projects.Table (Proj).Object_Directory = - No_Path + No_Path_Information then Make_Failed ("no object files to build library for project """, @@ -5308,7 +5309,7 @@ package body Make is if not Is_Absolute_Path (Exec_File_Name) then Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Exec_Directory); + (Main_Project).Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -5337,7 +5338,7 @@ package body Make is Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Directory)); + (Main_Project).Directory.Name)); begin for J in 1 .. Binder_Switches.Last loop Test_If_Relative_Path @@ -5554,8 +5555,9 @@ package body Make is begin if not Is_Absolute_Path (Exec_File_Name) then - Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Display_Exec_Dir); + Get_Name_String + (Project_Tree.Projects.Table + (Main_Project).Exec_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -6141,7 +6143,7 @@ package body Make is new String' (Get_Name_String (Project_Tree.Projects.Table - (Proj1).Display_Library_Dir)); + (Proj1).Library_Dir.Display_Name)); end if; end if; end loop; @@ -6156,7 +6158,7 @@ package body Make is Get_Name_String (Project_Tree.Projects.Table (Library_Projs.Table (Index)). - Display_Library_Dir)); + Library_Dir.Display_Name)); -- Add the -l switch @@ -6462,7 +6464,7 @@ package body Make is Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Directory)); + (Main_Project).Directory.Name)); begin for J in Last_Binder_Switch + 1 .. Binder_Switches.Last @@ -6961,7 +6963,7 @@ package body Make is -- locally removed, if Unit.File_Names (Body_Part).Name /= No_File - and then Unit.File_Names (Body_Part).Path /= Slash + and then Unit.File_Names (Body_Part).Path.Name /= Slash then -- And it is a source for the specified project @@ -6988,7 +6990,7 @@ package body Make is begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String - (Unit.File_Names (Body_Part).Path)); + (Unit.File_Names (Body_Part).Path.Name)); -- If it is a subunit, discard it @@ -7008,7 +7010,7 @@ package body Make is end if; elsif Unit.File_Names (Specification).Name /= No_File - and then Unit.File_Names (Specification).Path /= Slash + and then Unit.File_Names (Specification).Path.Name /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then -- If there is no source for the body, but there is a source @@ -7184,8 +7186,8 @@ package body Make is declare Object_Directory : constant String := Normalize_Pathname - (Get_Name_String - (Data.Display_Object_Dir)); + (Get_Name_String + (Data.Object_Directory.Display_Name)); Olast : Natural := Object_Directory'Last; @@ -7380,7 +7382,7 @@ package body Make is (Dir, Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Display_Directory)); + (Main_Project).Directory.Display_Name)); begin if Real_Path'Length = 0 then diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 684cae99eb8..04996bb4e13 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -551,7 +551,7 @@ package body Makegpr is if not For_Gnatmake then if Data.Library_Kind = Static then Add_Argument - (Get_Name_String (Data.Display_Library_Dir) & + (Get_Name_String (Data.Library_Dir.Display_Name) & Directory_Separator & "lib" & Get_Name_String (Data.Library_Name) & '.' & Archive_Ext, @@ -565,7 +565,7 @@ package body Makegpr is ("-l" & Get_Name_String (Data.Library_Name), Verbose_Mode); - Get_Name_String (Data.Display_Library_Dir); + Get_Name_String (Data.Library_Dir.Display_Name); Add_Argument ("-L" & Name_Buffer (1 .. Name_Len), @@ -617,7 +617,7 @@ package body Makegpr is elsif Project = Main_Project and then Global_Archive_Exists then Add_Argument - (Get_Name_String (Data.Display_Object_Dir) & + (Get_Name_String (Data.Object_Directory.Display_Name) & Directory_Separator & "lib" & Get_Name_String (Data.Display_Name) & '.' & Archive_Ext, @@ -1069,13 +1069,13 @@ package body Makegpr is if Project_Of_Current_Object_Directory /= Main_Project then Project_Of_Current_Object_Directory := Main_Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); + Change_Dir (Get_Name_String (Data.Object_Directory.Name)); if Verbose_Mode then Write_Str ("Changing to object directory of """); Write_Name (Data.Display_Name); Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); + Write_Name (Data.Object_Directory.Display_Name); Write_Line (""""); end if; end if; @@ -1647,7 +1647,8 @@ package body Makegpr is MLib.Build_Library (Ofiles => Arguments (1 .. Last_Argument), Output_File => Get_Name_String (Data.Library_Name), - Output_Dir => Get_Name_String (Data.Display_Library_Dir)); + Output_Dir => Get_Name_String + (Data.Library_Dir.Display_Name)); else -- Link with g++ if C++ is one of the languages, otherwise @@ -1709,7 +1710,7 @@ package body Makegpr is Options => Lib_Opts.all, Interfaces => No_Argument, Lib_Filename => Get_Name_String (Data.Library_Name), - Lib_Dir => Get_Name_String (Data.Library_Dir), + Lib_Dir => Get_Name_String (Data.Library_Dir.Name), Symbol_Data => No_Symbols, Driver_Name => Driver_Name, Lib_Version => "", @@ -2460,13 +2461,13 @@ package body Makegpr is if Project_Of_Current_Object_Directory /= Main_Project then Project_Of_Current_Object_Directory := Main_Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); + Change_Dir (Get_Name_String (Data.Object_Directory.Name)); if Verbose_Mode then Write_Str ("Changing to object directory of """); Write_Name (Data.Name); Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); + Write_Name (Data.Object_Directory.Display_Name); Write_Line (""""); end if; end if; @@ -2567,7 +2568,7 @@ package body Makegpr is -- Specify the project file Add_Argument (Dash_P, True); - Add_Argument (Get_Name_String (Data.Display_Path_Name), True); + Add_Argument (Get_Name_String (Data.Path.Display_Name), True); -- Add the saved switches, if any @@ -2774,13 +2775,13 @@ package body Makegpr is if Project_Of_Current_Object_Directory /= Project then Project_Of_Current_Object_Directory := Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); + Change_Dir (Get_Name_String (Data.Object_Directory.Name)); if Verbose_Mode then Write_Str ("Changing to object directory of """); Write_Name (Data.Display_Name); Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); + Write_Name (Data.Object_Directory.Display_Name); Write_Line (""""); end if; end if; @@ -3351,7 +3352,7 @@ package body Makegpr is if not Compile_Only and then not Data.Library - and then Data.Object_Directory /= No_Path + and then Data.Object_Directory /= No_Path_Information then Build_Global_Archive; Link_Executables; @@ -3513,7 +3514,7 @@ package body Makegpr is -- True if main sources were specified on the command line Object_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); -- Path of the object directory of the main project Source_Id : Other_Source_Id; @@ -3576,7 +3577,8 @@ package body Makegpr is if Data.Other_Sources_Present then declare Archive_Path : constant String := Get_Name_String - (Prj_Data.Display_Object_Dir) & Directory_Separator + (Prj_Data.Object_Directory.Display_Name) + & Directory_Separator & "lib" & Get_Name_String (Prj_Data.Display_Name) & '.' & Archive_Ext; Archive_TS : Time_Stamp_Type; @@ -3641,7 +3643,7 @@ package body Makegpr is Executable_Path : constant String := Get_Name_String - (Data.Display_Exec_Dir) & + (Data.Exec_Directory.Display_Name) & Directory_Separator & Executable_Name; -- Path name of the executable @@ -3699,7 +3701,7 @@ package body Makegpr is Add_Argument (Dash_o, True); Add_Argument - (Get_Name_String (Data.Display_Exec_Dir) & + (Get_Name_String (Data.Exec_Directory.Display_Name) & Directory_Separator & Get_Name_String (Executable_Of diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 63b975c36f6..1755ade229c 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -442,7 +442,7 @@ package body Makeutl is new String' (Get_Name_String (In_Tree.Projects.Table - (Proj). Directory)); + (Proj).Directory.Name)); end if; while Options /= Nil_String loop @@ -481,8 +481,13 @@ package body Makeutl is package body Mains is + type File_And_Loc is record + File_Name : File_Name_Type; + Location : Source_Ptr := No_Location; + end record; + package Names is new Table.Table - (Table_Component_Type => File_Name_Type, + (Table_Component_Type => File_And_Loc, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, @@ -502,7 +507,7 @@ package body Makeutl is Name_Len := 0; Add_Str_To_Name_Buffer (Name); Names.Increment_Last; - Names.Table (Names.Last) := Name_Find; + Names.Table (Names.Last) := (Name_Find, No_Location); end Add_Main; ------------ @@ -515,6 +520,19 @@ package body Makeutl is Mains.Reset; end Delete; + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location return Source_Ptr is + begin + if Current in Names.First .. Names.Last then + return Names.Table (Current).Location; + else + return No_Location; + end if; + end Get_Location; + --------------- -- Next_Main -- --------------- @@ -523,10 +541,9 @@ package body Makeutl is begin if Current >= Names.Last then return ""; - else Current := Current + 1; - return Get_Name_String (Names.Table (Current)); + return Get_Name_String (Names.Table (Current).File_Name); end if; end Next_Main; @@ -548,6 +565,29 @@ package body Makeutl is Current := 0; end Reset; + ------------------ + -- Set_Location -- + ------------------ + + procedure Set_Location (Location : Source_Ptr) is + begin + if Names.Last > 0 then + Names.Table (Names.Last).Location := Location; + end if; + end Set_Location; + + ----------------- + -- Update_Main -- + ----------------- + + procedure Update_Main (Name : String) is + begin + if Current in Names.First .. Names.Last then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + Names.Table (Current).File_Name := Name_Find; + end if; + end Update_Main; end Mains; ---------- diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 9672744a1ac..b6483f3e520 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -103,6 +103,10 @@ package Makeutl is procedure Add_Main (Name : String); -- Add one main to the table + procedure Set_Location (Location : Source_Ptr); + -- Set the location of the last main added. By default, the location is + -- No_Location. + procedure Delete; -- Empty the table @@ -113,6 +117,12 @@ package Makeutl is -- Increase the index and return the next main. -- If table is exhausted, return an empty string. + function Get_Location return Source_Ptr; + -- Get the location of the current main + + procedure Update_Main (Name : String); + -- Update the file name of the current main + function Number_Of_Mains return Natural; -- Returns the number of mains added with Add_Main since the last call -- to Delete. diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 193b54ca408..7e86facd99d 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -322,7 +322,8 @@ package body MLib.Prj is -- g-trasym.obj. Object_Directory_Path : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String + (Data.Object_Directory.Display_Name); Standalone : constant Boolean := Data.Standalone_Library; @@ -713,14 +714,15 @@ package body MLib.Prj is if Libgnarl_Needed = Unknown then if Data.Libgnarl_Needed = Unknown - and then Data.Object_Directory /= No_Path + and then Data.Object_Directory /= No_Path_Information then -- Check if libgnarl is needed for this library declare Object_Dir_Path : constant String := Get_Name_String - (Data.Display_Object_Dir); + (Data.Object_Directory. + Display_Name); Object_Dir : Dir_Type; Filename : String (1 .. 255); Last : Natural; @@ -799,7 +801,7 @@ package body MLib.Prj is Current := Library_Projs.Table (Index); Get_Name_String - (In_Tree.Projects.Table (Current).Display_Library_Dir); + (In_Tree.Projects.Table (Current).Library_Dir.Display_Name); Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Name_Buffer (1 .. Name_Len)); @@ -966,7 +968,7 @@ package body MLib.Prj is Unit := In_Tree.Units.Table (Source); if Unit.File_Names (Body_Part).Name /= No_File - and then Unit.File_Names (Body_Part).Path /= Slash + and then Unit.File_Names (Body_Part).Path.Name /= Slash then if Check_Project (Unit.File_Names (Body_Part).Project) @@ -979,7 +981,7 @@ package body MLib.Prj is Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit.File_Names - (Body_Part).Path)); + (Body_Part).Path.Name)); -- Add the ALI file only if it is not a subunit @@ -999,7 +1001,7 @@ package body MLib.Prj is end if; elsif Unit.File_Names (Specification).Name /= No_File - and then Unit.File_Names (Specification).Path /= Slash + and then Unit.File_Names (Specification).Path.Name /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then @@ -1318,7 +1320,7 @@ package body MLib.Prj is end if; Lib_Dirpath := - new String'(Get_Name_String (Data.Display_Library_Dir)); + new String'(Get_Name_String (Data.Library_Dir.Display_Name)); Lib_Filename := new String'(Get_Name_String (Data.Library_Name)); case Data.Library_Kind is @@ -1355,176 +1357,187 @@ package body MLib.Prj is There_Are_Foreign_Sources := Data.Other_Sources_Present; loop - declare - Object_Dir_Path : constant String := - Get_Name_String (Data.Display_Object_Dir); - Object_Dir : Dir_Type; - Filename : String (1 .. 255); - Last : Natural; - Id : Name_Id; + if Data.Object_Directory /= No_Path_Information then + declare + Object_Dir_Path : constant String := + Get_Name_String + (Data.Object_Directory.Display_Name); + Object_Dir : Dir_Type; + Filename : String (1 .. 255); + Last : Natural; + Id : Name_Id; - begin - Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); + begin + Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); - -- For all entries in the object directory + -- For all entries in the object directory - loop - Read (Object_Dir, Filename, Last); + loop + Read (Object_Dir, Filename, Last); - exit when Last = 0; + exit when Last = 0; - -- Check if it is an object file + -- Check if it is an object file - if Is_Obj (Filename (1 .. Last)) then - declare - Object_Path : constant String := - Normalize_Pathname - (Object_Dir_Path & Directory_Separator & - Filename (1 .. Last)); - C_Object_Path : String := Object_Path; - C_Filename : String := Filename (1 .. Last); + if Is_Obj (Filename (1 .. Last)) then + declare + Object_Path : constant String := + Normalize_Pathname + (Object_Dir_Path & + Directory_Separator & + Filename (1 .. Last)); + C_Object_Path : String := Object_Path; + C_Filename : String := Filename (1 .. Last); - begin - Canonical_Case_File_Name (C_Object_Path); - Canonical_Case_File_Name (C_Filename); + begin + Canonical_Case_File_Name (C_Object_Path); + Canonical_Case_File_Name (C_Filename); - -- If in the object directory of an extended project, - -- do not consider generated object files. + -- If in the object directory of an extended + -- project, do not consider generated object files. - if In_Main_Object_Directory - or else Last < 5 - or else C_Filename (1 .. B_Start'Length) /= - B_Start.all - then - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := - C_Filename (1 .. Last); - Id := Name_Find; - - if not Objects_Htable.Get (Id) then - declare - ALI_File : constant String := - Ext_To - (C_Filename - (1 .. Last), "ali"); - ALI_Path : constant String := - Ext_To (C_Object_Path, "ali"); - Add_It : Boolean := - There_Are_Foreign_Sources - or else - (Last > 5 + if In_Main_Object_Directory + or else Last < 5 + or else + C_Filename (1 .. B_Start'Length) /= B_Start.all + then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := + C_Filename (1 .. Last); + Id := Name_Find; + + if not Objects_Htable.Get (Id) then + declare + ALI_File : constant String := + Ext_To + (C_Filename + (1 .. Last), "ali"); + ALI_Path : constant String := + Ext_To (C_Object_Path, "ali"); + Add_It : Boolean := + There_Are_Foreign_Sources + or else + (Last > 5 and then - C_Filename - (1 .. B_Start'Length) = - B_Start.all); - Fname : File_Name_Type; - Proj : Project_Id; - - begin - if Is_Regular_File (ALI_Path) then - - -- If there is an ALI file, check if the - -- object file should be added to the - -- library. If there are foreign sources - -- we put all object files in the library. - - if not Add_It then - for Index in - 1 .. Unit_Table.Last (In_Tree.Units) - loop - if In_Tree.Units.Table - (Index).File_Names - (Body_Part).Name /= No_File - then - Proj := - In_Tree.Units.Table (Index). - File_Names - (Body_Part).Project; - Fname := - In_Tree.Units.Table (Index). - File_Names (Body_Part).Name; - - elsif - In_Tree.Units.Table - (Index).File_Names - (Specification).Name /= No_File - then - Proj := - In_Tree.Units.Table + C_Filename + (1 .. B_Start'Length) = + B_Start.all); + Fname : File_Name_Type; + Proj : Project_Id; + + begin + if Is_Regular_File (ALI_Path) then + + -- If there is an ALI file, check if + -- the object file should be added to + -- the library. If there are foreign + -- sources we put all object files in + -- the library. + + if not Add_It then + for Index in + 1 .. Unit_Table.Last + (In_Tree.Units) + loop + if In_Tree.Units.Table (Index).File_Names - (Specification).Project; - Fname := + (Body_Part).Name /= No_File + then + Proj := + In_Tree.Units.Table (Index). + File_Names + (Body_Part).Project; + Fname := + In_Tree.Units.Table (Index). + File_Names (Body_Part).Name; + + elsif In_Tree.Units.Table (Index).File_Names - (Specification).Name; - - else - Proj := No_Project; - end if; - - Add_It := Proj /= No_Project; - - -- If the source is in the project - -- or a project it extends, we may - -- put it in the library. - - if Add_It then - Add_It := Check_Project (Proj); - end if; - - -- But we don't, if the ALI file - -- does not correspond to the unit. - - if Add_It then - declare - F : constant String := - Ext_To - (Get_Name_String - (Fname), "ali"); - begin - Add_It := F = ALI_File; - end; - end if; - - exit when Add_It; - end loop; - end if; + (Specification).Name /= + No_File + then + Proj := + In_Tree.Units.Table + (Index).File_Names + (Specification).Project; + Fname := + In_Tree.Units.Table + (Index).File_Names + (Specification).Name; + + else + Proj := No_Project; + end if; + + Add_It := Proj /= No_Project; + + -- If the source is in the + -- project or a project it + -- extends, we may put it in + -- the library. + + if Add_It then + Add_It := Check_Project (Proj); + end if; + + -- But we don't, if the ALI file + -- does not correspond to the + -- unit. + + if Add_It then + declare + F : constant String := + Ext_To + (Get_Name_String + (Fname), "ali"); + begin + Add_It := F = ALI_File; + end; + end if; + + exit when Add_It; + end loop; + end if; - if Add_It then - Objects_Htable.Set (Id, True); - Objects.Append - (new String'(Object_Path)); + if Add_It then + Objects_Htable.Set (Id, True); + Objects.Append + (new String'(Object_Path)); - -- Record the ALI file + -- Record the ALI file - ALIs.Append (new String'(ALI_Path)); + ALIs.Append (new String'(ALI_Path)); - -- Find out if for this ALI file, - -- libgnarl or libdecgnat or - -- g-trasym.obj (on OpenVMS) is - -- necessary. + -- Find out if for this ALI file, + -- libgnarl or libdecgnat or + -- g-trasym.obj (on OpenVMS) is + -- necessary. - Check_Libs (ALI_Path, True); - end if; + Check_Libs (ALI_Path, True); + end if; - elsif There_Are_Foreign_Sources then - Objects.Append (new String'(Object_Path)); - end if; - end; + elsif There_Are_Foreign_Sources then + Objects.Append + (new String'(Object_Path)); + end if; + end; + end if; end if; - end if; - end; - end if; - end loop; + end; + end if; + end loop; - Close (Dir => Object_Dir); + Close (Dir => Object_Dir); - exception - when Directory_Error => - Com.Fail ("cannot find object directory """, - Get_Name_String (Data.Object_Directory), - """"); - end; + exception + when Directory_Error => + Com.Fail ("cannot find object directory """, + Get_Name_String + (Data.Object_Directory.Display_Name), + """"); + end; + end if; exit when Data.Extends = No_Project; @@ -1798,7 +1811,7 @@ package body MLib.Prj is begin Get_Name_String - (In_Tree.Projects.Table (For_Project).Library_Dir); + (In_Tree.Projects.Table (For_Project).Library_Dir.Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception @@ -1938,21 +1951,22 @@ package body MLib.Prj is Copy_ALI_Files (Files => Ali_Files.all, - To => In_Tree.Projects.Table (For_Project).Library_ALI_Dir, + To => In_Tree.Projects.Table + (For_Project).Library_ALI_Dir.Name, Interfaces => Arguments (1 .. Argument_Number)); -- Copy interface sources if Library_Src_Dir specified if Standalone and then In_Tree.Projects.Table - (For_Project).Library_Src_Dir /= No_Path + (For_Project).Library_Src_Dir /= No_Path_Information then -- Clean the interface copy directory: remove any source that -- could be a source of the project. begin Get_Name_String - (In_Tree.Projects.Table (For_Project).Library_Src_Dir); + (In_Tree.Projects.Table (For_Project).Library_Src_Dir.Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception @@ -2030,7 +2044,7 @@ package body MLib.Prj is In_Tree => In_Tree, Interfaces => Arguments (1 .. Argument_Number), To_Dir => In_Tree.Projects.Table - (For_Project).Display_Library_Src_Dir); + (For_Project).Library_Src_Dir.Display_Name); end if; end if; @@ -2084,14 +2098,14 @@ package body MLib.Prj is Lib_Name : constant File_Name_Type := Library_File_Name_For (For_Project, In_Tree); begin - Change_Dir (Get_Name_String (Data.Library_Dir)); + Change_Dir (Get_Name_String (Data.Library_Dir.Name)); Lib_TS := File_Stamp (Lib_Name); In_Tree.Projects.Table (For_Project).Library_TS := Lib_TS; end; if not Data.Externally_Built and then not Data.Need_To_Build_Lib - and then Data.Object_Directory /= No_Path + and then Data.Object_Directory /= No_Path_Information then declare Obj_TS : Time_Stamp_Type; @@ -2105,7 +2119,7 @@ package body MLib.Prj is -- If the library file does not exist, then the time stamp will -- be Empty_Time_Stamp, earlier than any other time stamp. - Change_Dir (Get_Name_String (Data.Object_Directory)); + Change_Dir (Get_Name_String (Data.Object_Directory.Name)); Open (Dir => Object_Dir, Dir_Name => "."); -- For all entries in the object directory @@ -2209,7 +2223,7 @@ package body MLib.Prj is and then Data.File_Names (J).Name = File_Name then Copy_File - (Get_Name_String (Data.File_Names (J).Path), + (Get_Name_String (Data.File_Names (J).Path.Name), Target, Success, Mode => Overwrite, @@ -2250,8 +2264,7 @@ package body MLib.Prj is Change_Dir (Get_Name_String - (In_Tree.Projects.Table - (For_Project).Object_Directory)); + (In_Tree.Projects.Table (For_Project).Object_Directory.Name)); for Index in Interfaces'Range loop diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index e4d0441d55a..b2c7c952ede 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -340,7 +340,7 @@ package body MLib.Tgt is declare Lib_Dir : constant String := Get_Name_String - (In_Tree.Projects.Table (Project).Library_Dir); + (In_Tree.Projects.Table (Project).Library_Dir.Name); Lib_Name : constant String := Get_Name_String (In_Tree.Projects.Table (Project).Library_Name); diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index e2b1fbc936b..6f6c888b4e6 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -231,6 +231,7 @@ package body Prj.Attr is "Ladefault_switches#" & "Lcswitches#" & "LVlinker_options#" & + "SVmap_file_option#" & -- Configuration - Linking diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index bbc45c57d3c..dd52f353287 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -251,7 +251,7 @@ package body Prj.Env is if (Data.Library and then Including_Libraries) or else - (Data.Object_Directory /= No_Path + (Data.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Data.Library)) then @@ -260,19 +260,22 @@ package body Prj.Env is -- files; otherwise add the object directory. if Data.Library then - if Data.Object_Directory = No_Path + if Data.Object_Directory = No_Path_Information or else - Contains_ALI_Files (Data.Library_ALI_Dir) + Contains_ALI_Files (Data.Library_ALI_Dir.Name) then - Add_To_Path (Get_Name_String (Data.Library_ALI_Dir)); + Add_To_Path + (Get_Name_String (Data.Library_ALI_Dir.Name)); else - Add_To_Path (Get_Name_String (Data.Object_Directory)); + Add_To_Path + (Get_Name_String (Data.Object_Directory.Name)); end if; else -- For a non library project, add the object directory - Add_To_Path (Get_Name_String (Data.Object_Directory)); + Add_To_Path + (Get_Name_String (Data.Object_Directory.Name)); end if; end if; @@ -520,7 +523,7 @@ package body Prj.Env is -- If we don't know the path name of the body of this unit, -- we compute it, and we store it. - if Data.File_Names (Body_Part).Path = No_Path then + if Data.File_Names (Body_Part).Path = No_Path_Information then declare Current_Source : String_List_Id := In_Tree.Projects.Table @@ -530,7 +533,7 @@ package body Prj.Env is begin -- By default, put the file name - Data.File_Names (Body_Part).Path := + Data.File_Names (Body_Part).Path.Name := Path_Name_Type (Data.File_Names (Body_Part).Name); -- For each source directory @@ -550,7 +553,7 @@ package body Prj.Env is if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; - Data.File_Names (Body_Part).Path := Name_Enter; + Data.File_Names (Body_Part).Path.Name := Name_Enter; exit; else @@ -566,7 +569,7 @@ package body Prj.Env is -- Returned the stored value - return Namet.Get_Name_String (Data.File_Names (Body_Part).Path); + return Namet.Get_Name_String (Data.File_Names (Body_Part).Path.Name); end Body_Path_Name_Of; ------------------------ @@ -1005,13 +1008,13 @@ package body Prj.Env is -- If there is a spec, put it in the mapping if Data.Name /= No_File then - if Data.Path = Slash then + if Data.Path.Name = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, - Path_Name => File_Name_Type (Data.Path)); + Path_Name => File_Name_Type (Data.Path.Name)); end if; end if; @@ -1020,13 +1023,13 @@ package body Prj.Env is -- If there is a body (or subunit) put it in the mapping if Data.Name /= No_File then - if Data.Path = Slash then + if Data.Path.Name = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, - Path_Name => File_Name_Type (Data.Path)); + Path_Name => File_Name_Type (Data.Path.Name)); end if; end if; end if; @@ -1111,7 +1114,7 @@ package body Prj.Env is -- Line with the path name - Get_Name_String (Data.Path); + Get_Name_String (Data.Path.Name); Put_Name_Buffer; end Put_Data; @@ -1334,7 +1337,7 @@ package body Prj.Env is if Src_Data.Language_Name = Language and then not Src_Data.Locally_Removed and then Src_Data.Replaced_By = No_Source - and then Src_Data.Path /= No_Path + and then Src_Data.Path.Name /= No_Path then if Src_Data.Unit /= No_Name then Get_Name_String (Src_Data.Unit); @@ -1359,7 +1362,7 @@ package body Prj.Env is Get_Name_String (Src_Data.File); Put_Name_Buffer; - Get_Name_String (Src_Data.Path); + Get_Name_String (Src_Data.Path.Name); Put_Name_Buffer; end if; @@ -1542,7 +1545,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Body_Part).Path); + (Unit.File_Names (Body_Part).Path.Name); else return Get_Name_String (Current_Name); @@ -1558,7 +1561,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Body_Part).Path); + (Unit.File_Names (Body_Part).Path.Name); else return Extended_Body_Name; @@ -1605,7 +1608,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Specification).Path); + (Unit.File_Names (Specification).Path.Name); else return Get_Name_String (Current_Name); end if; @@ -1620,7 +1623,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Specification).Path); + (Unit.File_Names (Specification).Path.Name); else return Extended_Spec_Name; end if; @@ -1723,8 +1726,8 @@ package body Prj.Env is -- If there is an object directory, call Action with its name - if Data.Object_Directory /= No_Path then - Get_Name_String (Data.Display_Object_Dir); + if Data.Object_Directory /= No_Path_Information then + Get_Name_String (Data.Object_Directory.Display_Name); Action (Name_Buffer (1 .. Name_Len)); end if; @@ -1899,16 +1902,17 @@ package body Prj.Env is and then Namet.Get_Name_String (Unit.File_Names (Specification).Name) = Original_Name) - or else (Unit.File_Names (Specification).Path /= No_Path + or else (Unit.File_Names (Specification).Path /= + No_Path_Information and then Namet.Get_Name_String - (Unit.File_Names (Specification).Path) = + (Unit.File_Names (Specification).Path.Name) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Specification).Project, In_Tree => In_Tree); - Path := Unit.File_Names (Specification).Display_Path; + Path := Unit.File_Names (Specification).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Specification."); @@ -1921,15 +1925,15 @@ package body Prj.Env is and then Namet.Get_Name_String (Unit.File_Names (Body_Part).Name) = Original_Name) - or else (Unit.File_Names (Body_Part).Path /= No_Path + or else (Unit.File_Names (Body_Part).Path /= No_Path_Information and then Namet.Get_Name_String - (Unit.File_Names (Body_Part).Path) = + (Unit.File_Names (Body_Part).Path.Name) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Body_Part).Project, In_Tree => In_Tree); - Path := Unit.File_Names (Body_Part).Display_Path; + Path := Unit.File_Names (Body_Part).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Body."); @@ -2121,7 +2125,7 @@ package body Prj.Env is Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table - (Unit.File_Names (Specification).Project).Path_Name); + (Unit.File_Names (Specification).Project).Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; @@ -2139,7 +2143,7 @@ package body Prj.Env is Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table - (Unit.File_Names (Body_Part).Project).Path_Name); + (Unit.File_Names (Body_Part).Project).Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; @@ -2328,7 +2332,7 @@ package body Prj.Env is if (Data.Library and Including_Libraries) or else - (Data.Object_Directory /= No_Path + (Data.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Data.Library)) then @@ -2338,14 +2342,15 @@ package body Prj.Env is -- otherwise add the object directory. if Data.Library then - if Data.Object_Directory = No_Path - or else Contains_ALI_Files (Data.Library_ALI_Dir) + if Data.Object_Directory = No_Path_Information + or else Contains_ALI_Files + (Data.Library_ALI_Dir.Name) then Add_To_Object_Path - (Data.Library_ALI_Dir, In_Tree); + (Data.Library_ALI_Dir.Name, In_Tree); else Add_To_Object_Path - (Data.Object_Directory, In_Tree); + (Data.Object_Directory.Name, In_Tree); end if; -- For a non-library project, add the object @@ -2359,7 +2364,7 @@ package body Prj.Env is and then There_Are_Ada_Sources (In_Tree, Project) then Add_To_Object_Path - (Data.Object_Directory, In_Tree); + (Data.Object_Directory.Name, In_Tree); end if; end if; end if; @@ -2566,7 +2571,7 @@ package body Prj.Env is Data : Unit_Data := In_Tree.Units.Table (Unit); begin - if Data.File_Names (Specification).Path = No_Path then + if Data.File_Names (Specification).Path.Name = No_Path then declare Current_Source : String_List_Id := In_Tree.Projects.Table @@ -2574,7 +2579,7 @@ package body Prj.Env is Path : GNAT.OS_Lib.String_Access; begin - Data.File_Names (Specification).Path := + Data.File_Names (Specification).Path.Name := Path_Name_Type (Data.File_Names (Specification).Name); while Current_Source /= Nil_String loop @@ -2588,7 +2593,7 @@ package body Prj.Env is if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; - Data.File_Names (Specification).Path := Name_Enter; + Data.File_Names (Specification).Path.Name := Name_Enter; exit; else Current_Source := @@ -2601,7 +2606,7 @@ package body Prj.Env is end; end if; - return Namet.Get_Name_String (Data.File_Names (Specification).Path); + return Namet.Get_Name_String (Data.File_Names (Specification).Path.Name); end Spec_Path_Name_Of; --------------------------- diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 83da472229f..39e369256a8 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -85,14 +85,14 @@ package Prj.Env is function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref) return String_Access; - -- Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute - -- it and cache it. + -- Get the source search path of a Project file. For the first call, + -- compute it and cache it. function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Recursive : Boolean) return String; - -- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True, + -- Get the source search path of a Project file. If Recursive it True, -- get all the source directories of the imported and modified project -- files (recursively). If Recursive is False, just get the path for the -- source directories of Project. Note: the resulting String may be empty diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 179609aaab9..d84ba7fbbf7 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -162,6 +162,16 @@ package body Prj.Nmsc is -- A hash table to store naming exceptions for Ada. For each file name -- there is one or several unit in table Ada_Naming_Exception_Table. + package Object_File_Names is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => File_Name_Type, + No_Element => No_File, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to store the object file names for a project, to check that + -- two different sources have different object file names. + type File_Found is record File : File_Name_Type := No_File; Found : Boolean := False; @@ -678,7 +688,7 @@ package body Prj.Nmsc is (Lang_Id).Config.Dependency_Kind; Src_Data.Naming_Exception := Naming_Exception; - if Src_Data.Compiled then + if Src_Data.Compiled and then Src_Data.Object_Exists then Src_Data.Object := Object_Name (File_Name); Src_Data.Dep_Name := Dependency_Name (File_Name, Src_Data.Dependency); @@ -686,8 +696,7 @@ package body Prj.Nmsc is end if; if Path /= No_Path then - Src_Data.Path := Path; - Src_Data.Display_Path := Display_Path; + Src_Data.Path := (Path, Display_Path); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path, Id); end if; @@ -1831,9 +1840,7 @@ package body Prj.Nmsc is Data.Config.Linker := Path_Name_Type (Attribute.Value.Value); - elsif - Attribute.Name = Name_Required_Switches - then + elsif Attribute.Name = Name_Required_Switches then -- Attribute Required_Switches: the minimum -- options to use when invoking the linker @@ -1843,6 +1850,8 @@ package body Prj.Nmsc is From_List => Attribute.Value.Values, In_Tree => In_Tree); + elsif Attribute.Name = Name_Map_File_Option then + Data.Config.Map_File_Option := Attribute.Value.Value; end if; end if; @@ -2555,7 +2564,7 @@ package body Prj.Nmsc is -- Compute the object path name - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator and then Name_Buffer (Name_Len) /= '/' @@ -2578,7 +2587,7 @@ package body Prj.Nmsc is -- Compute the dependency path name - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator and then Name_Buffer (Name_Len) /= '/' @@ -2848,7 +2857,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Str (" interface: "); - Write_Line (Get_Name_String (Src_Data.Path)); + Write_Line (Get_Name_String (Src_Data.Path.Name)); end if; end if; @@ -3851,13 +3860,15 @@ package body Prj.Nmsc is Error_Msg_Name_2 := Proj_Data.Name; if Extends then - Error_Msg - (Project, In_Tree, - Continuation.all & - "library project %% cannot extend project %% " & - "that is not a library project", - Data.Location); - Continuation := Continuation_String'Access; + if Data.Library_Kind /= Static then + Error_Msg + (Project, In_Tree, + Continuation.all & + "shared library project %% cannot extend " & + "project %% that is not a library project", + Data.Location); + Continuation := Continuation_String'Access; + end if; elsif Data.Library_Kind /= Static then Error_Msg @@ -3940,8 +3951,6 @@ package body Prj.Nmsc is -- inherit library directory. Data.Library_Dir := Extended_Data.Library_Dir; - Data.Display_Library_Dir := - Extended_Data.Display_Library_Dir; Library_Directory_Present := True; end if; end if; @@ -3982,20 +3991,20 @@ package body Prj.Nmsc is else -- Find path name (unless inherited), check that it is a directory - if Data.Library_Dir = No_Path then + if Data.Library_Dir = No_Path_Information then Locate_Directory (Project, In_Tree, File_Name_Type (Lib_Dir.Value), - Data.Display_Directory, - Data.Library_Dir, - Data.Display_Library_Dir, + Data.Directory.Display_Name, + Data.Library_Dir.Name, + Data.Library_Dir.Display_Name, Create => "library", Current_Dir => Current_Dir, Location => Lib_Dir.Location); end if; - if Data.Library_Dir = No_Path then + if Data.Library_Dir = No_Path_Information then -- Get the absolute name of the library directory that -- does not exist, to report an error. @@ -4010,7 +4019,7 @@ package body Prj.Nmsc is File_Name_Type (Lib_Dir.Value); else - Get_Name_String (Data.Display_Directory); + Get_Name_String (Data.Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -4035,14 +4044,13 @@ package body Prj.Nmsc is -- The library directory cannot be the same as the Object -- directory. - elsif Data.Library_Dir = Data.Object_Directory then + elsif Data.Library_Dir.Name = Data.Object_Directory.Name then Error_Msg (Project, In_Tree, "library directory cannot be the same " & "as object directory", Lib_Dir.Location); - Data.Library_Dir := No_Path; - Data.Display_Library_Dir := No_Path; + Data.Library_Dir := No_Path_Information; else declare @@ -4059,7 +4067,9 @@ package body Prj.Nmsc is Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_Dir = Path_Name_Type (Dir_Elem.Value) then + if + Data.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) + then Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg @@ -4087,7 +4097,7 @@ package body Prj.Nmsc is In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_Dir = + if Data.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := @@ -4109,15 +4119,15 @@ package body Prj.Nmsc is end if; if not OK then - Data.Library_Dir := No_Path; - Data.Display_Library_Dir := No_Path; + Data.Library_Dir := No_Path_Information; elsif Current_Verbosity = High then -- Display the Library directory in high verbosity Write_Str ("Library directory ="""); - Write_Str (Get_Name_String (Data.Display_Library_Dir)); + Write_Str + (Get_Name_String (Data.Library_Dir.Display_Name)); Write_Line (""""); end if; end; @@ -4127,7 +4137,7 @@ package body Prj.Nmsc is end if; Data.Library := - Data.Library_Dir /= No_Path + Data.Library_Dir /= No_Path_Information and then Data.Library_Name /= No_Name; @@ -4176,7 +4186,6 @@ package body Prj.Nmsc is Write_Line ("No library ALI directory specified"); end if; Data.Library_ALI_Dir := Data.Library_Dir; - Data.Display_Library_ALI_Dir := Data.Display_Library_Dir; else -- Find path name, check that it is a directory @@ -4185,14 +4194,14 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Lib_ALI_Dir.Value), - Data.Display_Directory, - Data.Library_ALI_Dir, - Data.Display_Library_ALI_Dir, + Data.Directory.Display_Name, + Data.Library_ALI_Dir.Name, + Data.Library_ALI_Dir.Display_Name, Create => "library ALI", Current_Dir => Current_Dir, Location => Lib_ALI_Dir.Location); - if Data.Library_ALI_Dir = No_Path then + if Data.Library_ALI_Dir = No_Path_Information then -- Get the absolute name of the library ALI directory that -- does not exist, to report an error. @@ -4207,7 +4216,7 @@ package body Prj.Nmsc is File_Name_Type (Lib_Dir.Value); else - Get_Name_String (Data.Display_Directory); + Get_Name_String (Data.Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -4241,8 +4250,7 @@ package body Prj.Nmsc is "library 'A'L'I directory cannot be the same " & "as object directory", Lib_ALI_Dir.Location); - Data.Library_ALI_Dir := No_Path; - Data.Display_Library_ALI_Dir := No_Path; + Data.Library_ALI_Dir := No_Path_Information; else declare @@ -4259,7 +4267,7 @@ package body Prj.Nmsc is Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_ALI_Dir = + if Data.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := @@ -4293,7 +4301,7 @@ package body Prj.Nmsc is In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_ALI_Dir = + if Data.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := @@ -4316,8 +4324,7 @@ package body Prj.Nmsc is end if; if not OK then - Data.Library_ALI_Dir := No_Path; - Data.Display_Library_ALI_Dir := No_Path; + Data.Library_ALI_Dir := No_Path_Information; elsif Current_Verbosity = High then @@ -4326,7 +4333,8 @@ package body Prj.Nmsc is Write_Str ("Library ALI directory ="""); Write_Str - (Get_Name_String (Data.Display_Library_ALI_Dir)); + (Get_Name_String + (Data.Library_ALI_Dir.Display_Name)); Write_Line (""""); end if; end; @@ -4684,7 +4692,7 @@ package body Prj.Nmsc is Data.Other_Sources_Present := False; else - -- If the configuration file does not define a language either + -- Fail if there is no default language defined if Def_Lang.Default then if not Default_Language_Is_Ada then @@ -4699,8 +4707,6 @@ package body Prj.Nmsc is end if; else - -- ??? Are we supporting a single default language in the - -- configuration file ? Get_Name_String (Def_Lang.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Def_Lang_Id := Name_Find; @@ -5062,8 +5068,8 @@ package body Prj.Nmsc is In_Tree.Units.Table (The_Unit_Id); if The_Unit_Data.File_Names (Body_Part).Name /= No_File - and then The_Unit_Data.File_Names (Body_Part).Path /= - Slash + and then The_Unit_Data.File_Names + (Body_Part).Path.Name /= Slash then if Check_Project (The_Unit_Data.File_Names (Body_Part).Project, @@ -5083,7 +5089,7 @@ package body Prj.Nmsc is Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (The_Unit_Data.File_Names - (Body_Part).Path)); + (Body_Part).Path.Name)); if Sinput.P.Source_File_Is_Subunit (Src_Ind) @@ -5117,7 +5123,7 @@ package body Prj.Nmsc is elsif The_Unit_Data.File_Names (Specification).Name /= No_File and then The_Unit_Data.File_Names - (Specification).Path /= Slash + (Specification).Path.Name /= Slash and then Check_Project (The_Unit_Data.File_Names (Specification).Project, @@ -5200,8 +5206,7 @@ package body Prj.Nmsc is In_Tree.Sources.Table (Source).Other_Part /= No_Source then - Source := - In_Tree.Sources.Table (Source).Other_Part; + Source := In_Tree.Sources.Table (Source).Other_Part; end if; String_Element_Table.Increment_Last @@ -5292,16 +5297,16 @@ package body Prj.Nmsc is (Project, In_Tree, Dir_Id, - Data.Display_Directory, - Data.Library_Src_Dir, - Data.Display_Library_Src_Dir, + Data.Directory.Display_Name, + Data.Library_Src_Dir.Name, + Data.Library_Src_Dir.Display_Name, Create => "library source copy", Current_Dir => Current_Dir, Location => Lib_Src_Dir.Location); -- If directory does not exist, report an error - if Data.Library_Src_Dir = No_Path then + if Data.Library_Src_Dir = No_Path_Information then -- Get the absolute name of the library directory that does -- not exist, to report an error. @@ -5315,7 +5320,7 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := Dir_Id; else - Get_Name_String (Data.Directory); + Get_Name_String (Data.Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator @@ -5350,7 +5355,7 @@ package body Prj.Nmsc is "directory to copy interfaces cannot be " & "the object directory", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Path; + Data.Library_Src_Dir := No_Path_Information; else declare @@ -5367,7 +5372,7 @@ package body Prj.Nmsc is -- Report error if it is one of the source directories - if Data.Library_Src_Dir = + if Data.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg @@ -5375,14 +5380,14 @@ package body Prj.Nmsc is "directory to copy interfaces cannot " & "be one of the source directories", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Path; + Data.Library_Src_Dir := No_Path_Information; exit; end if; Src_Dirs := Src_Dir.Next; end loop; - if Data.Library_Src_Dir /= No_Path then + if Data.Library_Src_Dir /= No_Path_Information then -- It cannot be a source directory of any other -- project either. @@ -5399,7 +5404,7 @@ package body Prj.Nmsc is -- Report error if it is one of the source -- directories - if Data.Library_Src_Dir = + if Data.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg_File_1 := @@ -5412,7 +5417,7 @@ package body Prj.Nmsc is "be the same as source directory { of " & "project %%", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Path; + Data.Library_Src_Dir := No_Path_Information; exit Project_Loop; end if; @@ -5425,11 +5430,11 @@ package body Prj.Nmsc is -- In high verbosity, if there is a valid Library_Src_Dir, -- display its path name. - if Data.Library_Src_Dir /= No_Path + if Data.Library_Src_Dir /= No_Path_Information and then Current_Verbosity = High then Write_Str ("Directory to copy interfaces ="""); - Write_Str (Get_Name_String (Data.Library_Src_Dir)); + Write_Str (Get_Name_String (Data.Library_Src_Dir.Name)); Write_Line (""""); end if; end if; @@ -5554,7 +5559,8 @@ package body Prj.Nmsc is else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Name_Len := 0; - Add_Str_To_Name_Buffer (Get_Name_String (Data.Directory)); + Add_Str_To_Name_Buffer + (Get_Name_String (Data.Directory.Name)); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Get_Name_String (Lib_Ref_Symbol_File.Value)); @@ -5603,7 +5609,7 @@ package body Prj.Nmsc is Symb_Path : constant String := Normalize_Pathname (Get_Name_String - (Data.Object_Directory) & + (Data.Object_Directory.Name) & Directory_Separator & Name_Buffer (1 .. Name_Len), Directory => Current_Dir, @@ -6364,7 +6370,7 @@ package body Prj.Nmsc is Normalize_Pathname (Name => Get_Name_String (Base_Dir), Directory => - Get_Name_String (Data.Display_Directory), + Get_Name_String (Data.Directory.Display_Name), Resolve_Links => False, Case_Sensitive => True); @@ -6416,7 +6422,7 @@ package body Prj.Nmsc is (Project => Project, In_Tree => In_Tree, Name => From, - Parent => Data.Display_Directory, + Parent => Data.Directory.Display_Name, Dir => Path_Name, Display => Display_Path_Name, Current_Dir => Current_Dir); @@ -6551,7 +6557,6 @@ package body Prj.Nmsc is -- We set the object directory to its default Data.Object_Directory := Data.Directory; - Data.Display_Object_Dir := Data.Display_Directory; if Object_Dir.Value /= Empty_String then Get_Name_String (Object_Dir.Value); @@ -6569,14 +6574,14 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Object_Dir.Value), - Data.Display_Directory, - Data.Object_Directory, - Data.Display_Object_Dir, + Data.Directory.Display_Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, Create => "object", Location => Object_Dir.Location, Current_Dir => Current_Dir); - if Data.Object_Directory = No_Path then + if Data.Object_Directory = No_Path_Information then -- The object directory does not exist, report an error if the -- project is not externally built. @@ -6595,14 +6600,16 @@ package body Prj.Nmsc is -- tools that recover from errors; for example, these tools -- could create the non existent directory. - Data.Display_Object_Dir := Path_Name_Type (Object_Dir.Value); + Data.Object_Directory.Display_Name := + Path_Name_Type (Object_Dir.Value); if Osint.File_Names_Case_Sensitive then - Data.Object_Directory := Path_Name_Type (Object_Dir.Value); + Data.Object_Directory.Name := + Path_Name_Type (Object_Dir.Value); else Get_Name_String (Object_Dir.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Data.Object_Directory := Name_Find; + Data.Object_Directory.Name := Name_Find; end if; end if; end if; @@ -6614,20 +6621,20 @@ package body Prj.Nmsc is (Project, In_Tree, Name_Find, - Data.Display_Directory, - Data.Object_Directory, - Data.Display_Object_Dir, + Data.Directory.Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, Create => "object", Location => Object_Dir.Location, Current_Dir => Current_Dir); end if; if Current_Verbosity = High then - if Data.Object_Directory = No_Path then + if Data.Object_Directory = No_Path_Information then Write_Line ("No object directory"); else Write_Str ("Object directory: """); - Write_Str (Get_Name_String (Data.Display_Object_Dir)); + Write_Str (Get_Name_String (Data.Object_Directory.Display_Name)); Write_Line (""""); end if; end if; @@ -6640,7 +6647,6 @@ package body Prj.Nmsc is -- We set the object directory to its default Data.Exec_Directory := Data.Object_Directory; - Data.Display_Exec_Dir := Data.Display_Object_Dir; if Exec_Dir.Value /= Empty_String then Get_Name_String (Exec_Dir.Value); @@ -6658,14 +6664,14 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Exec_Dir.Value), - Data.Display_Directory, - Data.Exec_Directory, - Data.Display_Exec_Dir, + Data.Directory.Name, + Data.Exec_Directory.Name, + Data.Exec_Directory.Display_Name, Create => "exec", Location => Exec_Dir.Location, Current_Dir => Current_Dir); - if Data.Exec_Directory = No_Path then + if Data.Exec_Directory = No_Path_Information then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg (Project, In_Tree, @@ -6676,11 +6682,11 @@ package body Prj.Nmsc is end if; if Current_Verbosity = High then - if Data.Exec_Directory = No_Path then + if Data.Exec_Directory = No_Path_Information then Write_Line ("No exec directory"); else Write_Str ("Exec directory: """); - Write_Str (Get_Name_String (Data.Display_Exec_Dir)); + Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name)); Write_Line (""""); end if; end if; @@ -6709,7 +6715,7 @@ package body Prj.Nmsc is if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then - Data.Object_Directory := No_Path; + Data.Object_Directory := No_Path_Information; end if; elsif Source_Dirs.Default then @@ -6722,8 +6728,8 @@ package body Prj.Nmsc is Data.Source_Dirs := String_Element_Table.Last (In_Tree.String_Elements); In_Tree.String_Elements.Table (Data.Source_Dirs) := - (Value => Name_Id (Data.Directory), - Display_Value => Name_Id (Data.Display_Directory), + (Value => Name_Id (Data.Directory.Name), + Display_Value => Name_Id (Data.Directory.Display_Name), Location => No_Location, Flag => False, Next => Nil_String, @@ -6732,7 +6738,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Line ("Single source directory:"); Write_Str (" """); - Write_Str (Get_Name_String (Data.Display_Directory)); + Write_Str (Get_Name_String (Data.Directory.Display_Name)); Write_Line (""""); end if; @@ -6753,7 +6759,7 @@ package body Prj.Nmsc is if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then - Data.Object_Directory := No_Path; + Data.Object_Directory := No_Path_Information; end if; Data.Source_Dirs := Nil_String; @@ -6846,7 +6852,7 @@ package body Prj.Nmsc is -- inherit the Mains from the project we are extending. if Mains.Default then - if Data.Extends /= No_Project then + if not Data.Library and then Data.Extends /= No_Project then Data.Mains := In_Tree.Projects.Table (Data.Extends).Mains; end if; @@ -7529,7 +7535,7 @@ package body Prj.Nmsc is Path_Name_Of (File_Name_Type (Excluded_Source_List_File.Value), - Data.Directory); + Data.Directory.Name); begin if Source_File_Path_Name'Length = 0 then @@ -7669,7 +7675,7 @@ package body Prj.Nmsc is if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then - Data.Object_Directory := No_Path; + Data.Object_Directory := No_Path_Information; end if; end if; end if; @@ -7762,7 +7768,7 @@ package body Prj.Nmsc is declare Source_File_Path_Name : constant String := Path_Name_Of - (File_Name_Type (Source_List_File.Value), Data.Directory); + (File_Name_Type (Source_List_File.Value), Data.Directory.Name); begin if Source_File_Path_Name'Length = 0 then @@ -7828,7 +7834,7 @@ package body Prj.Nmsc is -- Check if all exceptions have been found. -- For Ada, it is an error if an exception is not found. - -- For other language, the source is removed. + -- For other language, the source is simply removed. declare Source : Source_Id; @@ -7840,7 +7846,7 @@ package body Prj.Nmsc is Src_Data := In_Tree.Sources.Table (Source); if Src_Data.Naming_Exception - and then Src_Data.Path = No_Path + and then Src_Data.Path = No_Path_Information then if Src_Data.Unit /= No_Name then Error_Msg_Name_1 := Name_Id (Src_Data.Display_File); @@ -7849,11 +7855,9 @@ package body Prj.Nmsc is (Project, In_Tree, "source file %% for unit %% not found", No_Location); - - else - Remove_Source - (Source, No_Source, Project, Data, In_Tree); end if; + + Remove_Source (Source, No_Source, Project, Data, In_Tree); end if; Source := Src_Data.Next_In_Project; @@ -8518,9 +8522,8 @@ package body Prj.Nmsc is Check_Name := True; else - In_Tree.Sources.Table (Name_Loc.Source).Path := Path_Id; - In_Tree.Sources.Table - (Name_Loc.Source).Display_Path := Display_Path_Id; + In_Tree.Sources.Table (Name_Loc.Source).Path := + (Path_Id, Display_Path_Id); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, @@ -8583,13 +8586,21 @@ package body Prj.Nmsc is if Unit /= No_Name and then Src_Data.Unit = Unit - and then Src_Data.Kind /= Kind + and then + ((Src_Data.Kind = Spec and then Kind = Impl) + or else + (Src_Data.Kind = Impl and then Kind = Spec)) then Other_Part := Source; elsif (Unit /= No_Name and then Src_Data.Unit = Unit - and then Src_Data.Kind = Kind) + and then + (Src_Data.Kind = Kind + or else + (Src_Data.Kind = Sep and then Kind = Impl) + or else + (Src_Data.Kind = Impl and then Kind = Sep))) or else (Unit = No_Name and then Src_Data.File = File_Name) then -- Duplication of file/unit in same project is only @@ -8640,7 +8651,7 @@ package body Prj.Nmsc is Error_Msg_Name_1 := In_Tree.Projects.Table (Src_Data.Project).Name; - Error_Msg_Name_2 := Name_Id (Src_Data.Display_Path); + Error_Msg_Name_2 := Name_Id (Src_Data.Path.Display_Name); Error_Msg (Project, In_Tree, "\ project %%, %%", No_Location); @@ -8857,7 +8868,7 @@ package body Prj.Nmsc is if Extended = Project or else Project_Extends (Project, Extended, In_Tree) then - Unit.File_Names (Kind).Path := Slash; + Unit.File_Names (Kind).Path.Name := Slash; Unit.File_Names (Kind).Needs_Pragma := False; In_Tree.Units.Table (Index) := Unit; Add_Forbidden_File_Name @@ -9068,6 +9079,8 @@ package body Prj.Nmsc is Find_Explicit_Sources (Ada_Language_Index, Current_Dir, Project, In_Tree, Data); + -- Mark as such the sources that are declared as excluded + FF := Excluded_Sources_Htable.Get_First; while FF /= No_File_Found loop OK := False; @@ -9103,6 +9116,98 @@ package body Prj.Nmsc is FF := Excluded_Sources_Htable.Get_Next; end loop; + + -- Check that two sources of this project do not have the same object + -- file name. + + Check_Object_File_Names : declare + Src_Id : Source_Id; + Src_Data : Source_Data; + Source_Name : File_Name_Type; + + procedure Check_Object; + -- Check if object file name of the current source is already in + -- hash table Object_File_Names. If it is, report an error. If it + -- is not, put it there with the file name of the current source. + + ------------------ + -- Check_Object -- + ------------------ + + procedure Check_Object is + begin + Source_Name := Object_File_Names.Get (Src_Data.Object); + + if Source_Name /= No_File then + Error_Msg_File_1 := Src_Data.File; + Error_Msg_File_2 := Source_Name; + Error_Msg + (Project, + In_Tree, + "{ and { have the same object file name", + No_Location); + + else + Object_File_Names.Set (Src_Data.Object, Src_Data.File); + end if; + end Check_Object; + + -- Start of processing for Check_Object_File_Names + + begin + Object_File_Names.Reset; + Src_Id := In_Tree.First_Source; + while Src_Id /= No_Source loop + Src_Data := In_Tree.Sources.Table (Src_Id); + + if Src_Data.Compiled and then Src_Data.Object_Exists + and then Project_Extends (Project, Src_Data.Project, In_Tree) + then + if Src_Data.Unit = No_Name then + if Src_Data.Kind = Impl then + Check_Object; + end if; + + else + case Src_Data.Kind is + when Spec => + if Src_Data.Other_Part = No_Source then + Check_Object; + end if; + + when Sep => + null; + + when Impl => + if Src_Data.Other_Part /= No_Source then + Check_Object; + + else + -- Check if it is a subunit + + declare + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Src_Data.Path.Name)); + + begin + if Sinput.P.Source_File_Is_Subunit + (Src_Ind) + then + In_Tree.Sources.Table (Src_Id).Kind := Sep; + else + Check_Object; + end if; + end; + end if; + end case; + end if; + end if; + + Src_Id := Src_Data.Next_In_Sources; + end loop; + end Check_Object_File_Names; end Process_Sources_In_Multi_Language_Mode; -- Start of processing for Look_For_Sources @@ -9138,15 +9243,15 @@ package body Prj.Nmsc is (File_Name : File_Name_Type; Directory : Path_Name_Type) return String is - Result : String_Access; - + Result : String_Access; The_Directory : constant String := Get_Name_String (Directory); begin Get_Name_String (File_Name); - Result := Locate_Regular_File - (File_Name => Name_Buffer (1 .. Name_Len), - Path => The_Directory); + Result := + Locate_Regular_File + (File_Name => Name_Buffer (1 .. Name_Len), + Path => The_Directory); if Result = null then return ""; @@ -9385,14 +9490,17 @@ package body Prj.Nmsc is if (The_Unit_Data.File_Names (Unit_Kind).Name = Canonical_File_Name and then - The_Unit_Data.File_Names (Unit_Kind).Path = Slash) + The_Unit_Data.File_Names + (Unit_Kind).Path.Name = Slash) or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File or else Project_Extends (Data.Extends, The_Unit_Data.File_Names (Unit_Kind).Project, In_Tree) then - if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then + if + The_Unit_Data.File_Names (Unit_Kind).Path.Name = Slash + then Remove_Forbidden_File_Name (The_Unit_Data.File_Names (Unit_Kind).Name); end if; @@ -9409,8 +9517,7 @@ package body Prj.Nmsc is (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, - Path => Canonical_Path_Name, - Display_Path => Path_Name, + Path => (Canonical_Path_Name, Path_Name), Project => Project, Needs_Pragma => Needs_Pragma); In_Tree.Units.Table (The_Unit) := The_Unit_Data; @@ -9419,8 +9526,8 @@ package body Prj.Nmsc is elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project and then (Data.Known_Order_Of_Source_Dirs or else - The_Unit_Data.File_Names (Unit_Kind).Path = - Canonical_Path_Name) + The_Unit_Data.File_Names + (Unit_Kind).Path.Name = Canonical_Path_Name) then if Previous_Source = Nil_String then Data.Ada_Sources := Nil_String; @@ -9452,7 +9559,7 @@ package body Prj.Nmsc is (The_Unit_Data.File_Names (Unit_Kind).Project).Name; Err_Vars.Error_Msg_File_1 := File_Name_Type - (The_Unit_Data.File_Names (Unit_Kind).Path); + (The_Unit_Data.File_Names (Unit_Kind).Path.Name); Error_Msg (Project, In_Tree, "\ project file %%, {", The_Location); @@ -9502,8 +9609,7 @@ package body Prj.Nmsc is (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, - Path => Canonical_Path_Name, - Display_Path => Path_Name, + Path => (Canonical_Path_Name, Path_Name), Project => Project, Needs_Pragma => Needs_Pragma); In_Tree.Units.Table (The_Unit) := The_Unit_Data; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index ab9208f9e94..67c913378dd 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -39,6 +39,8 @@ with Table; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with System.HTable; use System.HTable; package body Prj.Part is @@ -1864,15 +1866,65 @@ package body Prj.Part is ------------------- function Try_Path_Name (Path : String) return String_Access is + Prj_Path : constant String := Project_Path; + First : Natural; + Last : Natural; + Result : String_Access := null; + begin if Current_Verbosity = High then Write_Str (" Trying "); Write_Line (Path); end if; - return Locate_Regular_File - (File_Name => Path, - Path => Project_Path); + if Is_Absolute_Path (Path) then + if Is_Regular_File (Path) then + Result := new String'(Path); + end if; + + else + -- Because we don't want to resolve symbolic links, we cannot use + -- Locate_Regular_File. So, we try each possible path + -- successively. + + First := Prj_Path'First; + while First <= Prj_Path'Last loop + while First <= Prj_Path'Last + and then Prj_Path (First) = Path_Separator + loop + First := First + 1; + end loop; + + exit when First > Prj_Path'Last; + + Last := First; + while Last < Prj_Path'Last + and then Prj_Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + Name_Len := 0; + + if not Is_Absolute_Path (Prj_Path (First .. Last)) then + Add_Str_To_Name_Buffer (Get_Current_Dir); + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Prj_Path (First .. Last)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Path); + + if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then + Result := new String'(Name_Buffer (1 .. Name_Len)); + exit; + end if; + + First := Last + 1; + end loop; + end if; + + return Result; end Try_Path_Name; -- Local Declarations diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 13f1d947804..67ae8ba85f0 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -2315,13 +2315,13 @@ package body Prj.Proc is declare Object_Dir : constant Path_Name_Type := In_Tree.Projects.Table - (Project).Object_Directory; + (Project).Object_Directory.Name; begin for Index in Project_Table.First .. Project_Table.Last (In_Tree.Projects) loop if In_Tree.Projects.Table (Index).Virtual then - In_Tree.Projects.Table (Index).Object_Directory := + In_Tree.Projects.Table (Index).Object_Directory.Name := Object_Dir; end if; end loop; @@ -2338,7 +2338,7 @@ package body Prj.Proc is Extending := In_Tree.Projects.Table (Proj).Extended_By; if Extending /= No_Project then - Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory; + Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory.Name; -- Check that a project being extended does not share its -- object directory with any project that extends it, directly @@ -2351,8 +2351,8 @@ package body Prj.Proc is if In_Tree.Projects.Table (Extending2).Ada_Sources /= Nil_String and then - In_Tree.Projects.Table (Extending2).Object_Directory = - Obj_Dir + In_Tree.Projects.Table + (Extending2).Object_Directory.Name = Obj_Dir then if In_Tree.Projects.Table (Extending2).Virtual then Error_Msg_Name_1 := @@ -2562,20 +2562,20 @@ package body Prj.Proc is Processed_Data.Display_Name := Name_Find; end if; - Processed_Data.Display_Path_Name := + Processed_Data.Path.Display_Name := Path_Name_Of (From_Project_Node, From_Project_Node_Tree); - Get_Name_String (Processed_Data.Display_Path_Name); + Get_Name_String (Processed_Data.Path.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Processed_Data.Path_Name := Name_Find; + Processed_Data.Path.Name := Name_Find; Processed_Data.Location := Location_Of (From_Project_Node, From_Project_Node_Tree); - Processed_Data.Display_Directory := + Processed_Data.Directory.Display_Name := Directory_Of (From_Project_Node, From_Project_Node_Tree); - Get_Name_String (Processed_Data.Display_Directory); + Get_Name_String (Processed_Data.Directory.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Processed_Data.Directory := Name_Find; + Processed_Data.Directory.Name := Name_Find; Processed_Data.Extended_By := Extended_By; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0435509988e..d838b114442 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -95,21 +95,16 @@ package body Prj is First_Referred_By => No_Project, Name => No_Name, Display_Name => No_Name, - Path_Name => No_Path, - Display_Path_Name => No_Path, + Path => No_Path_Information, Virtual => False, Location => No_Location, Mains => Nil_String, - Directory => No_Path, - Display_Directory => No_Path, + Directory => No_Path_Information, Dir_Path => null, Library => False, - Library_Dir => No_Path, - Display_Library_Dir => No_Path, - Library_Src_Dir => No_Path, - Display_Library_Src_Dir => No_Path, - Library_ALI_Dir => No_Path, - Display_Library_ALI_Dir => No_Path, + Library_Dir => No_Path_Information, + Library_Src_Dir => No_Path_Information, + Library_ALI_Dir => No_Path_Information, Library_Name => No_Name, Library_Kind => Static, Lib_Internal_Name => No_Name, @@ -131,11 +126,9 @@ package body Prj is Include_Language => No_Language_Index, Source_Dirs => Nil_String, Known_Order_Of_Source_Dirs => True, - Object_Directory => No_Path, - Display_Object_Dir => No_Path, + Object_Directory => No_Path_Information, Library_TS => Empty_Time_Stamp, - Exec_Directory => No_Path, - Display_Exec_Dir => No_Path, + Exec_Directory => No_Path_Information, Extends => No_Project, Extended_By => No_Project, Naming => Std_Naming_Data, diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 4c2af09c85c..5d8caa79cd3 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -150,6 +150,13 @@ package Prj is function Empty_String return Name_Id; -- Return the id for an empty string "" + type Path_Information is record + Name : Path_Name_Type := No_Path; + Display_Name : Path_Name_Type := No_Path; + end record; + + No_Path_Information : constant Path_Information := (No_Path, No_Path); + type Project_Id is new Nat; No_Project : constant Project_Id := 0; -- Id of a Project File @@ -672,11 +679,8 @@ package Prj is Display_File : File_Name_Type := No_File; -- File name of the source, for display purposes - Path : Path_Name_Type := No_Path; - -- Canonical path name of the source - - Display_Path : Path_Name_Type := No_Path; - -- Path name of the source, for display purposes + Path : Path_Information := No_Path_Information; + -- Path name of the source Source_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Time stamp of the source file @@ -756,8 +760,7 @@ package Prj is Replaced_By => No_Source, File => No_File, Display_File => No_File, - Path => No_Path, - Display_Path => No_Path, + Path => No_Path_Information, Source_TS => Empty_Time_Stamp, Object_Project => No_Project, Object_Exists => True, @@ -1125,104 +1128,106 @@ package Prj is -- The table that contains the lists of project files type Project_Configuration is record - Run_Path_Option : Name_List_Index := No_Name_List; - -- The option to use when linking to specify the path where to look - -- for libraries. + Run_Path_Option : Name_List_Index := No_Name_List; + -- The option to use when linking to specify the path where to look for + -- libraries. - Executable_Suffix : Name_Id := No_Name; - -- The suffix of executables, when specified in the configuration - -- or in package Builder of the main project. When this is not - -- specified, the executable suffix is the default for the platform. + Executable_Suffix : Name_Id := No_Name; + -- The suffix of executables, when specified in the configuration or in + -- package Builder of the main project. When this is not specified, the + -- executable suffix is the default for the platform. - -- Linking + -- Linking - Linker : Path_Name_Type := No_Path; - -- Path name of the linker driver. Specified in the configuration - -- or in the package Builder of the main project. + Linker : Path_Name_Type := No_Path; + -- Path name of the linker driver. Specified in the configuration or in + -- the package Builder of the main project. - Minimum_Linker_Options : Name_List_Index := No_Name_List; - -- The minimum options for the linker driver. Specified in the - -- configuration. + Map_File_Option : Name_Id := No_Name; + -- Option to use when invoking the linker to build a map file - Linker_Executable_Option : Name_List_Index := No_Name_List; - -- The option(s) to indicate the name of the executable in the - -- linker command. Specified in the configuration. When not - -- specified, default to -o <executable name>. + Minimum_Linker_Options : Name_List_Index := No_Name_List; + -- The minimum options for the linker driver. Specified in the + -- configuration. - Linker_Lib_Dir_Option : Name_Id := No_Name; - -- The option to specify where to find a library for linking. - -- Specified in the configuration. When not specified, defaults to - -- "-L". + Linker_Executable_Option : Name_List_Index := No_Name_List; + -- The option(s) to indicate the name of the executable in the linker + -- command. Specified in the configuration. When not specified, default + -- to -o <executable name>. - Linker_Lib_Name_Option : Name_Id := No_Name; - -- The option to specify the name of a library for linking. Specified - -- in the configuration. When not specified, defaults to "-l". + Linker_Lib_Dir_Option : Name_Id := No_Name; + -- The option to specify where to find a library for linking. Specified + -- in the configuration. When not specified, defaults to "-L". - -- Libraries + Linker_Lib_Name_Option : Name_Id := No_Name; + -- The option to specify the name of a library for linking. Specified in + -- the configuration. When not specified, defaults to "-l". - Library_Builder : Path_Name_Type := No_Path; - -- The executable to build library (specified in the configuration) + -- Libraries - Lib_Support : Library_Support := None; - -- The level of library support. Specified in the configuration. - -- Support is none, static libraries only or both static and shared - -- libraries. + Library_Builder : Path_Name_Type := No_Path; + -- The executable to build library (specified in the configuration) - -- Archives + Lib_Support : Library_Support := None; + -- The level of library support. Specified in the configuration. Support + -- is none, static libraries only or both static and shared libraries. - Archive_Builder : Name_List_Index := No_Name_List; - -- The name of the executable to build archives, with the minimum - -- switches. Specified in the configuration. + Archive_Builder : Name_List_Index := No_Name_List; + -- The name of the executable to build archives, with the minimum + -- switches. Specified in the configuration. - Archive_Builder_Append_Option : Name_List_Index := No_Name_List; - -- The options to append object files to an archive + Archive_Builder_Append_Option : Name_List_Index := No_Name_List; + -- The options to append object files to an archive - Archive_Indexer : Name_List_Index := No_Name_List; - -- The name of the executable to index archives, with the minimum - -- switches. Specified in the configuration. + Archive_Indexer : Name_List_Index := No_Name_List; + -- The name of the executable to index archives, with the minimum + -- switches. Specified in the configuration. - Archive_Suffix : File_Name_Type := No_File; - -- The suffix of archives. Specified in the configuration. When not - -- specified, defaults to ".a". + Archive_Suffix : File_Name_Type := No_File; + -- The suffix of archives. Specified in the configuration. When not + -- specified, defaults to ".a". - Lib_Partial_Linker : Name_List_Index := No_Name_List; + Lib_Partial_Linker : Name_List_Index := No_Name_List; - -- Shared libraries + -- Shared libraries - Shared_Lib_Driver : File_Name_Type := No_File; - -- The driver to link shared libraries. Set with attribute - -- Library_GCC. Default to gcc. + Shared_Lib_Driver : File_Name_Type := No_File; + -- The driver to link shared libraries. Set with attribute Library_GCC. + -- Default to gcc. - Shared_Lib_Prefix : File_Name_Type := No_File; - -- Part of a shared library file name that precedes the name of the - -- library. Specified in the configuration. When not specified, - -- defaults to "lib". + Shared_Lib_Prefix : File_Name_Type := No_File; + -- Part of a shared library file name that precedes the name of the + -- library. Specified in the configuration. When not specified, defaults + -- to "lib". - Shared_Lib_Suffix : File_Name_Type := No_File; - -- Suffix of shared libraries, after the library name in the shared - -- library name. Specified in the configuration. When not specified, - -- default to ".so". + Shared_Lib_Suffix : File_Name_Type := No_File; + -- Suffix of shared libraries, after the library name in the shared + -- library name. Specified in the configuration. When not specified, + -- default to ".so". - Shared_Lib_Min_Options : Name_List_Index := No_Name_List; - -- Comment ??? + Shared_Lib_Min_Options : Name_List_Index := No_Name_List; + -- The minimum options to use when building a shared library - Lib_Version_Options : Name_List_Index := No_Name_List; - -- Comment ??? + Lib_Version_Options : Name_List_Index := No_Name_List; + -- The options to use to specify a library version - Symbolic_Link_Supported : Boolean := False; - -- Comment ??? + Symbolic_Link_Supported : Boolean := False; + -- True if the platform supports symbolic link files - Lib_Maj_Min_Id_Supported : Boolean := False; - -- Comment ??? + Lib_Maj_Min_Id_Supported : Boolean := False; + -- True if platform supports library major and minor options, such as + -- libname.so -> libname.so.2 -> libname.so.2.4 - Auto_Init_Supported : Boolean := False; - -- Comment ??? + Auto_Init_Supported : Boolean := False; + -- True if automatic initialisation is supported for shared stand-alone + -- libraries. end record; Default_Project_Config : constant Project_Configuration := (Run_Path_Option => No_Name_List, Executable_Suffix => No_Name, Linker => No_Path, + Map_File_Option => No_Name, Minimum_Linker_Options => No_Name_List, Linker_Executable_Option => No_Name_List, Linker_Lib_Dir_Option => No_Name, @@ -1250,6 +1255,17 @@ package Prj is -- separator. type Project_Data is record + + ------------- + -- General -- + ------------- + + Name : Name_Id := No_Name; + -- The name of the project + + Display_Name : Name_Id := No_Name; + -- The name of the project with the spelling of its declaration + Qualifier : Project_Qualifier := Unspecified; -- The eventual qualifier for this project @@ -1257,90 +1273,115 @@ package Prj is -- True if the project is externally built. In such case, the Project -- Manager will not modify anything in this project. + Config : Project_Configuration; + + Path : Path_Information := No_Path_Information; + -- The path name of the project file + + Virtual : Boolean := False; + -- True for virtual extending projects + + Location : Source_Ptr := No_Location; + -- The location in the project file source of the reserved word project + + Naming : Naming_Data := Standard_Naming_Data; + -- The naming scheme of this project file + + --------------- + -- Languages -- + --------------- + Languages : Name_List_Index := No_Name_List; -- The list of languages of the sources of this project - Config : Project_Configuration; + Include_Language : Language_Index := No_Language_Index; + + First_Language_Processing : Language_Index := No_Language_Index; + -- First index of the language data in the project + + Unit_Based_Language_Name : Name_Id := No_Name; + Unit_Based_Language_Index : Language_Index := No_Language_Index; + -- The name and index, if any, of the unit-based language of some + -- sources of the project. There may be only one unit-based language + -- in one project. + + -------------- + -- Projects -- + -------------- First_Referred_By : Project_Id := No_Project; -- The project, if any, that was the first to be known as importing or -- extending this project - Name : Name_Id := No_Name; - -- The name of the project + Mains : String_List_Id := Nil_String; + -- List of mains specified by attribute Main - Display_Name : Name_Id := No_Name; - -- The name of the project with the spelling of its declaration + Extends : Project_Id := No_Project; + -- The reference of the project file, if any, that this project file + -- extends. - Path_Name : Path_Name_Type := No_Path; - -- The path name of the project file + Extended_By : Project_Id := No_Project; + -- The reference of the project file, if any, that extends this project + -- file. - Display_Path_Name : Path_Name_Type := No_Path; - -- The path name used for display purposes. May be different from - -- Path_Name for platforms where the file names are case-insensitive. + Decl : Declarations := No_Declarations; + -- The declarations (variables, attributes and packages) of this project + -- file. - Virtual : Boolean := False; - -- True for virtual extending projects + Imported_Projects : Project_List := Empty_Project_List; + -- The list of all directly imported projects, if any - Location : Source_Ptr := No_Location; - -- The location in the project file source of the reserved word project + All_Imported_Projects : Project_List := Empty_Project_List; + -- The list of all projects imported directly or indirectly, if any - Mains : String_List_Id := Nil_String; - -- List of mains specified by attribute Main + ----------------- + -- Directories -- + ----------------- - Directory : Path_Name_Type := No_Path; + Directory : Path_Information := No_Path_Information; -- Path name of the directory where the project file resides - Display_Directory : Path_Name_Type := No_Path; - -- The path name of the project directory, for display purposes. May be - -- different from Directory for platforms where the file names are - -- case-insensitive. - Dir_Path : String_Access; - -- Same as Directory, but as an access to String + -- Same as Directory.Name, but as an access to String + + Object_Directory : Path_Information := No_Path_Information; + -- The path name of the object directory of this project file + + Exec_Directory : Path_Information := No_Path_Information; + -- The path name of the exec directory of this project file. Default is + -- equal to Object_Directory. + + ------------- + -- Library -- + ------------- - Library_Dir : Path_Name_Type := No_Path; + Library : Boolean := False; + -- True if this is a library project + + Library_Name : Name_Id := No_Name; + -- If a library project, name of the library + + Library_Kind : Lib_Kind := Static; + -- If a library project, kind of library + + Library_Dir : Path_Information := No_Path_Information; -- If a library project, path name of the directory where the library -- resides. - Display_Library_Dir : Path_Name_Type := No_Path; - -- The path name of the library directory, for display purposes. May be - -- different from Library_Dir for platforms where the file names are - -- case-insensitive. - Library_TS : Time_Stamp_Type := Empty_Time_Stamp; -- The timestamp of a library file in a library project - Library_Src_Dir : Path_Name_Type := No_Path; + Library_Src_Dir : Path_Information := No_Path_Information; -- If a Stand-Alone Library project, path name of the directory where -- the sources of the interfaces of the library are copied. By default, -- if attribute Library_Src_Dir is not specified, sources of the -- interfaces are not copied anywhere. - Display_Library_Src_Dir : Path_Name_Type := No_Path; - -- The path name of the library source directory, for display purposes. - -- May be different from Library_Src_Dir for platforms where the file - -- names are case-insensitive. - - Library_ALI_Dir : Path_Name_Type := No_Path; + Library_ALI_Dir : Path_Information := No_Path_Information; -- In a library project, path name of the directory where the ALI files -- are copied. If attribute Library_ALI_Dir is not specified, ALI files -- are copied in the Library_Dir. - Display_Library_ALI_Dir : Path_Name_Type := No_Path; - -- The path name of the library ALI directory, for display purposes. May - -- be different from Library_ALI_Dir for platforms where the file names - -- are case-insensitive. - - Library : Boolean := False; - -- True if this is a library project - - Library_Name : Name_Id := No_Name; - -- If a library project, name of the library - - Library_Kind : Lib_Kind := Static; - -- If a library project, kind of library - Lib_Internal_Name : Name_Id := No_Name; -- If a library project, internal name store inside the library @@ -1355,12 +1396,17 @@ package Prj is -- For non static Stand-Alone Library Project Files, indicate if -- the library initialisation should be automatic. - Libgnarl_Needed : Yes_No_Unknown := Unknown; - -- Set to True when libgnarl is needed to link - Symbol_Data : Symbol_Record := No_Symbols; -- Symbol file name, reference symbol file name, symbol policy + Need_To_Build_Lib : Boolean := False; + -- Indicates that the library of a Library Project needs to be built or + -- rebuilt. + + ------------- + -- Sources -- + ------------- + Ada_Sources : String_List_Id := Nil_String; -- The list of all the Ada source file names (gnatmake only) @@ -1375,19 +1421,15 @@ package Prj is -- True if attribute Interfaces is declared for the project or any -- project it extends. - Unit_Based_Language_Name : Name_Id := No_Name; - Unit_Based_Language_Index : Language_Index := No_Language_Index; - -- The name and index, if any, of the unit-based language of some - -- sources of the project. There may be only one unit-based language - -- in one project. - Imported_Directories_Switches : Argument_List_Access := null; -- List of the source search switches (-I<source dir>) to be used when -- compiling. Include_Path : String_Access := null; - -- Value of the environment variable to indicate the source search path, - -- instead of a list of switches (Imported_Directories_Switches). + -- The search source path for the project. Used as the value for an + -- environment variable, specified by attribute Include_Path + -- (<language>). The names of the environment variables are in component + -- Include_Path of the records Language_Config. Include_Path_File : Path_Name_Type := No_Path; -- The path name of the of the source search directory file @@ -1395,8 +1437,6 @@ package Prj is Include_Data_Set : Boolean := False; -- Set True when Imported_Directories_Switches or Include_Path are set - Include_Language : Language_Index := No_Language_Index; - Source_Dirs : String_List_Id := Nil_String; -- The list of all the source directories @@ -1405,57 +1445,38 @@ package Prj is -- the ordering of the source subdirs depend on the OS. If True, -- duplicate file names in the same project file are allowed. - Object_Directory : Path_Name_Type := No_Path; - -- The path name of the object directory of this project file - - Display_Object_Dir : Path_Name_Type := No_Path; - -- The path name of the object directory, for display purposes. May be - -- different from Object_Directory for platforms where the file names - -- are case-insensitive. - - Exec_Directory : Path_Name_Type := No_Path; - -- The path name of the exec directory of this project file. Default is - -- equal to Object_Directory. - - Display_Exec_Dir : Path_Name_Type := No_Path; - -- The path name of the exec directory, for display purposes. May be - -- different from Exec_Directory for platforms where the file names are - -- case-insensitive. - - Extends : Project_Id := No_Project; - -- The reference of the project file, if any, that this project file - -- extends. - - Extended_By : Project_Id := No_Project; - -- The reference of the project file, if any, that extends this project - -- file. - - Naming : Naming_Data := Standard_Naming_Data; - -- The naming scheme of this project file + Ada_Include_Path : String_Access := null; + -- The cached value of source search path for this project file. Set by + -- the first call to Prj.Env.Ada_Include_Path for the project. Do not + -- use this field directly outside of the project manager, use + -- Prj.Env.Ada_Include_Path instead. - First_Language_Processing : Language_Index := No_Language_Index; - -- First index of the language data in the project + ------------- + -- Linking -- + ------------- - Decl : Declarations := No_Declarations; - -- The declarations (variables, attributes and packages) of this project - -- file. + Linker_Name : File_Name_Type := No_File; + -- Value of attribute Language_Processing'Linker in the project file - Imported_Projects : Project_List := Empty_Project_List; - -- The list of all directly imported projects, if any + Linker_Path : Path_Name_Type := No_Path; + -- Path of linker when attribute Language_Processing'Linker is specified - All_Imported_Projects : Project_List := Empty_Project_List; - -- The list of all projects imported directly or indirectly, if any + Minimum_Linker_Options : Name_List_Index := No_Name_List; + -- List of options specified in attribute + -- Language_Processing'Minimum_Linker_Options. - Ada_Include_Path : String_Access := null; - -- The cached value of ADA_INCLUDE_PATH for this project file. Do not - -- use this field directly outside of the compiler, use - -- Prj.Env.Ada_Include_Path instead. + ------------------- + -- Miscellaneous -- + ------------------- Ada_Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file. Do not -- use this field directly outside of the compiler, use -- Prj.Env.Ada_Objects_Path instead. + Libgnarl_Needed : Yes_No_Unknown := Unknown; + -- Set to True when libgnarl is needed to link + Objects_Path : String_Access := null; -- The cached value of the object dir path, used during the binding -- phase of gprbuild. @@ -1475,16 +1496,6 @@ package Prj is -- An indication that the configuration pragmas file is a temporary file -- that must be deleted at the end. - Linker_Name : File_Name_Type := No_File; - -- Value of attribute Language_Processing'Linker in the project file - - Linker_Path : Path_Name_Type := No_Path; - -- Path of linker when attribute Language_Processing'Linker is specified - - Minimum_Linker_Options : Name_List_Index := No_Name_List; - -- List of options specified in attribute - -- Language_Processing'Minimum_Linker_Options. - Config_Checked : Boolean := False; -- A flag to avoid checking repetitively the configuration pragmas file @@ -1496,10 +1507,6 @@ package Prj is -- A flag to mark a project as "visited" to avoid processing the same -- project several time. - Need_To_Build_Lib : Boolean := False; - -- Indicates that the library of a Library Project needs to be built or - -- rebuilt. - Depth : Natural := 0; -- The maximum depth of a project in the project graph. Depth of main -- project is 0. @@ -1573,13 +1580,12 @@ package Prj is type Spec_Or_Body is (Specification, Body_Part); type File_Name_Data is record - Name : File_Name_Type := No_File; - Index : Int := 0; - Display_Name : File_Name_Type := No_File; - Path : Path_Name_Type := No_Path; - Display_Path : Path_Name_Type := No_Path; - Project : Project_Id := No_Project; - Needs_Pragma : Boolean := False; + Name : File_Name_Type := No_File; + Index : Int := 0; + Display_Name : File_Name_Type := No_File; + Path : Path_Information := No_Path_Information; + Project : Project_Id := No_Project; + Needs_Pragma : Boolean := False; end record; -- File and Path name of a spec or body diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 650e2eaad3f..a0efccc3f06 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -959,7 +959,9 @@ package body Rtsfind is if Get_PCS_Name = Name_No_DSA then Check_RPC_Failure ("distribution feature not supported"); - elsif Get_PCS_Version /= Exp_Dist.PCS_Version_Number then + elsif Get_PCS_Version /= + Exp_Dist.PCS_Version_Number (Get_PCS_Name) + then Check_RPC_Failure ("PCS version mismatch"); end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 2c16961c009..76110c036ef 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1078,6 +1078,7 @@ package Rtsfind is RE_DSA_Implementation, -- System.Partition_Interface RE_PCS_Version, -- System.Partition_Interface + RE_Get_RACW, -- System.Partition_Interface RE_Get_RCI_Package_Receiver, -- System.Partition_Interface RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface RE_RACW_Stub_Type_Access, -- System.Partition_Interface @@ -1451,6 +1452,9 @@ package Rtsfind is RE_Mul_G, -- System.Vax_Float_Operations RE_Neg_F, -- System.Vax_Float_Operations RE_Neg_G, -- System.Vax_Float_Operations + RE_Return_D, -- System.Vax_Float_Operations + RE_Return_F, -- System.Vax_Float_Operations + RE_Return_G, -- System.Vax_Float_Operations RE_Sub_F, -- System.Vax_Float_Operations RE_Sub_G, -- System.Vax_Float_Operations @@ -2209,6 +2213,7 @@ package Rtsfind is RE_DSA_Implementation => System_Partition_Interface, RE_PCS_Version => System_Partition_Interface, + RE_Get_RACW => System_Partition_Interface, RE_Get_RCI_Package_Receiver => System_Partition_Interface, RE_Get_Unique_Remote_Pointer => System_Partition_Interface, RE_RACW_Stub_Type_Access => System_Partition_Interface, @@ -2582,6 +2587,9 @@ package Rtsfind is RE_Mul_G => System_Vax_Float_Operations, RE_Neg_F => System_Vax_Float_Operations, RE_Neg_G => System_Vax_Float_Operations, + RE_Return_D => System_Vax_Float_Operations, + RE_Return_F => System_Vax_Float_Operations, + RE_Return_G => System_Vax_Float_Operations, RE_Sub_F => System_Vax_Float_Operations, RE_Sub_G => System_Vax_Float_Operations, diff --git a/gcc/ada/s-casi16.adb b/gcc/ada/s-casi16.adb index 3980ce7d74f..846ec8dff00 100644 --- a/gcc/ada/s-casi16.adb +++ b/gcc/ada/s-casi16.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -44,10 +44,7 @@ package body System.Compare_Array_Signed_16 is for Half'Size use 16; -- Used to process operands by half words - type Uhalf is record - H : Half; - end record; - pragma Pack (Uhalf); + type Uhalf is new Half; for Uhalf'Alignment use 1; -- Used to process operands when unaligned @@ -110,8 +107,8 @@ package body System.Compare_Array_Signed_16 is else while Clen /= 0 loop - if U (L).H /= U (R).H then - if U (L).H > U (R).H then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-casi32.adb b/gcc/ada/s-casi32.adb index 7ce89da47d7..7076918491c 100644 --- a/gcc/ada/s-casi32.adb +++ b/gcc/ada/s-casi32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,10 +41,7 @@ package body System.Compare_Array_Signed_32 is for Word'Size use 32; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -93,8 +90,8 @@ package body System.Compare_Array_Signed_32 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-casi64.adb b/gcc/ada/s-casi64.adb index 0cbae743b1a..0bf9745d375 100644 --- a/gcc/ada/s-casi64.adb +++ b/gcc/ada/s-casi64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,10 +41,7 @@ package body System.Compare_Array_Signed_64 is for Word'Size use 64; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -93,8 +90,8 @@ package body System.Compare_Array_Signed_64 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-caun16.adb b/gcc/ada/s-caun16.adb index 9bbbb968c83..b75d8bb9be3 100644 --- a/gcc/ada/s-caun16.adb +++ b/gcc/ada/s-caun16.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -44,10 +44,7 @@ package body System.Compare_Array_Unsigned_16 is for Half'Size use 16; -- Used to process operands by half words - type Uhalf is record - H : Half; - end record; - pragma Pack (Uhalf); + type Uhalf is new Half; for Uhalf'Alignment use 1; -- Used to process operands when unaligned @@ -110,8 +107,8 @@ package body System.Compare_Array_Unsigned_16 is else while Clen /= 0 loop - if U (L).H /= U (R).H then - if U (L).H > U (R).H then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-caun32.adb b/gcc/ada/s-caun32.adb index c0289395214..a7dcd8f086d 100644 --- a/gcc/ada/s-caun32.adb +++ b/gcc/ada/s-caun32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,10 +41,7 @@ package body System.Compare_Array_Unsigned_32 is for Word'Size use 32; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -93,8 +90,8 @@ package body System.Compare_Array_Unsigned_32 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-caun64.adb b/gcc/ada/s-caun64.adb index 10ff8176496..28d2c15bce6 100644 --- a/gcc/ada/s-caun64.adb +++ b/gcc/ada/s-caun64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,10 +40,7 @@ package body System.Compare_Array_Unsigned_64 is type Word is mod 2 ** 64; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -92,8 +89,8 @@ package body System.Compare_Array_Unsigned_64 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb index d7d94957c0b..c764a1c658e 100644 --- a/gcc/ada/s-direio.adb +++ b/gcc/ada/s-direio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -251,15 +251,23 @@ package body System.Direct_IO is ----------- procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is + pragma Unmodified (File); + -- File is actually modified via Unrestricted_Access below, but + -- GNAT will generate a warning anyway. + begin - FIO.Reset (AP (File), Mode); + FIO.Reset (AP (File)'Unrestricted_Access, Mode); File.Index := 1; File.Last_Op := Op_Read; end Reset; procedure Reset (File : in out File_Type) is + pragma Unmodified (File); + -- File is actually modified via Unrestricted_Access below, but + -- GNAT will generate a warning anyway. + begin - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Index := 1; File.Last_Op := Op_Read; end Reset; diff --git a/gcc/ada/s-direio.ads b/gcc/ada/s-direio.ads index a43ebb67fc7..3e32c982d42 100644 --- a/gcc/ada/s-direio.ads +++ b/gcc/ada/s-direio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -111,7 +111,6 @@ package System.Direct_IO is Size : Interfaces.C_Streams.size_t); procedure Reset (File : in out File_Type; Mode : FCB.File_Mode); - procedure Reset (File : in out File_Type); procedure Set_Index (File : File_Type; To : Positive_Count); @@ -125,4 +124,21 @@ package System.Direct_IO is Zeroes : System.Storage_Elements.Storage_Array); -- Note: Zeroes is the buffer of zeroes used to fill out partial records + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, FCB.File_Mode), + Mechanism => (File => Reference)); + end System.Direct_IO; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index f34e68ab696..bfe7d6b0cc5 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -206,9 +206,10 @@ package body System.File_IO is -- Close -- ----------- - procedure Close (File : in out AFCB_Ptr) is + procedure Close (File_Ptr : access AFCB_Ptr) is Close_Status : int := 0; Dup_Strm : Boolean := False; + File : AFCB_Ptr renames File_Ptr.all; begin -- Take a task lock, to protect the global data value Open_Files @@ -296,7 +297,8 @@ package body System.File_IO is -- Delete -- ------------ - procedure Delete (File : in out AFCB_Ptr) is + procedure Delete (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; begin Check_File_Open (File); @@ -308,7 +310,7 @@ package body System.File_IO is Filename : aliased constant String := File.Name.all; begin - Close (File); + 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 @@ -354,7 +356,7 @@ package body System.File_IO is procedure Finalize (V : in out File_IO_Clean_Up_Type) is pragma Warnings (Off, V); - Fptr1 : AFCB_Ptr; + Fptr1 : aliased AFCB_Ptr; Fptr2 : AFCB_Ptr; Discard : int; @@ -371,7 +373,7 @@ package body System.File_IO is Fptr1 := Open_Files; while Fptr1 /= null loop Fptr2 := Fptr1.Next; - Close (Fptr1); + Close (Fptr1'Access); Fptr1 := Fptr2; end loop; @@ -1058,17 +1060,19 @@ package body System.File_IO is -- The reset which does not change the mode simply does a rewind - procedure Reset (File : in out AFCB_Ptr) is + procedure Reset (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; begin Check_File_Open (File); - Reset (File, File.Mode); + 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) - procedure Reset (File : in out AFCB_Ptr; Mode : File_Mode) is + procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is + File : AFCB_Ptr renames File_Ptr.all; Fopstr : aliased Fopen_String; begin @@ -1106,7 +1110,7 @@ package body System.File_IO is (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding); if File.Stream = NULL_Stream then - Close (File); + Close (File_Ptr); raise Use_Error; else diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads index 6cd787104d1..f69c580856b 100644 --- a/gcc/ada/s-fileio.ads +++ b/gcc/ada/s-fileio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -100,20 +100,23 @@ package System.File_IO is -- this allocated file control block. If the open/create fails, then the -- fields of File are undefined, and File_Ptr is unchanged. - procedure Close (File : in out FCB.AFCB_Ptr); + procedure Close (File_Ptr : access FCB.AFCB_Ptr); -- The file is closed, all storage associated with it is released, and -- File is set to null. Note that this routine calls AFCB_Close to perform -- any specialized close actions, then closes the file at the system level, -- then frees the mode and form strings, and finally calls AFCB_Free to - -- free the file control block itself, setting File to null. + -- free the file control block itself, setting File.all to null. Note that + -- for this assignment to be done in all cases, including those where + -- an exception is raised, we can't use an IN OUT parameter (which would + -- not be copied back in case of abnormal return). - procedure Delete (File : in out FCB.AFCB_Ptr); + procedure Delete (File_Ptr : access FCB.AFCB_Ptr); -- The indicated file is unlinked - procedure Reset (File : in out FCB.AFCB_Ptr; Mode : FCB.File_Mode); + procedure Reset (File_Ptr : access FCB.AFCB_Ptr; Mode : FCB.File_Mode); -- The file is reset, and the mode changed as indicated - procedure Reset (File : in out FCB.AFCB_Ptr); + procedure Reset (File_Ptr : access FCB.AFCB_Ptr); -- The files is reset, and the mode is unchanged function Mode (File : FCB.AFCB_Ptr) return FCB.File_Mode; diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb index 6eb8a0ca6ef..07668da318e 100644 --- a/gcc/ada/s-stausa.adb +++ b/gcc/ada/s-stausa.adb @@ -205,10 +205,10 @@ package body System.Stack_Usage is Result_Array := new Result_Array_Type (1 .. Buffer_Size); Result_Array.all := (others => - (Task_Name => (others => ASCII.NUL), - Measure => 0, - Max_Size => 0, - Overflow_Guard => 0)); + (Task_Name => (others => ASCII.NUL), + Min_Measure => 0, + Max_Measure => 0, + Max_Size => 0)); -- Set the Is_Enabled flag to true, so that the task wrapper knows that -- it has to handle dynamic stack analysis @@ -233,7 +233,7 @@ package body System.Stack_Usage is (Environment_Task_Analyzer, "ENVIRONMENT TASK", Stack_Size, - 0, + Stack_Size, System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address)); Fill_Stack (Environment_Task_Analyzer); @@ -253,32 +253,49 @@ package body System.Stack_Usage is ---------------- procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is - -- Change the local variables and parameters of this function with -- super-extra care. The more the stack frame size of this function is -- big, the more an "instrumentation threshold at writing" error is -- likely to happen. - Stack : aliased Stack_Slots (1 .. Analyzer.Size / Bytes_Per_Pattern); + Current_Stack_Level : aliased Integer; begin - Stack := (others => Analyzer.Pattern); + -- Reajust the pattern size. When we arrive in this function, there is + -- already a given amount of stack used, that we won't analyze. + + Analyzer.Stack_Used_When_Filling := + Stack_Size + (Analyzer.Bottom_Of_Stack, + To_Stack_Address (Current_Stack_Level'Address)) + + Natural (Current_Stack_Level'Size); + + Analyzer.Pattern_Size := + Analyzer.Pattern_Size - Analyzer.Stack_Used_When_Filling; + + declare + Stack : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + + begin + Stack := (others => Analyzer.Pattern); - Analyzer.Stack_Overlay_Address := Stack'Address; + Analyzer.Stack_Overlay_Address := Stack'Address; - Analyzer.Bottom_Pattern_Mark := - To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); - Analyzer.Top_Pattern_Mark := - To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); + Analyzer.Top_Pattern_Mark := + To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); - -- If Arr has been packed, the following assertion must be true (we add - -- the size of the element whose address is: - -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): + -- If Arr has been packed, the following assertion must be true (we + -- add the size of the element whose address is: + -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): - pragma Assert - (Analyzer.Size = - Stack_Size - (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); + pragma Assert + (Analyzer.Pattern_Size = + Stack_Size + (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); + end; end Fill_Stack; ------------------------- @@ -286,25 +303,25 @@ package body System.Stack_Usage is ------------------------- procedure Initialize_Analyzer - (Analyzer : in out Stack_Analyzer; - Task_Name : String; - Size : Natural; - Overflow_Guard : Natural; - Bottom : Stack_Address; - Pattern : Unsigned_32 := 16#DEAD_BEEF#) + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Pattern : Unsigned_32 := 16#DEAD_BEEF#) is begin -- Initialize the analyzer fields Analyzer.Bottom_Of_Stack := Bottom; - Analyzer.Size := Size; + Analyzer.Stack_Size := Stack_Size; + Analyzer.Pattern_Size := Max_Pattern_Size; Analyzer.Pattern := Pattern; Analyzer.Result_Id := Next_Id; Analyzer.Task_Name := (others => ' '); - -- Compute the task name, and truncate it if it's bigger than - -- Task_Name_Length + -- Compute the task name, and truncate if bigger than Task_Name_Length if Task_Name'Length <= Task_Name_Length then Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name; @@ -314,8 +331,6 @@ package body System.Stack_Usage is Task_Name'First + Task_Name_Length - 1); end if; - Analyzer.Overflow_Guard := Overflow_Guard; - Next_Id := Next_Id + 1; end Initialize_Analyzer; @@ -346,7 +361,7 @@ package body System.Stack_Usage is -- is, the more an "instrumentation threshold at reading" error is -- likely to happen. - Stack : Stack_Slots (1 .. Analyzer.Size / Bytes_Per_Pattern); + Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); for Stack'Address use Analyzer.Stack_Overlay_Address; begin @@ -382,10 +397,8 @@ package body System.Stack_Usage is --------------------- function Get_Usage_Range (Result : Task_Result) return String is - Min_Used_Str : constant String := - Natural'Image (Result.Measure); - Max_Used_Str : constant String := - Natural'Image (Result.Measure + Result.Overflow_Guard); + Min_Used_Str : constant String := Natural'Image (Result.Min_Measure); + Max_Used_Str : constant String := Natural'Image (Result.Max_Measure); begin return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -" & Max_Used_Str & "]"; @@ -458,8 +471,8 @@ package body System.Stack_Usage is for J in Result_Array'Range loop exit when J >= Next_Id; - if Result_Array (J).Measure - > Result_Array (Max_Actual_Use_Result_Id).Measure + if Result_Array (J).Max_Measure + > Result_Array (Max_Actual_Use_Result_Id).Max_Measure then Max_Actual_Use_Result_Id := J; end if; @@ -526,15 +539,18 @@ package body System.Stack_Usage is ------------------- procedure Report_Result (Analyzer : Stack_Analyzer) is - Result : constant Task_Result := - (Task_Name => Analyzer.Task_Name, - Max_Size => Analyzer.Size + Analyzer.Overflow_Guard, - Measure => Stack_Size - (Analyzer.Topmost_Touched_Mark, - Analyzer.Bottom_Of_Stack), - Overflow_Guard => Analyzer.Overflow_Guard - - Natural (Analyzer.Bottom_Of_Stack - - Analyzer.Bottom_Pattern_Mark)); + Measure : constant Natural := + Stack_Size + (Analyzer.Topmost_Touched_Mark, + Analyzer.Bottom_Of_Stack) + + Analyzer.Stack_Used_When_Filling; + + Result : constant Task_Result := + (Task_Name => Analyzer.Task_Name, + Max_Size => Analyzer.Stack_Size, + Min_Measure => Measure, + Max_Measure => Measure + Analyzer.Stack_Size + - Analyzer.Pattern_Size); begin if Analyzer.Result_Id in Result_Array'Range then @@ -550,7 +566,7 @@ package body System.Stack_Usage is Result_Str_Len : constant Natural := Get_Usage_Range (Result)'Length; Size_Str_Len : constant Natural := - Natural'Image (Analyzer.Size)'Length; + Natural'Image (Analyzer.Stack_Size)'Length; Max_Stack_Size_Len : Natural; Max_Actual_Use_Len : Natural; diff --git a/gcc/ada/s-stausa.ads b/gcc/ada/s-stausa.ads index b309c3735e8..7c500bffaec 100644 --- a/gcc/ada/s-stausa.ads +++ b/gcc/ada/s-stausa.ads @@ -41,10 +41,6 @@ package System.Stack_Usage is package SSE renames System.Storage_Elements; - -- The alignment clause seems dubious, what about architectures where - -- the maximum alignment is less than 4??? - -- Anyway, why not use Interfaces.Unsigned_32??? - subtype Stack_Address is SSE.Integer_Address; -- Address on the stack @@ -53,9 +49,8 @@ package System.Stack_Usage is renames System.Storage_Elements.To_Integer; type Stack_Analyzer is private; - -- Type of the stack analyzer tool. It is used to fill a portion of - -- the stack with Pattern, and to compute the stack used after some - -- execution. + -- Type of the stack analyzer tool. It is used to fill a portion of the + -- stack with Pattern, and to compute the stack used after some execution. -- Usage: @@ -90,9 +85,9 @@ package System.Stack_Usage is -- Errors: -- -- We are instrumenting the code to measure the stack used by the user - -- code. This method has a number of systematic errors, but several - -- methods can be used to evaluate or reduce those errors. Here are - -- those errors and the strategy that we use to deal with them: + -- code. This method has a number of systematic errors, but several methods + -- can be used to evaluate or reduce those errors. Here are those errors + -- and the strategy that we use to deal with them: -- Bottom offset: @@ -164,8 +159,8 @@ package System.Stack_Usage is -- Description: The pattern zone does not fit on the stack. This may -- lead to an erroneous execution. - -- Strategy: Specify a storage size that is bigger than the size of the - -- pattern. 2 times bigger should be enough. + -- Strategy: Specify a storage size that is bigger than the size of the + -- pattern. 2 times bigger should be enough. -- Augmentation of the user stack frames: @@ -211,15 +206,18 @@ package System.Stack_Usage is -- Analyzer.Top_Pattern_Mark procedure Initialize_Analyzer - (Analyzer : in out Stack_Analyzer; - Task_Name : String; - Size : Natural; - Overflow_Guard : Natural; - Bottom : Stack_Address; - Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); -- Should be called before any use of a Stack_Analyzer, to initialize it. - -- Size is the size of the pattern zone. Bottom should be a close - -- approximation of the caller base frame address. + -- Max_Pattern_Size is the size of the pattern zone, might be smaller than + -- the full stack size in order to take into account e.g. the secondary + -- stack and a guard against overflow. The actual size taken will be + -- reajusted with data already used at the time the stack is actually + -- filled. Is_Enabled : Boolean := False; -- When this flag is true, then stack analysis is enabled @@ -274,7 +272,10 @@ private Task_Name : String (1 .. Task_Name_Length); -- Name of the task - Size : Natural; + Stack_Size : Natural; + -- Entire size of the analyzed stack + + Pattern_Size : Natural; -- Size of the pattern zone Pattern : Pattern_Type; @@ -304,9 +305,9 @@ private -- Id of the result. If less than value given to gnatbind -u corresponds -- to the location in the result array of result for the current task. - Overflow_Guard : Natural; - -- The amount of bytes that won't be analyzed in order to prevent - -- writing out of the stack + Stack_Used_When_Filling : Natural := 0; + -- Amount of stack that was already used when actually filling the + -- memory, and therefore not analyzed. end record; Environment_Task_Analyzer : Stack_Analyzer; @@ -314,10 +315,16 @@ private Compute_Environment_Task : Boolean; type Task_Result is record - Task_Name : String (1 .. Task_Name_Length); - Measure : Natural; - Max_Size : Natural; - Overflow_Guard : Natural; + Task_Name : String (1 .. Task_Name_Length); + + Min_Measure : Natural; + -- Minimum value for the measure + + Max_Measure : Natural; + -- Maximum value for the measure, taking into account the actual size + -- of the pattern filled. + + Max_Size : Natural; end record; type Result_Array_Type is array (Positive range <>) of Task_Result; diff --git a/gcc/ada/s-tasinf-mingw.adb b/gcc/ada/s-tasinf-mingw.adb index 33b9c739853..644192b0a94 100644 --- a/gcc/ada/s-tasinf-mingw.adb +++ b/gcc/ada/s-tasinf-mingw.adb @@ -33,6 +33,12 @@ -- This is the Windows (native) version of this module +with System.OS_Interface; +pragma Unreferenced (System.OS_Interface); +-- System.OS_Interface is not used today, but the protocol between the +-- run-time and the binder is that any tasking application uses +-- System.OS_Interface, so notify the binder with this "with" clause. + package body System.Task_Info is N_CPU : Natural := 0; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 09d9070cd4e..d28cb7e42d2 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -1065,8 +1065,6 @@ package body System.Tasking.Stages is Overflow_Guard := Big_Overflow_Guard; end if; - Size := Size - Overflow_Guard; - if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address; @@ -1078,14 +1076,18 @@ package body System.Tasking.Stages is Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; end if; + Size := Size - Overflow_Guard; + if System.Stack_Usage.Is_Enabled then STPO.Lock_RTS; - Initialize_Analyzer (Self_ID.Common.Analyzer, - Self_ID.Common.Task_Image - (1 .. Self_ID.Common.Task_Image_Len), - Size, - Overflow_Guard, - SSE.To_Integer (Bottom_Of_Stack'Address)); + Initialize_Analyzer + (Self_ID.Common.Analyzer, + Self_ID.Common.Task_Image + (1 .. Self_ID.Common.Task_Image_Len), + Natural + (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), + Size, + SSE.To_Integer (Bottom_Of_Stack'Address)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); end if; diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index e7d561bed16..d00ca1dba85 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- @@ -32,7 +32,7 @@ -- -- ------------------------------------------------------------------------------ -with System.IO; use System.IO; +with System.IO; with System.Machine_Code; use System.Machine_Code; package body System.Vax_Float_Operations is @@ -328,7 +328,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_D (Arg : D) is begin - Put (D'Image (Arg)); + System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- @@ -337,7 +337,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_F (Arg : F) is begin - Put (F'Image (Arg)); + System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- @@ -346,7 +346,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_G (Arg : G) is begin - Put (G'Image (Arg)); + System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- @@ -627,7 +627,7 @@ package body System.Vax_Float_Operations is procedure pd (Arg : D) is begin - Put_Line (D'Image (Arg)); + System.IO.Put_Line (D'Image (Arg)); end pd; -------- @@ -636,7 +636,7 @@ package body System.Vax_Float_Operations is procedure pf (Arg : F) is begin - Put_Line (F'Image (Arg)); + System.IO.Put_Line (F'Image (Arg)); end pf; -------- @@ -645,9 +645,58 @@ package body System.Vax_Float_Operations is procedure pg (Arg : G) is begin - Put_Line (G'Image (Arg)); + System.IO.Put_Line (G'Image (Arg)); end pg; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + R : D; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", + Volatile => True); + Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); + return R; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + R : F; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + R : G; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_G; + ----------- -- Sub_F -- ----------- diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb index 0741664082b..79e295f94c1 100644 --- a/gcc/ada/s-vaflop.adb +++ b/gcc/ada/s-vaflop.adb @@ -37,7 +37,7 @@ -- case where the -gnatdm switch is used to force testing of VMS features -- on non-VMS systems. -with System.IO; use System.IO; +with System.IO; package body System.Vax_Float_Operations is pragma Warnings (Off); @@ -94,7 +94,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_D (Arg : D) is begin - Put (D'Image (Arg)); + System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- @@ -103,7 +103,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_F (Arg : F) is begin - Put (F'Image (Arg)); + System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- @@ -112,7 +112,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_G (Arg : G) is begin - Put (G'Image (Arg)); + System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- @@ -352,7 +352,7 @@ package body System.Vax_Float_Operations is procedure pd (Arg : D) is begin - Put_Line (D'Image (Arg)); + System.IO.Put_Line (D'Image (Arg)); end pd; -------- @@ -361,7 +361,7 @@ package body System.Vax_Float_Operations is procedure pf (Arg : F) is begin - Put_Line (F'Image (Arg)); + System.IO.Put_Line (F'Image (Arg)); end pf; -------- @@ -370,7 +370,7 @@ package body System.Vax_Float_Operations is procedure pg (Arg : G) is begin - Put_Line (G'Image (Arg)); + System.IO.Put_Line (G'Image (Arg)); end pg; ------------ @@ -400,6 +400,33 @@ package body System.Vax_Float_Operations is return F (X); end S_To_F; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + begin + return X; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + begin + return X; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + begin + return X; + end Return_G; + ----------- -- Sub_F -- ----------- diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads index 47e991a3b33..caf1dcc4e9c 100644 --- a/gcc/ada/s-vaflop.ads +++ b/gcc/ada/s-vaflop.ads @@ -143,6 +143,20 @@ package System.Vax_Float_Operations is function Ne_G (X, Y : G) return Boolean; -- Compares for X /= Y + ---------------------- + -- Return Functions -- + ---------------------- + + function Return_D (X : D) return D; + function Return_F (X : F) return F; + function Return_G (X : G) return G; + -- Deal with returned value for an imported function where the function + -- result is of VAX Float type. Usually nothing needs to be done, and these + -- functions return their argument unchanged. But for the case of VMS Alpha + -- the return value is already in $f0, so we need to trick the compiler + -- into thinking that we are moving X to $f0. See bodies for this case + -- for the Asm sequence generated to achieve this. + ---------------------------------- -- Routines for Valid Attribute -- ---------------------------------- @@ -190,43 +204,46 @@ package System.Vax_Float_Operations is -- types, and are retained for backwards compatibility. private - pragma Inline (D_To_G); - pragma Inline (F_To_G); - pragma Inline (F_To_Q); - pragma Inline (F_To_S); - pragma Inline (G_To_D); - pragma Inline (G_To_F); - pragma Inline (G_To_Q); - pragma Inline (G_To_T); - pragma Inline (Q_To_F); - pragma Inline (Q_To_G); - pragma Inline (S_To_F); - pragma Inline (T_To_G); - - pragma Inline (Abs_F); - pragma Inline (Abs_G); - pragma Inline (Add_F); - pragma Inline (Add_G); - pragma Inline (Div_G); - pragma Inline (Div_F); - pragma Inline (Mul_F); - pragma Inline (Mul_G); - pragma Inline (Neg_G); - pragma Inline (Neg_F); - pragma Inline (Sub_F); - pragma Inline (Sub_G); - - pragma Inline (Eq_F); - pragma Inline (Eq_G); - pragma Inline (Le_F); - pragma Inline (Le_G); - pragma Inline (Lt_F); - pragma Inline (Lt_G); - pragma Inline (Ne_F); - pragma Inline (Ne_G); - - pragma Inline (Valid_D); - pragma Inline (Valid_F); - pragma Inline (Valid_G); + pragma Inline_Always (D_To_G); + pragma Inline_Always (F_To_G); + pragma Inline_Always (F_To_Q); + pragma Inline_Always (F_To_S); + pragma Inline_Always (G_To_D); + pragma Inline_Always (G_To_F); + pragma Inline_Always (G_To_Q); + pragma Inline_Always (G_To_T); + pragma Inline_Always (Q_To_F); + pragma Inline_Always (Q_To_G); + pragma Inline_Always (S_To_F); + pragma Inline_Always (T_To_G); + + pragma Inline_Always (Abs_F); + pragma Inline_Always (Abs_G); + pragma Inline_Always (Add_F); + pragma Inline_Always (Add_G); + pragma Inline_Always (Div_G); + pragma Inline_Always (Div_F); + pragma Inline_Always (Mul_F); + pragma Inline_Always (Mul_G); + pragma Inline_Always (Neg_G); + pragma Inline_Always (Neg_F); + pragma Inline_Always (Return_D); + pragma Inline_Always (Return_F); + pragma Inline_Always (Return_G); + pragma Inline_Always (Sub_F); + pragma Inline_Always (Sub_G); + + pragma Inline_Always (Eq_F); + pragma Inline_Always (Eq_G); + pragma Inline_Always (Le_F); + pragma Inline_Always (Le_G); + pragma Inline_Always (Lt_F); + pragma Inline_Always (Lt_G); + pragma Inline_Always (Ne_F); + pragma Inline_Always (Ne_G); + + pragma Inline_Always (Valid_D); + pragma Inline_Always (Valid_F); + pragma Inline_Always (Valid_G); end System.Vax_Float_Operations; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0735740472f..0cb2ace755e 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5234,6 +5234,7 @@ package body Sem_Attr is -- subtype then get the type from the initial value. If the value has -- been expanded into assignments, there is no expression and the -- attribute reference remains dynamic. + -- We could do better here and retrieve the type ??? if Ekind (P_Entity) = E_Constant @@ -8090,27 +8091,61 @@ package body Sem_Attr is -- even if the array is packed and the slice itself is not -- addressable. Transform the prefix into an indexed component. + -- Note that the transformation is safe only if we know that + -- the slice is non-null. That is because a null slice can have + -- an out of bounds index value. + + -- Right now, gigi blows up if given 'Address on a slice as a + -- result of some incorrect freeze nodes generated by the front + -- end, and this covers up that bug in one case, but the bug is + -- likely still there in the cases not handled by this code ??? + + -- It's not clear what 'Address *should* return for a null + -- slice with out of bounds indexes, this might be worth an ARG + -- discussion ??? + + -- One approach would be to do a length check unconditionally, + -- and then do the transformation below unconditionally, but + -- analyze with checks off, avoiding the problem of the out of + -- bounds index. This approach would interpret the address of + -- an out of bounds null slice as being the address where the + -- array element would be if there was one, which is probably + -- as reasonable an interpretation as any ??? + declare Loc : constant Source_Ptr := Sloc (P); D : constant Node_Id := Discrete_Range (P); Lo : Node_Id; begin - if Is_Entity_Name (D) then + if Is_Entity_Name (D) + and then + Not_Null_Range + (Type_Low_Bound (Entity (D)), + Type_High_Bound (Entity (D))) + then Lo := Make_Attribute_Reference (Loc, Prefix => (New_Occurrence_Of (Entity (D), Loc)), Attribute_Name => Name_First); - else + + elsif Nkind (D) = N_Range + and then Not_Null_Range (Low_Bound (D), High_Bound (D)) + then Lo := Low_Bound (D); + + else + Lo := Empty; end if; - Rewrite (P, - Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Prefix (P)), - Expressions => New_List (Lo))); + if Present (Lo) then + Rewrite (P, + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Prefix (P)), + Expressions => New_List (Lo))); - Analyze_And_Resolve (P); + Analyze_And_Resolve (P); + end if; end; end if; end Address_Attribute; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a3f036ade25..4f618213fcd 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9850,7 +9850,6 @@ package body Sem_Ch3 is function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is D : Entity_Id; E : Elmt_Id; - G : Elmt_Id; begin -- The discriminant may be declared for the type, in which case we @@ -9880,14 +9879,15 @@ package body Sem_Ch3 is -- to one: one new discriminant can constrain several old ones. In -- that case, scan sequentially the stored_constraint, the list of -- discriminants of the parents, and the constraints. + -- Previous code checked for the present of the Stored_Constraint + -- list for the derived type, but did not use it at all. Should it + -- be present when the component is a discriminated task type? if Is_Derived_Type (Typ) - and then Present (Stored_Constraint (Typ)) and then Scope (Entity (Discrim)) = Etype (Typ) then D := First_Discriminant (Etype (Typ)); E := First_Elmt (Constraints); - G := First_Elmt (Stored_Constraint (Typ)); while Present (D) loop if D = Entity (Discrim) then return Node (E); @@ -9895,7 +9895,6 @@ package body Sem_Ch3 is Next_Discriminant (D); Next_Elmt (E); - Next_Elmt (G); end loop; end if; @@ -10186,7 +10185,9 @@ package body Sem_Ch3 is Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); end if; - Set_Etype (Def_Id, Any_Type); + -- Set Etype to the known type, to reduce chances of cascaded errors + + Set_Etype (Def_Id, E); Set_Error_Posted (Def_Id); end Fixup_Bad_Constraint; @@ -13052,7 +13053,7 @@ package body Sem_Ch3 is Prev_Par : Node_Id; procedure Tag_Mismatch; - -- Diagnose a tagged partial view whose full view is untagged; + -- Diagnose a tagged partial view whose full view is untagged. -- We post the message on the full view, with a reference to -- the previous partial view. The partial view can be private -- or incomplete, and these are handled in a different manner, @@ -13233,9 +13234,9 @@ package body Sem_Ch3 is end if; -- A prior untagged partial view can have an associated class-wide - -- type due to use of the class attribute, and in this case also the - -- full type is required to be tagged. This Ada95 usage is deprecated - -- in favor of incomplete tagged declarations but we check for it. + -- type due to use of the class attribute, and in this case the full + -- type must also be tagged. This Ada 95 usage is deprecated in favor + -- of incomplete tagged declarations, but we check for it. if Is_Type (Prev) and then (Is_Tagged_Type (Prev) @@ -16618,7 +16619,8 @@ package body Sem_Ch3 is -- view of the type. function Designates_T (Subt : Node_Id) return Boolean; - -- Check whether a node designates the enclosing record type + -- Check whether a node designates the enclosing record type, or 'Class + -- of that type function Mentions_T (Acc_Def : Node_Id) return Boolean; -- Check whether an access definition includes a reference to @@ -16636,13 +16638,25 @@ package body Sem_Ch3 is Inc_T : Entity_Id; H : Entity_Id; + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". + + Is_Tagged : constant Boolean := + (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition + and then + Present + (Record_Extension_Part (Type_Definition (Typ_Decl)))) + or else + (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition + and then Tagged_Present (Type_Definition (Typ_Decl))); + begin -- If there is a previous partial view, no need to create a new one -- If the partial view, given by Prev, is incomplete, If Prev is -- a private declaration, full declaration is flagged accordingly. if Prev /= Typ then - if Tagged_Present (Type_Definition (Typ_Decl)) then + if Is_Tagged then Make_Class_Wide_Type (Prev); Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); Set_Etype (Class_Wide_Type (Typ), Typ); @@ -16651,6 +16665,15 @@ package body Sem_Ch3 is return; elsif Has_Private_Declaration (Typ) then + + -- If we refer to T'Class inside T, and T is the completion of a + -- private type, then we need to make sure the class-wide type + -- exists. + + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; + return; -- If there was a previous anonymous access type, the incomplete @@ -16692,14 +16715,9 @@ package body Sem_Ch3 is Analyze (Decl); Set_Full_View (Inc_T, Typ); - if (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition - and then - Present - (Record_Extension_Part (Type_Definition (Typ_Decl)))) - or else Tagged_Present (Type_Definition (Typ_Decl)) - then + if Is_Tagged then -- Create a common class-wide type for both views, and set - -- the etype of the class-wide type to the full view. + -- the Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index a341069bf75..89b85fe2c23 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -171,6 +171,7 @@ package Sem_Ch3 is -- family declaration or a loop iteration. The index is given by an -- index declaration (a 'box'), or by a discrete range. The later can -- be the name of a discrete type, or a subtype indication. + -- -- Related_Nod is the node where the potential generated implicit types -- will be inserted. The 2 last parameters are used for creating the name. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 037ccf980da..f8bd8d49853 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1602,6 +1602,7 @@ package body Sem_Ch6 is elsif Nkind (Parent (N)) = N_Compilation_Unit then Freeze_Before (N, Spec_Id); end if; + else Spec_Id := Corresponding_Spec (N); end if; @@ -2459,18 +2460,17 @@ package body Sem_Ch6 is Push_Scope (Designator); Process_Formals (Formals, N); - -- Ada 2005 (AI-345): Allow the overriding of interface primitives - -- by subprograms which belong to a concurrent type implementing an - -- interface. Set the parameter type of each controlling formal to - -- the corresponding record type. + -- Ada 2005 (AI-345): If this is an overriding operation of an + -- inherited interface operation, and the controlling type is + -- a synchronized type, replace the type with its corresponding + -- record, to match the proper signature of an overriding operation. if Ada_Version >= Ada_05 then Formal := First_Formal (Designator); while Present (Formal) loop Formal_Typ := Etype (Formal); - if (Ekind (Formal_Typ) = E_Protected_Type - or else Ekind (Formal_Typ) = E_Task_Type) + if Is_Concurrent_Type (Formal_Typ) and then Present (Corresponding_Record_Type (Formal_Typ)) and then Present (Interfaces (Corresponding_Record_Type (Formal_Typ))) @@ -3142,7 +3142,18 @@ package body Sem_Ch6 is if Old_Type /= Standard_Void_Type and then New_Type /= Standard_Void_Type then - if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then + + -- If we are checking interface conformance we omit controlling + -- arguments and result, because we are only checking the conformance + -- of the remaining parameters. + + if Has_Controlling_Result (Old_Id) + and then Has_Controlling_Result (New_Id) + and then Skip_Controlling_Formals + then + null; + + elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then Conformance_Error ("\return type does not match!", New_Id); return; end if; @@ -4990,7 +5001,7 @@ package body Sem_Ch6 is -- can be called in a dispatching context and such calls must be -- handled like calls to a class-wide function. - if not Is_Constrained (Result_Subt) + if not Is_Constrained (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Discard := @@ -5774,13 +5785,16 @@ package body Sem_Ch6 is Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean is + Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + begin pragma Assert (Is_Subprogram (Iface_Prim) and then Is_Subprogram (Prim) and then Is_Dispatching_Operation (Iface_Prim) and then Is_Dispatching_Operation (Prim)); - pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) + pragma Assert (Is_Interface (Iface) or else (Present (Alias (Iface_Prim)) and then Is_Interface @@ -5791,48 +5805,40 @@ package body Sem_Ch6 is or else Ekind (Prim) /= Ekind (Iface_Prim) or else not Is_Dispatching_Operation (Prim) or else Scope (Prim) /= Scope (Tagged_Type) - or else No (Find_Dispatching_Type (Prim)) - or else Base_Type (Find_Dispatching_Type (Prim)) /= Tagged_Type + or else No (Typ) + or else Base_Type (Typ) /= Tagged_Type or else not Primitive_Names_Match (Iface_Prim, Prim) then return False; - -- Case of a procedure, or a function not returning an interface + -- Case of a procedure, or a function that does not have a controlling + -- result (I or access I). elsif Ekind (Iface_Prim) = E_Procedure or else Etype (Prim) = Etype (Iface_Prim) - or else not Is_Interface (Etype (Iface_Prim)) + or else not Has_Controlling_Result (Prim) then return Type_Conformant (Prim, Iface_Prim, Skip_Controlling_Formals => True); - -- Case of a function returning an interface - - elsif Implements_Interface (Etype (Prim), Etype (Iface_Prim)) then - declare - Ret_Typ : constant Entity_Id := Etype (Prim); - Is_Conformant : Boolean; - - begin - -- Temporarly set both entities returning exactly the same type to - -- be able to call Type_Conformant (because that routine has no - -- machinery to handle interfaces). - - Set_Etype (Prim, Etype (Iface_Prim)); + -- Case of a function returning an interface, or an access to one. + -- Check that the return types correspond. - Is_Conformant := + elsif Implements_Interface (Typ, Iface) then + if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) + /= + (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type) + then + return False; + else + return Type_Conformant (Prim, Iface_Prim, Skip_Controlling_Formals => True); + end if; - -- Restore proper decoration of returned type - - Set_Etype (Prim, Ret_Typ); - - return Is_Conformant; - end; + else + return False; end if; - - return False; end Is_Interface_Conformant; --------------------------------- diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 0be68edc9f3..211bdddb49e 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -64,7 +64,9 @@ package body Sem_Dist is procedure Add_Stub_Constructs (N : Node_Id) is U : constant Node_Id := Unit (N); Spec : Entity_Id := Empty; - Exp : Node_Id := U; -- Unit that will be expanded + + Exp : Node_Id := U; + -- Unit that will be expanded begin pragma Assert (Distribution_Stub_Mode /= No_Stubs); @@ -84,7 +86,6 @@ package body Sem_Dist is or else Is_Remote_Call_Interface (Spec)); if Distribution_Stub_Mode = Generate_Caller_Stub_Body then - if Is_Shared_Passive (Spec) then null; elsif Nkind (U) = N_Package_Body then @@ -95,7 +96,6 @@ package body Sem_Dist is end if; else - if Is_Shared_Passive (Spec) then Build_Passive_Partition_Stub (Exp); else @@ -186,7 +186,6 @@ package body Sem_Dist is if Parent_Name /= No_String then Start_String (Parent_Name); Store_String_Char (Get_Char_Code ('.')); - else Start_String; end if; @@ -242,15 +241,13 @@ package body Sem_Dist is Par : Node_Id; begin - if (Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement) + if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Nkind (Name (N)) in N_Has_Entity and then Is_Remote_Call_Interface (Entity (Name (N))) and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) and then Comes_From_Source (N) then Par := Parent (Entity (Name (N))); - while Present (Par) and then (Nkind (Par) /= N_Package_Specification or else Is_Wrapper_Package (Defining_Entity (Par))) @@ -294,9 +291,10 @@ package body Sem_Dist is ------------------------------------ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is - N : Node_Id := Parent (E); + N : Node_Id; begin + N := Parent (E); while Nkind (N) /= N_Package_Specification loop N := Parent (N); end loop; @@ -317,11 +315,10 @@ package body Sem_Dist is Typ : constant Entity_Id := Etype (N); begin - Ety := Entity (Prefix (N)); - -- In case prefix is not a library unit entity, get the entity -- of library unit. + Ety := Entity (Prefix (N)); while (Present (Scope (Ety)) and then Scope (Ety) /= Standard_Standard) and not Is_Child_Unit (Ety) @@ -363,7 +360,6 @@ package body Sem_Dist is else Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); - end if; -- Replace the attribute node by a conversion of the function call @@ -426,10 +422,11 @@ package body Sem_Dist is Tick_Access_Conv_Call := Make_Function_Call (Loc, - Name => New_Occurrence_Of (Attribute_Subp, Loc), + Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( - Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), New_Occurrence_Of (All_Calls_Remote_E, Loc))); @@ -527,8 +524,7 @@ package body Sem_Dist is Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Full_Obj_Type, + Defining_Identifier => Full_Obj_Type, Type_Definition => Make_Record_Definition (Loc, Abstract_Present => True, @@ -558,39 +554,33 @@ package body Sem_Dist is All_Present => True, Subtype_Indication => Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Obj_Type, Loc), - Attribute_Name => - Name_Class)))); + Prefix => New_Occurrence_Of (Obj_Type, Loc), + Attribute_Name => Name_Class)))); + Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); Set_Is_Remote_Types (RACW_Type, Is_RT); Subpkg_Decl := Make_Package_Declaration (Loc, Make_Package_Specification (Loc, - Defining_Unit_Name => - Subpkg, - Visible_Declarations => - Vis_Decls, - Private_Declarations => - Priv_Decls, - End_Label => - New_Occurrence_Of (Subpkg, Loc))); + Defining_Unit_Name => Subpkg, + Visible_Declarations => Vis_Decls, + Private_Declarations => Priv_Decls, + End_Label => New_Occurrence_Of (Subpkg, Loc))); + Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); Set_Is_Remote_Types (Subpkg, Is_RT); Insert_After_And_Analyze (N, Subpkg_Decl); -- Generate package body to receive RACW calling stubs - -- Note: Analyze_Declarations has an absolute requirement that - -- the declaration list be non-empty, so we provide a dummy null - -- statement here. + + -- Note: Analyze_Declarations has an absolute requirement that the + -- declaration list be non-empty, so provide dummy null statement here. Subpkg_Body := Make_Package_Body (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Subpkg)), - Declarations => New_List ( - Make_Null_Statement (Loc))); + Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), + Declarations => New_List (Make_Null_Statement (Loc))); Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); -- Many parts of the analyzer and expander expect @@ -612,10 +602,10 @@ package body Sem_Dist is Make_Defining_Identifier (Loc, Name_Ras), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => - False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RACW_Type, Loc))))))); + Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); @@ -656,7 +646,6 @@ package body Sem_Dist is end if; elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then - Params := Expressions (Deref_Subp_Call); if Present (Params) then @@ -681,13 +670,12 @@ package body Sem_Dist is if Ekind (Deref_Proc) = E_Function then Call_Node := Make_Function_Call (Loc, - Name => New_Occurrence_Of (Deref_Proc, Loc), + Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); - else Call_Node := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Deref_Proc, Loc), + Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); end if; @@ -711,8 +699,8 @@ package body Sem_Dist is and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) - and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement - or else Nkind (Parent (Parent (P))) = N_Indexed_Component) + and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, + N_Indexed_Component) and then Expander_Active then RAS_E_Dereference (P); @@ -788,17 +776,14 @@ package body Sem_Dist is -- We do not have to handle this case return False; - end if; Rewrite (N, Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Ras)), - Expression => - Make_Null (Loc))))); + Choices => New_List (Make_Identifier (Loc, Name_Ras)), + Expression => Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index c03f11ab0af..15c3df81dc5 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3388,7 +3388,7 @@ package body Sem_Eval is Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); - -- Set link to original named number, for ASIS use. + -- Set link to original named number, for ASIS use Set_Original_Entity (N, Ent); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9cc285f1100..f59e6415962 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6561,7 +6561,7 @@ package body Sem_Res is procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin -- Handle restriction against anonymous null access values This - -- restriction can be turned off using -gnatdh. + -- restriction can be turned off using -gnatdj. -- Ada 2005 (AI-231): Remove restriction @@ -6571,7 +6571,7 @@ package body Sem_Res is and then Comes_From_Source (N) then -- In the common case of a call which uses an explicitly null - -- value for an access parameter, give specialized error msg + -- value for an access parameter, give specialized error message. if Nkind_In (Parent (N), N_Procedure_Call_Statement, N_Function_Call) diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 84b24d26a4c..7d4cdddc479 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -767,6 +767,7 @@ package body Snames is "local_config_file#" & "local_configuration_pragmas#" & "locally_removed_files#" & + "map_file_option#" & "mapping_file_switches#" & "mapping_spec_suffix#" & "mapping_body_suffix#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 0b247e7f462..c2001e68aa4 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -1088,63 +1088,64 @@ package Snames is Name_Local_Config_File : constant Name_Id := N + 706; Name_Local_Configuration_Pragmas : constant Name_Id := N + 707; Name_Locally_Removed_Files : constant Name_Id := N + 708; - Name_Mapping_File_Switches : constant Name_Id := N + 709; - Name_Mapping_Spec_Suffix : constant Name_Id := N + 710; - Name_Mapping_Body_Suffix : constant Name_Id := N + 711; - Name_Metrics : constant Name_Id := N + 712; - Name_Naming : constant Name_Id := N + 713; - Name_Object_Generated : constant Name_Id := N + 714; - Name_Objects_Linked : constant Name_Id := N + 715; - Name_Objects_Path : constant Name_Id := N + 716; - Name_Objects_Path_File : constant Name_Id := N + 717; - Name_Object_Dir : constant Name_Id := N + 718; - Name_Pic_Option : constant Name_Id := N + 719; - Name_Pretty_Printer : constant Name_Id := N + 720; - Name_Prefix : constant Name_Id := N + 721; - Name_Project : constant Name_Id := N + 722; - Name_Roots : constant Name_Id := N + 723; - Name_Required_Switches : constant Name_Id := N + 724; - Name_Run_Path_Option : constant Name_Id := N + 725; - Name_Runtime_Project : constant Name_Id := N + 726; - Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 727; - Name_Shared_Library_Prefix : constant Name_Id := N + 728; - Name_Shared_Library_Suffix : constant Name_Id := N + 729; - Name_Separate_Suffix : constant Name_Id := N + 730; - Name_Source_Dirs : constant Name_Id := N + 731; - Name_Source_Files : constant Name_Id := N + 732; - Name_Source_List_File : constant Name_Id := N + 733; - Name_Spec : constant Name_Id := N + 734; - Name_Spec_Suffix : constant Name_Id := N + 735; - Name_Specification : constant Name_Id := N + 736; - Name_Specification_Exceptions : constant Name_Id := N + 737; - Name_Specification_Suffix : constant Name_Id := N + 738; - Name_Stack : constant Name_Id := N + 739; - Name_Switches : constant Name_Id := N + 740; - Name_Symbolic_Link_Supported : constant Name_Id := N + 741; - Name_Sync : constant Name_Id := N + 742; - Name_Synchronize : constant Name_Id := N + 743; - Name_Toolchain_Description : constant Name_Id := N + 744; - Name_Toolchain_Version : constant Name_Id := N + 745; - Name_Runtime_Library_Dir : constant Name_Id := N + 746; + Name_Map_File_Option : constant Name_Id := N + 709; + Name_Mapping_File_Switches : constant Name_Id := N + 710; + Name_Mapping_Spec_Suffix : constant Name_Id := N + 711; + Name_Mapping_Body_Suffix : constant Name_Id := N + 712; + Name_Metrics : constant Name_Id := N + 713; + Name_Naming : constant Name_Id := N + 714; + Name_Object_Generated : constant Name_Id := N + 715; + Name_Objects_Linked : constant Name_Id := N + 716; + Name_Objects_Path : constant Name_Id := N + 717; + Name_Objects_Path_File : constant Name_Id := N + 718; + Name_Object_Dir : constant Name_Id := N + 719; + Name_Pic_Option : constant Name_Id := N + 720; + Name_Pretty_Printer : constant Name_Id := N + 721; + Name_Prefix : constant Name_Id := N + 722; + Name_Project : constant Name_Id := N + 723; + Name_Roots : constant Name_Id := N + 724; + Name_Required_Switches : constant Name_Id := N + 725; + Name_Run_Path_Option : constant Name_Id := N + 726; + Name_Runtime_Project : constant Name_Id := N + 727; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 728; + Name_Shared_Library_Prefix : constant Name_Id := N + 729; + Name_Shared_Library_Suffix : constant Name_Id := N + 730; + Name_Separate_Suffix : constant Name_Id := N + 731; + Name_Source_Dirs : constant Name_Id := N + 732; + Name_Source_Files : constant Name_Id := N + 733; + Name_Source_List_File : constant Name_Id := N + 734; + Name_Spec : constant Name_Id := N + 735; + Name_Spec_Suffix : constant Name_Id := N + 736; + Name_Specification : constant Name_Id := N + 737; + Name_Specification_Exceptions : constant Name_Id := N + 738; + Name_Specification_Suffix : constant Name_Id := N + 739; + Name_Stack : constant Name_Id := N + 740; + Name_Switches : constant Name_Id := N + 741; + Name_Symbolic_Link_Supported : constant Name_Id := N + 742; + Name_Sync : constant Name_Id := N + 743; + Name_Synchronize : constant Name_Id := N + 744; + Name_Toolchain_Description : constant Name_Id := N + 745; + Name_Toolchain_Version : constant Name_Id := N + 746; + Name_Runtime_Library_Dir : constant Name_Id := N + 747; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 747; + Name_Unaligned_Valid : constant Name_Id := N + 748; -- Ada 2005 reserved words - First_2005_Reserved_Word : constant Name_Id := N + 748; - Name_Interface : constant Name_Id := N + 748; - Name_Overriding : constant Name_Id := N + 749; - Name_Synchronized : constant Name_Id := N + 750; - Last_2005_Reserved_Word : constant Name_Id := N + 750; + First_2005_Reserved_Word : constant Name_Id := N + 749; + Name_Interface : constant Name_Id := N + 749; + Name_Overriding : constant Name_Id := N + 750; + Name_Synchronized : constant Name_Id := N + 751; + Last_2005_Reserved_Word : constant Name_Id := N + 751; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 750; + Last_Predefined_Name : constant Name_Id := N + 751; --------------------------------------- -- Subtypes Defining Name Categories -- diff --git a/gcc/ada/system-darwin-ppc.ads b/gcc/ada/system-darwin-ppc.ads index fc93f93a92b..be25c474a3a 100644 --- a/gcc/ada/system-darwin-ppc.ads +++ b/gcc/ada/system-darwin-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/PPC Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -164,7 +164,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads index 7bb91e76002..04cdbbcf94f 100644 --- a/gcc/ada/system-darwin-x86.ads +++ b/gcc/ada/system-darwin-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/x86 Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -164,7 +164,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-freebsd-x86.ads b/gcc/ada/system-freebsd-x86.ads index 3631b8575b7..1f727a4def7 100644 --- a/gcc/ada/system-freebsd-x86.ads +++ b/gcc/ada/system-freebsd-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (FreeBSD/x86 Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads index 08c08a36068..f74f5fa11b0 100644 --- a/gcc/ada/system-linux-ppc.ads +++ b/gcc/ada/system-linux-ppc.ads @@ -146,7 +146,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads index f46da46fdaf..81c970d0262 100644 --- a/gcc/ada/system-linux-x86.ads +++ b/gcc/ada/system-linux-x86.ads @@ -146,7 +146,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads index 7ee41803340..da8a2fd9f2c 100644 --- a/gcc/ada/system-linux-x86_64.ads +++ b/gcc/ada/system-linux-x86_64.ads @@ -146,7 +146,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-mingw.ads b/gcc/ada/system-mingw.ads index 56d0fea42fc..4d37001558d 100644 --- a/gcc/ada/system-mingw.ads +++ b/gcc/ada/system-mingw.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Windows Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads index 712812c46c5..26ca7e4d43b 100644 --- a/gcc/ada/system-solaris-sparc.ads +++ b/gcc/ada/system-solaris-sparc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (SUN Solaris Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-solaris-sparcv9.ads b/gcc/ada/system-solaris-sparcv9.ads index 56a60ae9ce7..6da815ecc7e 100644 --- a/gcc/ada/system-solaris-sparcv9.ads +++ b/gcc/ada/system-solaris-sparcv9.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Solaris Sparcv9 Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads index 59c3a360e73..dd7eb4b6728 100644 --- a/gcc/ada/system-solaris-x86.ads +++ b/gcc/ada/system-solaris-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (x86 Solaris Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index d243d726442..d0744bbcca4 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -46,7 +46,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 22; + ASIS_Version_Number : constant := 23; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree diff --git a/gcc/ada/xsnames.adb b/gcc/ada/xsnames.adb index e5579d805e8..d43631a258e 100644 --- a/gcc/ada/xsnames.adb +++ b/gcc/ada/xsnames.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -51,7 +51,6 @@ procedure XSnames is Line : VString := Nul; Name : VString := Nul; Name1 : VString := Nul; - Oname : VString := Nul; Oval : VString := Nul; Restl : VString := Nul; @@ -165,7 +164,6 @@ begin Create (OutH, Out_File, "snames.nh"); Anchored_Mode := True; - Oname := Nul; Val := 0; loop diff --git a/gcc/c.opt b/gcc/c.opt index 18ce852dc86..9669f2ca6ba 100644 --- a/gcc/c.opt +++ b/gcc/c.opt @@ -195,6 +195,10 @@ Wendif-labels C ObjC C++ ObjC++ Warning Warn about stray tokens after #elif and #endif +Wenum-compare +C++ ObjC++ Var(warn_enum_compare) Init(1) Warning +Warn about comparison of different enum types + Werror C ObjC C++ ObjC++ ; Documented in common.opt diff --git a/gcc/cgraphbuild.c b/gcc/cgraphbuild.c index 6706c4520fb..e37ca86f51d 100644 --- a/gcc/cgraphbuild.c +++ b/gcc/cgraphbuild.c @@ -97,7 +97,7 @@ initialize_inline_failed (struct cgraph_node *node) "considered for inlining"); else if (!node->local.inlinable) e->inline_failed = N_("function not inlinable"); - else if (CALL_CANNOT_INLINE_P (e->call_stmt)) + else if (CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) e->inline_failed = N_("mismatched arguments"); else e->inline_failed = N_("function not considered for inlining"); diff --git a/gcc/config/avr/avr.c b/gcc/config/avr/avr.c index 012a7e4fd1b..d2cc33a0293 100644 --- a/gcc/config/avr/avr.c +++ b/gcc/config/avr/avr.c @@ -682,7 +682,9 @@ expand_prologue (void) /* Prevent any attempt to delete the setting of ZERO_REG! */ emit_insn (gen_rtx_USE (VOIDmode, zero_reg_rtx)); } - if (minimize && (frame_pointer_needed || live_seq > 6)) + if (minimize && (frame_pointer_needed + || (AVR_2_BYTE_PC && live_seq > 6) + || live_seq > 7)) { insn = emit_move_insn (gen_rtx_REG (HImode, REG_X), gen_int_mode (size, HImode)); diff --git a/gcc/config/avr/avr.md b/gcc/config/avr/avr.md index 137d3258833..ffbbefa74ef 100644 --- a/gcc/config/avr/avr.md +++ b/gcc/config/avr/avr.md @@ -587,18 +587,6 @@ [(set_attr "length" "2") (set_attr "cc" "set_n")]) -(define_insn "*addhi3_zero_extend2" - [(set (match_operand:HI 0 "register_operand" "=r") - (plus:HI - (zero_extend:HI (match_operand:QI 1 "register_operand" "%0")) - (zero_extend:HI (match_operand:QI 2 "register_operand" "r"))))] - "" - "add %0,%2 - mov %B0,__zero_reg__ - adc %B0,__zero_reg__" - [(set_attr "length" "3") - (set_attr "cc" "set_n")]) - (define_insn "*addhi3_sp_R_pc2" [(set (match_operand:HI 1 "stack_register_operand" "=q") (plus:HI (match_operand:HI 2 "stack_register_operand" "q") @@ -2777,8 +2765,8 @@ (use (reg:HI REG_X)) (clobber (reg:HI REG_Z))] "" - "ldi r30,pm_lo8(1f) - ldi r31,pm_hi8(1f) + "ldi r30,lo8(gs(1f)) + ldi r31,hi8(gs(1f)) %~jmp __prologue_saves__+((18 - %0) * 2) 1:" [(set_attr_alternative "length" diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 30653347913..3fe483343c9 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -4741,7 +4741,12 @@ ix86_function_arg_boundary (enum machine_mode mode, tree type) { int align; if (type) - align = TYPE_ALIGN (type); + { + if (TYPE_STRUCTURAL_EQUALITY_P (type)) + align = TYPE_ALIGN (type); + else + align = TYPE_ALIGN (TYPE_CANONICAL (type)); + } else align = GET_MODE_ALIGNMENT (mode); if (align < PARM_BOUNDARY) @@ -10652,12 +10657,10 @@ ix86_expand_vector_move (enum machine_mode mode, rtx operands[]) && standard_sse_constant_p (op1) <= 0) op1 = validize_mem (force_const_mem (mode, op1)); - /* TDmode values are passed as TImode on the stack. TImode values - are moved via xmm registers, and moving them to stack can result in - unaligned memory access. Use ix86_expand_vector_move_misalign() - if memory operand is not aligned correctly. */ + /* We need to check memory alignment for SSE mode since attribute + can make operands unaligned. */ if (can_create_pseudo_p () - && (mode == TImode) && !TARGET_64BIT + && SSE_REG_MODE_P (mode) && ((MEM_P (op0) && (MEM_ALIGN (op0) < align)) || (MEM_P (op1) && (MEM_ALIGN (op1) < align)))) { diff --git a/gcc/config/rs6000/rs6000.c b/gcc/config/rs6000/rs6000.c index e90772b03ef..1eafc999fde 100644 --- a/gcc/config/rs6000/rs6000.c +++ b/gcc/config/rs6000/rs6000.c @@ -3897,14 +3897,18 @@ rs6000_legitimize_tls_address (rtx addr, enum tls_model model) if (model == TLS_MODEL_GLOBAL_DYNAMIC) { r3 = gen_rtx_REG (Pmode, 3); - if (TARGET_64BIT) - insn = gen_tls_gd_64 (r3, got, addr); + tga = rs6000_tls_get_addr (); + + if (DEFAULT_ABI == ABI_AIX && TARGET_64BIT) + insn = gen_tls_gd_aix64 (r3, got, addr, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_AIX && !TARGET_64BIT) + insn = gen_tls_gd_aix32 (r3, got, addr, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_V4) + insn = gen_tls_gd_sysvsi (r3, got, addr, tga, const0_rtx); else - insn = gen_tls_gd_32 (r3, got, addr); + gcc_unreachable (); + start_sequence (); - emit_insn (insn); - tga = gen_rtx_MEM (Pmode, rs6000_tls_get_addr ()); - insn = gen_call_value (r3, tga, const0_rtx, const0_rtx); insn = emit_call_insn (insn); RTL_CONST_CALL_P (insn) = 1; use_reg (&CALL_INSN_FUNCTION_USAGE (insn), r3); @@ -3915,14 +3919,18 @@ rs6000_legitimize_tls_address (rtx addr, enum tls_model model) else if (model == TLS_MODEL_LOCAL_DYNAMIC) { r3 = gen_rtx_REG (Pmode, 3); - if (TARGET_64BIT) - insn = gen_tls_ld_64 (r3, got); + tga = rs6000_tls_get_addr (); + + if (DEFAULT_ABI == ABI_AIX && TARGET_64BIT) + insn = gen_tls_ld_aix64 (r3, got, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_AIX && !TARGET_64BIT) + insn = gen_tls_ld_aix32 (r3, got, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_V4) + insn = gen_tls_ld_sysvsi (r3, got, tga, const0_rtx); else - insn = gen_tls_ld_32 (r3, got); + gcc_unreachable (); + start_sequence (); - emit_insn (insn); - tga = gen_rtx_MEM (Pmode, rs6000_tls_get_addr ()); - insn = gen_call_value (r3, tga, const0_rtx, const0_rtx); insn = emit_call_insn (insn); RTL_CONST_CALL_P (insn) = 1; use_reg (&CALL_INSN_FUNCTION_USAGE (insn), r3); diff --git a/gcc/config/rs6000/rs6000.md b/gcc/config/rs6000/rs6000.md index fc65c94f8ca..1f63454e694 100644 --- a/gcc/config/rs6000/rs6000.md +++ b/gcc/config/rs6000/rs6000.md @@ -10199,183 +10199,155 @@ ;; TLS support. -;; "b" output constraint here and on tls_ld to support tls linker optimization. -(define_insn "tls_gd_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=b") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGD))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@got@tlsgd") - -(define_insn "tls_gd_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=b") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGD))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%2@got@tlsgd") - -(define_insn "tls_ld_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=b") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b")] - UNSPEC_TLSLD))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%&@got@tlsld") - -(define_insn "tls_ld_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=b") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b")] - UNSPEC_TLSLD))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%&@got@tlsld") - -(define_insn "tls_dtprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@dtprel") - -(define_insn "tls_dtprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%2@dtprel") - -(define_insn "tls_dtprel_ha_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELHA))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addis %0,%1,%2@dtprel@ha") +;; Mode attributes for different ABIs. +(define_mode_iterator TLSmode [(SI "! TARGET_64BIT") (DI "TARGET_64BIT")]) +(define_mode_attr tls_abi_suffix [(SI "32") (DI "64")]) +(define_mode_attr tls_sysv_suffix [(SI "si") (DI "di")]) +(define_mode_attr tls_insn_suffix [(SI "wz") (DI "d")]) + +(define_insn "tls_gd_aix<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 3 "symbol_ref_operand" "s")) + (match_operand 4 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_AIX" + "addi %0,%1,%2@got@tlsgd\;bl %z3\;%." + [(set_attr "type" "two") + (set_attr "length" "12")]) -(define_insn "tls_dtprel_ha_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELHA))] - "HAVE_AS_TLS && TARGET_64BIT" - "addis %0,%1,%2@dtprel@ha") +(define_insn "tls_gd_sysv<TLSmode:tls_sysv_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 3 "symbol_ref_operand" "s")) + (match_operand 4 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_V4" +{ + if (flag_pic) + { + if (TARGET_SECURE_PLT && flag_pic == 2) + return "addi %0,%1,%2@got@tlsgd\;bl %z3+32768@plt"; + else + return "addi %0,%1,%2@got@tlsgd\;bl %z3@plt"; + } + else + return "addi %0,%1,%2@got@tlsgd\;bl %z3"; +} + [(set_attr "type" "two") + (set_attr "length" "8")]) -(define_insn "tls_dtprel_lo_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELLO))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@dtprel@l") +(define_insn "tls_ld_aix<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 2 "symbol_ref_operand" "s")) + (match_operand 3 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b")] + UNSPEC_TLSLD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_AIX" + "addi %0,%1,%&@got@tlsld\;bl %z2\;%." + [(set_attr "length" "12")]) -(define_insn "tls_dtprel_lo_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELLO))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%2@dtprel@l") +(define_insn "tls_ld_sysv<TLSmode:tls_sysv_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 2 "symbol_ref_operand" "s")) + (match_operand 3 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b")] + UNSPEC_TLSLD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_V4" +{ + if (flag_pic) + { + if (TARGET_SECURE_PLT && flag_pic == 2) + return "addi %0,%1,%&@got@tlsld\;bl %z2+32768@plt"; + else + return "addi %0,%1,%&@got@tlsld\;bl %z2@plt"; + } + else + return "addi %0,%1,%&@got@tlsld\;bl %z2"; +} + [(set_attr "length" "8")]) -(define_insn "tls_got_dtprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTDTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "lwz %0,%2@got@dtprel(%1)") +(define_insn "tls_dtprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSDTPREL))] + "HAVE_AS_TLS" + "addi %0,%1,%2@dtprel") -(define_insn "tls_got_dtprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTDTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" - "ld %0,%2@got@dtprel(%1)") +(define_insn "tls_dtprel_ha_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSDTPRELHA))] + "HAVE_AS_TLS" + "addis %0,%1,%2@dtprel@ha") -(define_insn "tls_tprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@tprel") +(define_insn "tls_dtprel_lo_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSDTPRELLO))] + "HAVE_AS_TLS" + "addi %0,%1,%2@dtprel@l") -(define_insn "tls_tprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" +(define_insn "tls_got_dtprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGOTDTPREL))] + "HAVE_AS_TLS" + "l<TLSmode:tls_insn_suffix> %0,%2@got@dtprel(%1)") + +(define_insn "tls_tprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTPREL))] + "HAVE_AS_TLS" "addi %0,%1,%2@tprel") -(define_insn "tls_tprel_ha_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELHA))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addis %0,%1,%2@tprel@ha") - -(define_insn "tls_tprel_ha_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELHA))] - "HAVE_AS_TLS && TARGET_64BIT" +(define_insn "tls_tprel_ha_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTPRELHA))] + "HAVE_AS_TLS" "addis %0,%1,%2@tprel@ha") -(define_insn "tls_tprel_lo_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELLO))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@tprel@l") - -(define_insn "tls_tprel_lo_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELLO))] - "HAVE_AS_TLS && TARGET_64BIT" +(define_insn "tls_tprel_lo_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTPRELLO))] + "HAVE_AS_TLS" "addi %0,%1,%2@tprel@l") ;; "b" output constraint here and on tls_tls input to support linker tls ;; optimization. The linker may edit the instructions emitted by a ;; tls_got_tprel/tls_tls pair to addis,addi. -(define_insn "tls_got_tprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=b") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "lwz %0,%2@got@tprel(%1)") - -(define_insn "tls_got_tprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=b") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" - "ld %0,%2@got@tprel(%1)") - -(define_insn "tls_tls_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTLS))] - "HAVE_AS_TLS && !TARGET_64BIT" +(define_insn "tls_got_tprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGOTTPREL))] + "HAVE_AS_TLS" + "l<TLSmode:tls_insn_suffix> %0,%2@got@tprel(%1)") + +(define_insn "tls_tls_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTLS))] + "HAVE_AS_TLS" "add %0,%1,%2@tls") -(define_insn "tls_tls_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTLS))] - "HAVE_AS_TLS && TARGET_64BIT" - "add %0,%1,%2@tls") ;; Next come insns related to the calling sequence. ;; diff --git a/gcc/config/s390/s390.md b/gcc/config/s390/s390.md index 5ffa72884a0..03ebfcde5b8 100644 --- a/gcc/config/s390/s390.md +++ b/gcc/config/s390/s390.md @@ -231,6 +231,34 @@ (define_attr "cpu" "g5,g6,z900,z990,z9_109" (const (symbol_ref "s390_tune"))) +(define_attr "cpu_facility" "standard,ieee,zarch,longdisp,extimm,dfp" + (const_string "standard")) + +(define_attr "enabled" "" + (cond [(eq_attr "cpu_facility" "standard") + (const_int 1) + + (and (eq_attr "cpu_facility" "ieee") + (ne (symbol_ref "TARGET_CPU_IEEE_FLOAT") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "zarch") + (ne (symbol_ref "TARGET_ZARCH") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "longdisp") + (ne (symbol_ref "TARGET_LONG_DISPLACEMENT") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "extimm") + (ne (symbol_ref "TARGET_EXTIMM") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "dfp") + (ne (symbol_ref "TARGET_DFP") (const_int 0))) + (const_int 1)] + (const_int 0))) + ;; Pipeline description for z900. For lack of anything better, ;; this description is also used for the g5 and g6. (include "2064.md") @@ -523,7 +551,7 @@ ; ltr, lt, ltgr, ltg (define_insn "*tst<mode>_extimm" [(set (reg CC_REGNUM) - (compare (match_operand:GPR 0 "nonimmediate_operand" "d,m") + (compare (match_operand:GPR 0 "nonimmediate_operand" "d,RT") (match_operand:GPR 1 "const0_operand" ""))) (set (match_operand:GPR 2 "register_operand" "=d,d") (match_dup 0))] @@ -536,7 +564,7 @@ ; ltr, lt, ltgr, ltg (define_insn "*tst<mode>_cconly_extimm" [(set (reg CC_REGNUM) - (compare (match_operand:GPR 0 "nonimmediate_operand" "d,m") + (compare (match_operand:GPR 0 "nonimmediate_operand" "d,RT") (match_operand:GPR 1 "const0_operand" ""))) (clobber (match_scratch:GPR 2 "=X,d"))] "s390_match_ccmode(insn, CCSmode) && TARGET_EXTIMM" @@ -665,7 +693,7 @@ (define_insn "*cmpdi_cct" [(set (reg CC_REGNUM) (compare (match_operand:DI 0 "nonimmediate_operand" "%d,d,d,d,Q") - (match_operand:DI 1 "general_operand" "d,K,Os,m,BQ")))] + (match_operand:DI 1 "general_operand" "d,K,Os,RT,BQ")))] "s390_match_ccmode (insn, CCTmode) && TARGET_64BIT" "@ cgr\t%0,%1 @@ -694,7 +722,7 @@ (define_insn "*cmpdi_ccs_sign" [(set (reg CC_REGNUM) - (compare (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")) + (compare (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,RT")) (match_operand:DI 0 "register_operand" "d,d")))] "s390_match_ccmode(insn, CCSRmode) && TARGET_64BIT" "@ @@ -731,7 +759,7 @@ (define_insn "*cmpdi_ccu_zero" [(set (reg CC_REGNUM) - (compare (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")) + (compare (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,RT")) (match_operand:DI 0 "register_operand" "d,d")))] "s390_match_ccmode (insn, CCURmode) && TARGET_64BIT" "@ @@ -742,7 +770,7 @@ (define_insn "*cmpdi_ccu" [(set (reg CC_REGNUM) (compare (match_operand:DI 0 "nonimmediate_operand" "d,d,d,Q,BQ") - (match_operand:DI 1 "general_operand" "d,Op,m,BQ,Q")))] + (match_operand:DI 1 "general_operand" "d,Op,RT,BQ,Q")))] "s390_match_ccmode (insn, CCUmode) && TARGET_64BIT" "@ clgr\t%0,%1 @@ -863,7 +891,7 @@ (define_insn "movti" [(set (match_operand:TI 0 "nonimmediate_operand" "=d,QS,d,o,Q") - (match_operand:TI 1 "general_operand" "QS,d,dPm,d,Q"))] + (match_operand:TI 1 "general_operand" "QS,d,dPRT,d,Q"))] "TARGET_64BIT" "@ lmg\t%0,%N0,%S1 @@ -986,14 +1014,14 @@ [(set_attr "op_type" "RIL") (set_attr "type" "larl")]) -(define_insn "*movdi_64dfp" +(define_insn "*movdi_64" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,f,d,d,d,d, - m,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") + RT,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") (match_operand:DI 1 "general_operand" - "K,N0HD0,N1HD0,N2HD0,N3HD0,Os,N0SD0,N1SD0,d,f,L,d,m, + "K,N0HD0,N1HD0,N2HD0,N3HD0,Os,N0SD0,N1SD0,d,f,L,d,RT, d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] - "TARGET_64BIT && TARGET_DFP" + "TARGET_64BIT" "@ lghi\t%0,%h1 llihh\t%0,%i1 @@ -1022,72 +1050,9 @@ [(set_attr "op_type" "RI,RI,RI,RI,RI,RIL,RIL,RIL,RRE,RRE,RXY,RRE,RXY,RXY, RR,RX,RXY,RX,RXY,*,*,RS,RS,SS") (set_attr "type" "*,*,*,*,*,*,*,*,floaddf,floaddf,la,lr,load,store, - floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*")]) - -(define_insn "*movdi_64extimm" - [(set (match_operand:DI 0 "nonimmediate_operand" - "=d,d,d,d,d,d,d,d,d,d,d,m,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") - (match_operand:DI 1 "general_operand" - "K,N0HD0,N1HD0,N2HD0,N3HD0,Os,N0SD0,N1SD0,L,d,m,d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] - "TARGET_64BIT && TARGET_EXTIMM" - "@ - lghi\t%0,%h1 - llihh\t%0,%i1 - llihl\t%0,%i1 - llilh\t%0,%i1 - llill\t%0,%i1 - lgfi\t%0,%1 - llihf\t%0,%k1 - llilf\t%0,%k1 - lay\t%0,%a1 - lgr\t%0,%1 - lg\t%0,%1 - stg\t%1,%0 - ldr\t%0,%1 - ld\t%0,%1 - ldy\t%0,%1 - std\t%1,%0 - stdy\t%1,%0 - # - # - stam\t%1,%N1,%S0 - lam\t%0,%N0,%S1 - #" - [(set_attr "op_type" "RI,RI,RI,RI,RI,RIL,RIL,RIL,RXY,RRE,RXY,RXY, - RR,RX,RXY,RX,RXY,*,*,RS,RS,SS") - (set_attr "type" "*,*,*,*,*,*,*,*,la,lr,load,store, - floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*")]) - -(define_insn "*movdi_64" - [(set (match_operand:DI 0 "nonimmediate_operand" - "=d,d,d,d,d,d,d,d,m,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") - (match_operand:DI 1 "general_operand" - "K,N0HD0,N1HD0,N2HD0,N3HD0,L,d,m,d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] - "TARGET_64BIT && !TARGET_EXTIMM" - "@ - lghi\t%0,%h1 - llihh\t%0,%i1 - llihl\t%0,%i1 - llilh\t%0,%i1 - llill\t%0,%i1 - lay\t%0,%a1 - lgr\t%0,%1 - lg\t%0,%1 - stg\t%1,%0 - ldr\t%0,%1 - ld\t%0,%1 - ldy\t%0,%1 - std\t%1,%0 - stdy\t%1,%0 - # - # - stam\t%1,%N1,%S0 - lam\t%0,%N0,%S1 - #" - [(set_attr "op_type" "RI,RI,RI,RI,RI,RXY,RRE,RXY,RXY, - RR,RX,RXY,RX,RXY,*,*,RS,RS,SS") - (set_attr "type" "*,*,*,*,*,la,lr,load,store, - floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*")]) + floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*") + (set_attr "cpu_facility" "*,*,*,*,*,extimm,extimm,extimm,dfp,dfp,longdisp, + *,*,*,*,*,longdisp,*,longdisp,*,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "register_operand" "") @@ -1124,7 +1089,7 @@ (define_insn "*movdi_31" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,Q,S,d,o,!*f,!*f,!*f,!R,!T,Q") - (match_operand:DI 1 "general_operand" "Q,S,d,d,dPm,d,*f,R,T,*f,*f,Q"))] + (match_operand:DI 1 "general_operand" "Q,S,d,d,dPRT,d,*f,R,T,*f,*f,Q"))] "!TARGET_64BIT" "@ lm\t%0,%N0,%S1 @@ -1540,7 +1505,7 @@ (define_insn "*mov<mode>_64" [(set (match_operand:TD_TF 0 "nonimmediate_operand" "=f,f,f,o, d,QS, d,o,Q") - (match_operand:TD_TF 1 "general_operand" " G,f,o,f,QS, d,dm,d,Q"))] + (match_operand:TD_TF 1 "general_operand" " G,f,o,f,QS, d,dRT,d,Q"))] "TARGET_64BIT" "@ lzxr\t%0 @@ -1657,9 +1622,9 @@ (define_insn "*mov<mode>_64dfp" [(set (match_operand:DD_DF 0 "nonimmediate_operand" - "=f,f,f,d,f,f,R,T,d,d,m,?Q") + "=f,f,f,d,f,f,R,T,d,d,RT,?Q") (match_operand:DD_DF 1 "general_operand" - "G,f,d,f,R,T,f,f,d,m,d,?Q"))] + "G,f,d,f,R,T,f,f,d,RT,d,?Q"))] "TARGET_64BIT && TARGET_DFP" "@ lzdr\t%0 @@ -1679,8 +1644,8 @@ fstoredf,fstoredf,lr,load,store,*")]) (define_insn "*mov<mode>_64" - [(set (match_operand:DD_DF 0 "nonimmediate_operand" "=f,f,f,f,R,T,d,d,m,?Q") - (match_operand:DD_DF 1 "general_operand" "G,f,R,T,f,f,d,m,d,?Q"))] + [(set (match_operand:DD_DF 0 "nonimmediate_operand" "=f,f,f,f,R,T,d, d,RT,?Q") + (match_operand:DD_DF 1 "general_operand" "G,f,R,T,f,f,d,RT, d,?Q"))] "TARGET_64BIT" "@ lzdr\t%0 @@ -1699,9 +1664,9 @@ (define_insn "*mov<mode>_31" [(set (match_operand:DD_DF 0 "nonimmediate_operand" - "=f,f,f,f,R,T,d,d,Q,S, d,o,Q") + "=f,f,f,f,R,T,d,d,Q,S, d,o,Q") (match_operand:DD_DF 1 "general_operand" - " G,f,R,T,f,f,Q,S,d,d,dPm,d,Q"))] + " G,f,R,T,f,f,Q,S,d,d,dPRT,d,Q"))] "!TARGET_64BIT" "@ lzdr\t%0 @@ -2903,7 +2868,7 @@ (define_insn "*extendsidi2" [(set (match_operand:DI 0 "register_operand" "=d,d") - (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")))] + (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,RT")))] "TARGET_64BIT" "@ lgfr\t%0,%1 @@ -2944,7 +2909,7 @@ (define_insn "*extendhidi2_extimm" [(set (match_operand:DI 0 "register_operand" "=d,d") - (sign_extend:DI (match_operand:HI 1 "nonimmediate_operand" "d,m")))] + (sign_extend:DI (match_operand:HI 1 "nonimmediate_operand" "d,RT")))] "TARGET_64BIT && TARGET_EXTIMM" "@ lghr\t%0,%1 @@ -2953,7 +2918,7 @@ (define_insn "*extendhidi2" [(set (match_operand:DI 0 "register_operand" "=d") - (sign_extend:DI (match_operand:HI 1 "memory_operand" "m")))] + (sign_extend:DI (match_operand:HI 1 "memory_operand" "RT")))] "TARGET_64BIT" "lgh\t%0,%1" [(set_attr "op_type" "RXY")]) @@ -2988,7 +2953,7 @@ ; lbr, lgbr, lb, lgb (define_insn "*extendqi<mode>2_extimm" [(set (match_operand:GPR 0 "register_operand" "=d,d") - (sign_extend:GPR (match_operand:QI 1 "nonimmediate_operand" "d,m")))] + (sign_extend:GPR (match_operand:QI 1 "nonimmediate_operand" "d,RT")))] "TARGET_EXTIMM" "@ l<g>br\t%0,%1 @@ -2998,7 +2963,7 @@ ; lb, lgb (define_insn "*extendqi<mode>2" [(set (match_operand:GPR 0 "register_operand" "=d") - (sign_extend:GPR (match_operand:QI 1 "memory_operand" "m")))] + (sign_extend:GPR (match_operand:QI 1 "memory_operand" "RT")))] "!TARGET_EXTIMM && TARGET_LONG_DISPLACEMENT" "l<g>b\t%0,%1" [(set_attr "op_type" "RXY")]) @@ -3043,7 +3008,7 @@ (define_insn "*zero_extendsidi2" [(set (match_operand:DI 0 "register_operand" "=d,d") - (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")))] + (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,RT")))] "TARGET_64BIT" "@ llgfr\t%0,%1 @@ -3056,7 +3021,7 @@ (define_insn "*llgt_sidi" [(set (match_operand:DI 0 "register_operand" "=d") - (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "m") 0) + (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "RT") 0) (const_int 2147483647)))] "TARGET_64BIT" "llgt\t%0,%1" @@ -3064,7 +3029,7 @@ (define_insn_and_split "*llgt_sidi_split" [(set (match_operand:DI 0 "register_operand" "=d") - (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "m") 0) + (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "RT") 0) (const_int 2147483647))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" @@ -3077,7 +3042,7 @@ (define_insn "*llgt_sisi" [(set (match_operand:SI 0 "register_operand" "=d,d") - (and:SI (match_operand:SI 1 "nonimmediate_operand" "d,m") + (and:SI (match_operand:SI 1 "nonimmediate_operand" "d,RT") (const_int 2147483647)))] "TARGET_ZARCH" "@ @@ -3150,7 +3115,7 @@ ; llhr, llcr, llghr, llgcr, llh, llc, llgh, llgc (define_insn "*zero_extend<HQI:mode><GPR:mode>2_extimm" [(set (match_operand:GPR 0 "register_operand" "=d,d") - (zero_extend:GPR (match_operand:HQI 1 "nonimmediate_operand" "d,m")))] + (zero_extend:GPR (match_operand:HQI 1 "nonimmediate_operand" "d,RT")))] "TARGET_EXTIMM" "@ ll<g><hc>r\t%0,%1 @@ -3160,7 +3125,7 @@ ; llgh, llgc (define_insn "*zero_extend<HQI:mode><GPR:mode>2" [(set (match_operand:GPR 0 "register_operand" "=d") - (zero_extend:GPR (match_operand:HQI 1 "memory_operand" "m")))] + (zero_extend:GPR (match_operand:HQI 1 "memory_operand" "RT")))] "TARGET_ZARCH && !TARGET_EXTIMM" "llg<hc>\t%0,%1" [(set_attr "op_type" "RXY")]) @@ -3180,7 +3145,7 @@ (define_insn_and_split "*zero_extendqisi2_31" [(set (match_operand:SI 0 "register_operand" "=&d") - (zero_extend:SI (match_operand:QI 1 "memory_operand" "m")))] + (zero_extend:SI (match_operand:QI 1 "memory_operand" "RT")))] "!TARGET_ZARCH" "#" "&& reload_completed" @@ -3204,14 +3169,14 @@ (define_insn "*zero_extendqihi2_64" [(set (match_operand:HI 0 "register_operand" "=d") - (zero_extend:HI (match_operand:QI 1 "memory_operand" "m")))] + (zero_extend:HI (match_operand:QI 1 "memory_operand" "RT")))] "TARGET_ZARCH && !TARGET_EXTIMM" "llgc\t%0,%1" [(set_attr "op_type" "RXY")]) (define_insn_and_split "*zero_extendqihi2_31" [(set (match_operand:HI 0 "register_operand" "=&d") - (zero_extend:HI (match_operand:QI 1 "memory_operand" "m")))] + (zero_extend:HI (match_operand:QI 1 "memory_operand" "RT")))] "!TARGET_ZARCH" "#" "&& reload_completed" @@ -3668,7 +3633,7 @@ (define_insn "*adddi3_sign" [(set (match_operand:DI 0 "register_operand" "=d,d") - (plus:DI (sign_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (plus:DI (sign_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0"))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" @@ -3679,7 +3644,7 @@ (define_insn "*adddi3_zero_cc" [(set (reg CC_REGNUM) - (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") @@ -3692,7 +3657,7 @@ (define_insn "*adddi3_zero_cconly" [(set (reg CC_REGNUM) - (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] @@ -3704,7 +3669,7 @@ (define_insn "*adddi3_zero" [(set (match_operand:DI 0 "register_operand" "=d,d") - (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0"))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" @@ -4032,7 +3997,7 @@ (define_insn "*subdi3_sign" [(set (match_operand:DI 0 "register_operand" "=d,d") (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (sign_extend:DI (match_operand:SI 2 "general_operand" "d,m")))) + (sign_extend:DI (match_operand:SI 2 "general_operand" "d,RT")))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" "@ @@ -4043,7 +4008,7 @@ (define_insn "*subdi3_zero_cc" [(set (reg CC_REGNUM) (compare (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m"))) + (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT"))) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (minus:DI (match_dup 1) (zero_extend:DI (match_dup 2))))] @@ -4056,7 +4021,7 @@ (define_insn "*subdi3_zero_cconly" [(set (reg CC_REGNUM) (compare (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m"))) + (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT"))) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode (insn, CCLmode) && TARGET_64BIT" @@ -4068,7 +4033,7 @@ (define_insn "*subdi3_zero" [(set (match_operand:DI 0 "register_operand" "=d,d") (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")))) + (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" "@ @@ -4324,7 +4289,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 1))) (set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_dup 3) (match_dup 1)) (match_dup 2)))] @@ -4340,7 +4305,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 1))) (clobber (match_scratch:GPR 0 "=d,d"))] "s390_match_ccmode (insn, CCL1mode) && TARGET_CPU_ZARCH" @@ -4357,7 +4322,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 2))) (set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_dup 3) (match_dup 1)) (match_dup 2)))] @@ -4373,7 +4338,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 2))) (clobber (match_scratch:GPR 0 "=d,d"))] "s390_match_ccmode (insn, CCL1mode) && TARGET_CPU_ZARCH" @@ -4388,7 +4353,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_dup 3) (match_dup 1)) (match_dup 2)))] @@ -4403,7 +4368,7 @@ [(set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m"))) + (match_operand:GPR 2 "general_operand" "d,RT"))) (clobber (reg:CC CC_REGNUM))] "TARGET_CPU_ZARCH" "@ @@ -4416,7 +4381,7 @@ [(set (reg CC_REGNUM) (compare (minus:GPR (minus:GPR (match_operand:GPR 1 "nonimmediate_operand" "0,0") - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_operand:GPR 3 "s390_slb_comparison" "")) (const_int 0))) (set (match_operand:GPR 0 "register_operand" "=d,d") @@ -4431,7 +4396,7 @@ (define_insn "*sub<mode>3_slb" [(set (match_operand:GPR 0 "register_operand" "=d,d") (minus:GPR (minus:GPR (match_operand:GPR 1 "nonimmediate_operand" "0,0") - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_operand:GPR 3 "s390_slb_comparison" ""))) (clobber (reg:CC CC_REGNUM))] "TARGET_CPU_ZARCH" @@ -4534,7 +4499,7 @@ (define_insn "*muldi3_sign" [(set (match_operand:DI 0 "register_operand" "=d,d") - (mult:DI (sign_extend:DI (match_operand:SI 2 "nonimmediate_operand" "d,m")) + (mult:DI (sign_extend:DI (match_operand:SI 2 "nonimmediate_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0")))] "TARGET_64BIT" "@ @@ -4546,7 +4511,7 @@ (define_insn "muldi3" [(set (match_operand:DI 0 "register_operand" "=d,d,d") (mult:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0") - (match_operand:DI 2 "general_operand" "d,K,m")))] + (match_operand:DI 2 "general_operand" "d,K,RT")))] "TARGET_64BIT" "@ msgr\t%0,%2 @@ -4607,7 +4572,7 @@ (mult:DI (zero_extend:DI (match_operand:SI 1 "register_operand" "%0,0")) (zero_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,m"))))] + (match_operand:SI 2 "nonimmediate_operand" "d,RT"))))] "!TARGET_64BIT && TARGET_CPU_ZARCH" "@ mlr\t%0,%2 @@ -4697,7 +4662,7 @@ (ashift:TI (zero_extend:TI (mod:DI (match_operand:DI 1 "register_operand" "0,0") - (match_operand:DI 2 "general_operand" "d,m"))) + (match_operand:DI 2 "general_operand" "d,RT"))) (const_int 64)) (zero_extend:TI (div:DI (match_dup 1) (match_dup 2)))))] "TARGET_64BIT" @@ -4714,7 +4679,7 @@ (zero_extend:TI (mod:DI (match_operand:DI 1 "register_operand" "0,0") (sign_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,m")))) + (match_operand:SI 2 "nonimmediate_operand" "d,RT")))) (const_int 64)) (zero_extend:TI (div:DI (match_dup 1) (sign_extend:DI (match_dup 2))))))] @@ -4773,7 +4738,7 @@ (truncate:DI (umod:TI (match_operand:TI 1 "register_operand" "0,0") (zero_extend:TI - (match_operand:DI 2 "nonimmediate_operand" "d,m"))))) + (match_operand:DI 2 "nonimmediate_operand" "d,RT"))))) (const_int 64)) (zero_extend:TI (truncate:DI @@ -4891,7 +4856,7 @@ (truncate:SI (umod:DI (match_operand:DI 1 "register_operand" "0,0") (zero_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,m"))))) + (match_operand:SI 2 "nonimmediate_operand" "d,RT"))))) (const_int 32)) (zero_extend:DI (truncate:SI @@ -5111,7 +5076,7 @@ (define_insn "*anddi3_cc" [(set (reg CC_REGNUM) (compare (and:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (and:DI (match_dup 1) (match_dup 2)))] @@ -5124,7 +5089,7 @@ (define_insn "*anddi3_cconly" [(set (reg CC_REGNUM) (compare (and:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode(insn, CCTmode) && TARGET_64BIT @@ -5135,14 +5100,14 @@ ng\t%0,%2" [(set_attr "op_type" "RRE,RXY")]) -(define_insn "*anddi3_extimm" +(define_insn "*anddi3" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,d,d,AQ,Q") (and:DI (match_operand:DI 1 "nonimmediate_operand" "%d,o,0,0,0,0,0,0,0,0,0,0") (match_operand:DI 2 "general_operand" - "M,M,N0HDF,N1HDF,N2HDF,N3HDF,N0SDF,N1SDF,d,m,NxQDF,Q"))) + "M,M,N0HDF,N1HDF,N2HDF,N3HDF,N0SDF,N1SDF,d,RT,NxQDF,Q"))) (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" + "TARGET_64BIT && s390_logical_operator_ok_p (operands)" "@ # # @@ -5156,28 +5121,8 @@ ng\t%0,%2 # #" - [(set_attr "op_type" "RRE,RXE,RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS")]) - -(define_insn "*anddi3" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,AQ,Q") - (and:DI (match_operand:DI 1 "nonimmediate_operand" - "%d,o,0,0,0,0,0,0,0,0") - (match_operand:DI 2 "general_operand" - "M,M,N0HDF,N1HDF,N2HDF,N3HDF,d,m,NxQDF,Q"))) - (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && !TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" - "@ - # - # - nihh\t%0,%j2 - nihl\t%0,%j2 - nilh\t%0,%j2 - nill\t%0,%j2 - ngr\t%0,%2 - ng\t%0,%2 - # - #" - [(set_attr "op_type" "RRE,RXE,RI,RI,RI,RI,RRE,RXY,SI,SS")]) + [(set_attr "op_type" "RRE,RXE,RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS") + (set_attr "cpu_facility" "*,*,*,*,*,*,extimm,extimm,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "s_operand" "") @@ -5416,7 +5361,7 @@ (define_insn "*iordi3_cc" [(set (reg CC_REGNUM) (compare (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (ior:DI (match_dup 1) (match_dup 2)))] @@ -5429,7 +5374,7 @@ (define_insn "*iordi3_cconly" [(set (reg CC_REGNUM) (compare (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode(insn, CCTmode) && TARGET_64BIT" @@ -5438,13 +5383,13 @@ og\t%0,%2" [(set_attr "op_type" "RRE,RXY")]) -(define_insn "*iordi3_extimm" +(define_insn "*iordi3" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,AQ,Q") (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0,0,0,0,0,0,0") (match_operand:DI 2 "general_operand" - "N0HD0,N1HD0,N2HD0,N3HD0,N0SD0,N1SD0,d,m,NxQD0,Q"))) + "N0HD0,N1HD0,N2HD0,N3HD0,N0SD0,N1SD0,d,RT,NxQD0,Q"))) (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" + "TARGET_64BIT && s390_logical_operator_ok_p (operands)" "@ oihh\t%0,%i2 oihl\t%0,%i2 @@ -5456,25 +5401,8 @@ og\t%0,%2 # #" - [(set_attr "op_type" "RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS")]) - -(define_insn "*iordi3" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,AQ,Q") - (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0,0,0,0,0") - (match_operand:DI 2 "general_operand" - "N0HD0,N1HD0,N2HD0,N3HD0,d,m,NxQD0,Q"))) - (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && !TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" - "@ - oihh\t%0,%i2 - oihl\t%0,%i2 - oilh\t%0,%i2 - oill\t%0,%i2 - ogr\t%0,%2 - og\t%0,%2 - # - #" - [(set_attr "op_type" "RI,RI,RI,RI,RRE,RXY,SI,SS")]) + [(set_attr "op_type" "RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS") + (set_attr "cpu_facility" "*,*,*,*,extimm,extimm,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "s_operand" "") @@ -5706,7 +5634,7 @@ (define_insn "*xordi3_cc" [(set (reg CC_REGNUM) (compare (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (xor:DI (match_dup 1) (match_dup 2)))] @@ -5719,7 +5647,7 @@ (define_insn "*xordi3_cconly" [(set (reg CC_REGNUM) (compare (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode(insn, CCTmode) && TARGET_64BIT" @@ -5728,12 +5656,12 @@ xg\t%0,%2" [(set_attr "op_type" "RRE,RXY")]) -(define_insn "*xordi3_extimm" +(define_insn "*xordi3" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,AQ,Q") (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0,0,0") - (match_operand:DI 2 "general_operand" "N0SD0,N1SD0,d,m,NxQD0,Q"))) + (match_operand:DI 2 "general_operand" "N0SD0,N1SD0,d,RT,NxQD0,Q"))) (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" + "TARGET_64BIT && s390_logical_operator_ok_p (operands)" "@ xihf\t%0,%k2 xilf\t%0,%k2 @@ -5741,20 +5669,8 @@ xg\t%0,%2 # #" - [(set_attr "op_type" "RIL,RIL,RRE,RXY,SI,SS")]) - -(define_insn "*xordi3" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,AQ,Q") - (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0") - (match_operand:DI 2 "general_operand" "d,m,NxQD0,Q"))) - (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && !TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" - "@ - xgr\t%0,%2 - xg\t%0,%2 - # - #" - [(set_attr "op_type" "RRE,RXY,SI,SS")]) + [(set_attr "op_type" "RIL,RIL,RRE,RXY,SI,SS") + (set_attr "cpu_facility" "extimm,extimm,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "s_operand" "") @@ -7411,7 +7327,7 @@ (define_insn "*tls_load_64" [(set (match_operand:DI 0 "register_operand" "=d") - (unspec:DI [(match_operand:DI 1 "memory_operand" "m") + (unspec:DI [(match_operand:DI 1 "memory_operand" "RT") (match_operand:DI 2 "" "")] UNSPEC_TLS_LOAD))] "TARGET_64BIT" diff --git a/gcc/config/spu/divmodti4.c b/gcc/config/spu/divmodti4.c new file mode 100644 index 00000000000..ca643cc33bf --- /dev/null +++ b/gcc/config/spu/divmodti4.c @@ -0,0 +1,168 @@ +/* Copyright (C) 2008 Free Software Foundation, Inc. + + This file is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2 of the License, or (at your option) + any later version. + + This file is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with this file; see the file COPYING. If not, write to the Free + Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA + 02110-1301, USA. */ + +/* As a special exception, if you link this library with files compiled with + GCC to produce an executable, this does not cause the resulting executable + to be covered by the GNU General Public License. The exception does not + however invalidate any other reasons why the executable file might be covered + by the GNU General Public License. */ + +#include <spu_intrinsics.h> + +typedef unsigned int UTItype __attribute__ ((mode (TI))); +typedef int TItype __attribute__ ((mode (TI))); +TItype __divti3 (TItype u, TItype v); +TItype __modti3 (TItype u, TItype v); +UTItype __udivti3 (UTItype u, UTItype v); +UTItype __umodti3 (UTItype u, UTItype v); +UTItype __udivmodti4 (UTItype u, UTItype v, UTItype *w); + +inline static unsigned int +count_leading_zeros (UTItype x) +{ + qword c = si_clz (*(qword *) & x); + qword cmp0 = si_cgti (c, 31); + qword cmp1 = si_and (cmp0, si_shlqbyi (cmp0, 4)); + qword cmp2 = si_and (cmp1, si_shlqbyi (cmp0, 8)); + qword s = si_a (c, si_and (cmp0, si_shlqbyi (c, 4))); + s = si_a (s, si_and (cmp1, si_shlqbyi (c, 8))); + s = si_a (s, si_and (cmp2, si_shlqbyi (c, 12))); + return si_to_uint (s); +} + +/* Based on implementation of udivmodsi4, which is essentially + * an optimized version of gcc/config/udivmodsi4.c + clz %7,%2 + clz %4,%1 + il %5,1 + fsmbi %0,0 + sf %7,%4,%7 + ori %3,%1,0 + shl %5,%5,%7 + shl %4,%2,%7 +1: or %8,%0,%5 + rotmi %5,%5,-1 + clgt %6,%4,%3 + sf %7,%4,%3 + rotmi %4,%4,-1 + selb %0,%8,%0,%6 + selb %3,%7,%3,%6 +3: brnz %5,1b + */ + +UTItype +__udivmodti4 (UTItype num, UTItype den, UTItype * rp) +{ + qword shift = + si_from_uint (count_leading_zeros (den) - count_leading_zeros (num)); + qword n0 = *(qword *) & num; + qword d0 = *(qword *) & den; + qword bit = si_andi (si_fsmbi (1), 1); + qword r0 = si_il (0); + qword m1 = si_fsmbi (0x000f); + qword mask, r1, n1; + + d0 = si_shlqbybi (si_shlqbi (d0, shift), shift); + bit = si_shlqbybi (si_shlqbi (bit, shift), shift); + + do + { + r1 = si_or (r0, bit); + + // n1 = n0 - d0 in TImode + n1 = si_bg (d0, n0); + n1 = si_shlqbyi (n1, 4); + n1 = si_sf (m1, n1); + n1 = si_bgx (d0, n0, n1); + n1 = si_shlqbyi (n1, 4); + n1 = si_sf (m1, n1); + n1 = si_bgx (d0, n0, n1); + n1 = si_shlqbyi (n1, 4); + n1 = si_sf (m1, n1); + n1 = si_sfx (d0, n0, n1); + + mask = si_fsm (si_cgti (n1, -1)); + r0 = si_selb (r0, r1, mask); + n0 = si_selb (n0, n1, mask); + bit = si_rotqmbii (bit, -1); + d0 = si_rotqmbii (d0, -1); + } + while (si_to_uint (si_orx (bit))); + if (rp) + *rp = *(UTItype *) & n0; + return *(UTItype *) & r0; +} + +UTItype +__udivti3 (UTItype n, UTItype d) +{ + return __udivmodti4 (n, d, (UTItype *)0); +} + +UTItype +__umodti3 (UTItype n, UTItype d) +{ + UTItype w; + __udivmodti4 (n, d, &w); + return w; +} + +TItype +__divti3 (TItype n, TItype d) +{ + int c = 0; + TItype w; + + if (n < 0) + { + c = ~c; + n = -n; + } + if (d < 0) + { + c = ~c; + d = -d; + } + + w = __udivmodti4 (n, d, (UTItype *)0); + if (c) + w = -w; + return w; +} + +TItype +__modti3 (TItype n, TItype d) +{ + int c = 0; + TItype w; + + if (n < 0) + { + c = ~c; + n = -n; + } + if (d < 0) + { + c = ~c; + d = -d; + } + + __udivmodti4 (n, d, (UTItype *) &w); + if (c) + w = -w; + return w; +} diff --git a/gcc/config/spu/multi3.c b/gcc/config/spu/multi3.c new file mode 100644 index 00000000000..6998ed026f8 --- /dev/null +++ b/gcc/config/spu/multi3.c @@ -0,0 +1,99 @@ +/* Copyright (C) 2008 Free Software Foundation, Inc. + + This file is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2 of the License, or (at your option) + any later version. + + This file is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with this file; see the file COPYING. If not, write to the Free + Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA + 02110-1301, USA. */ + +/* As a special exception, if you link this library with files compiled with + GCC to produce an executable, this does not cause the resulting executable + to be covered by the GNU General Public License. The exception does not + however invalidate any other reasons why the executable file might be covered + by the GNU General Public License. */ + +#include <spu_intrinsics.h> + +typedef int TItype __attribute__ ((mode (TI))); + +/* A straight forward vectorization and unrolling of + * short l[8], r[8]; + * TItype total = 0; + * for (i = 0; i < 8; i++) + * for (j = 0; j < 8; j++) + * total += (TItype)((l[7-i] * r[7-j]) << (16 * (i + j))); + */ +TItype +__multi3 (TItype l, TItype r) +{ + qword u = *(qword *) & l; + qword v = *(qword *) & r; + qword splat0 = si_shufb (v, v, si_ilh (0x0001)); + qword splat1 = si_shufb (v, v, si_ilh (0x0203)); + qword splat2 = si_shufb (v, v, si_ilh (0x0405)); + qword splat3 = si_shufb (v, v, si_ilh (0x0607)); + qword splat4 = si_shufb (v, v, si_ilh (0x0809)); + qword splat5 = si_shufb (v, v, si_ilh (0x0a0b)); + qword splat6 = si_shufb (v, v, si_ilh (0x0c0d)); + qword splat7 = si_shufb (v, v, si_ilh (0x0e0f)); + + qword part0l = si_shlqbyi (si_mpyu (u, splat0), 14); + qword part1h = si_shlqbyi (si_mpyhhu (u, splat1), 14); + qword part1l = si_shlqbyi (si_mpyu (u, splat1), 12); + qword part2h = si_shlqbyi (si_mpyhhu (u, splat2), 12); + qword part2l = si_shlqbyi (si_mpyu (u, splat2), 10); + qword part3h = si_shlqbyi (si_mpyhhu (u, splat3), 10); + qword part3l = si_shlqbyi (si_mpyu (u, splat3), 8); + qword part4h = si_shlqbyi (si_mpyhhu (u, splat4), 8); + qword part4l = si_shlqbyi (si_mpyu (u, splat4), 6); + qword part5h = si_shlqbyi (si_mpyhhu (u, splat5), 6); + qword part5l = si_shlqbyi (si_mpyu (u, splat5), 4); + qword part6h = si_shlqbyi (si_mpyhhu (u, splat6), 4); + qword part6l = si_shlqbyi (si_mpyu (u, splat6), 2); + qword part7h = si_shlqbyi (si_mpyhhu (u, splat7), 2); + qword part7l = si_mpyu (u, splat7); + + qword carry, total0, total1, total2, total3, total4; + qword total5, total6, total7, total8, total9, total10; + qword total; + + total0 = si_a (si_a (si_a (part0l, part1h), si_a (part1l, part2h)), part7l); + total1 = si_a (part2l, part3h); + total2 = si_a (part3l, part4h); + total3 = si_a (part4l, part5h); + total4 = si_a (part5l, part6h); + total5 = si_a (part6l, part7h); + total6 = si_a (total0, total1); + total7 = si_a (total2, total3); + total8 = si_a (total4, total5); + total9 = si_a (total6, total7); + total10 = si_a (total8, total9); + + carry = si_cg (part2l, part3h); + carry = si_a (carry, si_cg (part3l, part4h)); + carry = si_a (carry, si_cg (part4l, part5h)); + carry = si_a (carry, si_cg (part5l, part6h)); + carry = si_a (carry, si_cg (part6l, part7h)); + carry = si_a (carry, si_cg (total0, total1)); + carry = si_a (carry, si_cg (total2, total3)); + carry = si_a (carry, si_cg (total4, total5)); + carry = si_a (carry, si_cg (total6, total7)); + carry = si_a (carry, si_cg (total8, total9)); + carry = si_shlqbyi (carry, 4); + + total = si_cg (total10, carry); + total = si_shlqbyi (total, 4); + total = si_cgx (total10, carry, total); + total = si_shlqbyi (total, 4); + total = si_addx (total10, carry, total); + return *(TItype *) & total; +} diff --git a/gcc/config/spu/spu.c b/gcc/config/spu/spu.c index 692a8dae34f..de307ab32ed 100644 --- a/gcc/config/spu/spu.c +++ b/gcc/config/spu/spu.c @@ -4422,6 +4422,13 @@ spu_init_libfuncs (void) set_conv_libfunc (ufloat_optab, DFmode, SImode, "__float_unssidf"); set_conv_libfunc (ufloat_optab, DFmode, DImode, "__float_unsdidf"); + + set_optab_libfunc (smul_optab, TImode, "__multi3"); + set_optab_libfunc (sdiv_optab, TImode, "__divti3"); + set_optab_libfunc (smod_optab, TImode, "__modti3"); + set_optab_libfunc (udiv_optab, TImode, "__udivti3"); + set_optab_libfunc (umod_optab, TImode, "__umodti3"); + set_optab_libfunc (udivmod_optab, TImode, "__udivmodti4"); } /* Make a subreg, stripping any existing subreg. We could possibly just @@ -4473,7 +4480,7 @@ spu_init_builtins (void) unsigned_V4SI_type_node = build_vector_type (unsigned_intSI_type_node, 4); unsigned_V2DI_type_node = build_vector_type (unsigned_intDI_type_node, 2); - spu_builtin_types[SPU_BTI_QUADWORD] = V16QI_type_node; + spu_builtin_types[SPU_BTI_QUADWORD] = intTI_type_node; spu_builtin_types[SPU_BTI_7] = global_trees[TI_INTSI_TYPE]; spu_builtin_types[SPU_BTI_S7] = global_trees[TI_INTSI_TYPE]; @@ -5368,7 +5375,8 @@ spu_expand_builtin_1 (struct spu_builtin_description *d, if (VECTOR_MODE_P (mode) && (GET_CODE (ops[i]) == CONST_INT || GET_MODE_CLASS (GET_MODE (ops[i])) == MODE_INT - || GET_MODE_CLASS (GET_MODE (ops[i])) == MODE_FLOAT)) + || GET_MODE_CLASS (GET_MODE (ops[i])) == MODE_FLOAT) + && d->parm[i] != SPU_BTI_QUADWORD) { if (GET_CODE (ops[i]) == CONST_INT) ops[i] = spu_const (mode, INTVAL (ops[i])); diff --git a/gcc/config/spu/t-spu-elf b/gcc/config/spu/t-spu-elf index b9550a3d082..ea9825ac497 100644 --- a/gcc/config/spu/t-spu-elf +++ b/gcc/config/spu/t-spu-elf @@ -29,7 +29,9 @@ LIB2FUNCS_STATIC_EXTRA = $(srcdir)/config/spu/float_unssidf.c \ $(srcdir)/config/spu/mfc_tag_reserve.c \ $(srcdir)/config/spu/mfc_tag_release.c \ $(srcdir)/config/spu/mfc_multi_tag_reserve.c \ - $(srcdir)/config/spu/mfc_multi_tag_release.c + $(srcdir)/config/spu/mfc_multi_tag_release.c \ + $(srcdir)/config/spu/multi3.c \ + $(srcdir)/config/spu/divmodti4.c LIB2ADDEH = $(srcdir)/unwind-dw2.c $(srcdir)/unwind-dw2-fde.c \ $(srcdir)/unwind-sjlj.c $(srcdir)/unwind-c.c diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 4b1c7dbc32c..f371d8ca0c3 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,15 @@ +2008-05-27 Michael Matz <matz@suse.de> + + PR c++/27975 + * call.c (build_new_op): Make warning conditional on + OPT_Wenum_compare. + +2008-05-27 Alexandre Oliva <aoliva@redhat.com> + + PR c++/35909 + * call.c (convert_like_real): Convert bitfield to desired type + before creating temporary. + 2008-05-26 Daniel Franke <franke.daniel@gmail.com> * Makefile.in: Adjusted dependencies on c-incpath.o. diff --git a/gcc/cp/call.c b/gcc/cp/call.c index b83ad3a2eef..0948c790c41 100644 --- a/gcc/cp/call.c +++ b/gcc/cp/call.c @@ -4004,7 +4004,8 @@ build_new_op (enum tree_code code, int flags, tree arg1, tree arg2, tree arg3, != TYPE_MAIN_VARIANT (TREE_TYPE (arg2))) && (complain & tf_warning)) { - warning (0, "comparison between %q#T and %q#T", + warning (OPT_Wenum_compare, + "comparison between %q#T and %q#T", TREE_TYPE (arg1), TREE_TYPE (arg2)); } break; @@ -4580,7 +4581,10 @@ convert_like_real (conversion *convs, tree expr, tree fn, int argnum, return error_mark_node; } if (lvalue & clk_bitfield) - expr = convert_bitfield_to_declared_type (expr); + { + expr = convert_bitfield_to_declared_type (expr); + expr = fold_convert (type, expr); + } expr = build_target_expr_with_type (expr, type); } diff --git a/gcc/defaults.h b/gcc/defaults.h index 392d22cfabb..3eecd8db81a 100644 --- a/gcc/defaults.h +++ b/gcc/defaults.h @@ -902,6 +902,10 @@ along with GCC; see the file COPYING3. If not see #define LEGITIMATE_PIC_OPERAND_P(X) 1 #endif +#ifndef TARGET_MEM_CONSTRAINT +#define TARGET_MEM_CONSTRAINT 'm' +#endif + #ifndef REVERSIBLE_CC_MODE #define REVERSIBLE_CC_MODE(MODE) 0 #endif diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index e3678177a80..a2665f3c3b3 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -232,7 +232,7 @@ Objective-C and Objective-C++ Dialects}. -Wchar-subscripts -Wclobbered -Wcomment @gol -Wconversion -Wcoverage-mismatch -Wno-deprecated @gol -Wno-deprecated-declarations -Wdisabled-optimization -Wno-div-by-zero @gol --Wempty-body -Wno-endif-labels @gol +-Wempty-body -Wenum-compare -Wno-endif-labels @gol -Werror -Werror=* @gol -Wfatal-errors -Wfloat-equal -Wformat -Wformat=2 @gol -Wno-format-contains-nul -Wno-format-extra-args -Wformat-nonliteral @gol @@ -3658,6 +3658,11 @@ while} statement. Additionally, in C++, warn when an empty body occurs in a @samp{while} or @samp{for} statement with no whitespacing before the semicolon. This warning is also enabled by @option{-Wextra}. +@item -Wenum-compare @r{(C++ and Objective-C++ only)} +@opindex Wenum-compare +@opindex Wno-enum-compare +Warn about a comparison between values of different enum types. + @item -Wsign-compare @opindex Wsign-compare @opindex Wno-sign-compare diff --git a/gcc/doc/md.texi b/gcc/doc/md.texi index a8e43ead2fd..05b1754b818 100644 --- a/gcc/doc/md.texi +++ b/gcc/doc/md.texi @@ -1050,6 +1050,7 @@ have. Constraints can also require two operands to match. * Multi-Alternative:: When an insn has two alternative constraint-patterns. * Class Preferences:: Constraints guide which hard register to put things in. * Modifiers:: More precise control over effects of constraints. +* Disable Insn Alternatives:: Disable insn alternatives using the @code{enabled} attribute. * Machine Constraints:: Existing constraints for some particular machines. * Define Constraints:: How to define machine-specific constraints. * C Constraint Interface:: How to test constraints from C code. @@ -1085,6 +1086,8 @@ number of constraints and modifiers. @item @samp{m} A memory operand is allowed, with any kind of address that the machine supports in general. +Note that the letter used for the general memory constraint can be +re-defined by a back end using the @code{TARGET_MEM_CONSTRAINT} macro. @cindex offsettable address @cindex @samp{o} in constraint @@ -3087,6 +3090,99 @@ Unsigned constant valid for BccUI instructions @end table @ifset INTERNALS +@node Disable Insn Alternatives +@subsection Disable insn alternatives using the @code{enabled} attribute +@cindex enabled + +The @code{enabled} insn attribute may be used to disable certain insn +alternatives for machine-specific reasons. This is useful when adding +new instructions to an existing pattern which are only available for +certain cpu architecture levels as specified with the @code{-march=} +option. + +If an insn alternative is disabled, then it will never be used. The +compiler treats the constraints for the disabled alternative as +unsatisfiable. + +In order to make use of the @code{enabled} attribute a back end has to add +in the machine description files: + +@enumerate +@item +A definition of the @code{enabled} insn attribute. The attribute is +defined as usual using the @code{define_attr} command. This +definition should be based on other insn attributes and/or target flags. +The @code{enabled} attribute is a numeric attribute and should evaluate to +@code{(const_int 1)} for an enabled alternative and to +@code{(const_int 0)} otherwise. +@item +A definition of another insn attribute used to describe for what +reason an insn alternative might be available or +not. E.g. @code{cpu_facility} as in the example below. +@item +An assignement for the second attribute to each insn definition +combining instructions which are not all available under the same +circumstances. (Note: It obviously only makes sense for definitions +with more than one alternative. Otherwise the insn pattern should be +disabled or enabled using the insn condition.) +@end enumerate + +E.g. the following two patterns could easily be merged using the @code{enabled} +attribute: + +@smallexample + +(define_insn "*movdi_old" + [(set (match_operand:DI 0 "register_operand" "=d") + (match_operand:DI 1 "register_operand" " d"))] + "!TARGET_NEW" + "lgr %0,%1") + +(define_insn "*movdi_new" + [(set (match_operand:DI 0 "register_operand" "=d,f,d") + (match_operand:DI 1 "register_operand" " d,d,f"))] + "TARGET_NEW" + "@@ + lgr %0,%1 + ldgr %0,%1 + lgdr %0,%1") + +@end smallexample + +to: + +@smallexample + +(define_insn "*movdi_combined" + [(set (match_operand:DI 0 "register_operand" "=d,f,d") + (match_operand:DI 1 "register_operand" " d,d,f"))] + "" + "@@ + lgr %0,%1 + ldgr %0,%1 + lgdr %0,%1" + [(set_attr "cpu_facility" "*,new,new")]) + +@end smallexample + +with the @code{enabled} attribute defined like this: + +@smallexample + +(define_attr "cpu_facility" "standard,new" (const_string "standard")) + +(define_attr "enabled" "" + (cond [(eq_attr "cpu_facility" "standard") (const_int 1) + (and (eq_attr "cpu_facility" "new") + (ne (symbol_ref "TARGET_NEW") (const_int 0))) + (const_int 1)] + (const_int 0))) + +@end smallexample + +@end ifset + +@ifset INTERNALS @node Define Constraints @subsection Defining Machine-Specific Constraints @cindex defining constraints @@ -6519,6 +6615,22 @@ If the attribute takes numeric values, no @code{enum} type will be defined and the function to obtain the attribute's value will return @code{int}. +There are attributes which are tied to a specific meaning. These +attributes are not free to use for other purposes: + +@table @code +@item length +The @code{length} attribute is used to calculate the length of emitted +code chunks. This is especially important when verifying branch +distances. @xref{Insn Lengths}. + +@item enabled +The @code{enabled} attribute can be defined to prevent certain +alternatives of an insn definition from being used during code +generation. @xref{Disable Insn Alternatives}. + +@end table + @end ifset @ifset INTERNALS @node Expressions diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi index eeb744bd60d..3e4d2b7b5bf 100644 --- a/gcc/doc/tm.texi +++ b/gcc/doc/tm.texi @@ -5315,6 +5315,17 @@ into the @code{symbol_ref}, and then check for it here. When you see a Format}. @end defmac +@defmac TARGET_MEM_CONSTRAINT +A single character to be used instead of the default @code{'m'} +character for general memory addresses. This defines the constraint +letter which matches the memory addresses accepted by +@code{GO_IF_LEGITIMATE_ADDRESS_P}. Define this macro if you want to +support new address formats in your back end without changing the +semantics of the @code{'m'} constraint. This is necessary in order to +preserve functionality of inline assembly constructs using the +@code{'m'} constraint. +@end defmac + @defmac FIND_BASE_TERM (@var{x}) A C expression to determine the base term of address @var{x}. This macro is used in only one place: `find_base_term' in alias.c. diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c index 145b8fefaef..2113410232c 100644 --- a/gcc/dwarf2out.c +++ b/gcc/dwarf2out.c @@ -315,6 +315,14 @@ static GTY(()) unsigned fde_table_in_use; fde_table. */ #define FDE_TABLE_INCREMENT 256 +/* Get the current fde_table entry we should use. */ + +static inline dw_fde_ref +current_fde (void) +{ + return fde_table_in_use ? &fde_table[fde_table_in_use - 1] : NULL; +} + /* A list of call frame insns for the CIE. */ static GTY(()) dw_cfi_ref cie_cfi_head; @@ -641,7 +649,9 @@ add_fde_cfi (const char *label, dw_cfi_ref cfi) { if (label) { - dw_fde_ref fde = &fde_table[fde_table_in_use - 1]; + dw_fde_ref fde = current_fde (); + + gcc_assert (fde != NULL); if (*label == 0) label = dwarf2out_cfi_label (); @@ -713,6 +723,7 @@ static void lookup_cfa (dw_cfa_location *loc) { dw_cfi_ref cfi; + dw_fde_ref fde; loc->reg = INVALID_REGNUM; loc->offset = 0; @@ -722,12 +733,10 @@ lookup_cfa (dw_cfa_location *loc) for (cfi = cie_cfi_head; cfi; cfi = cfi->dw_cfi_next) lookup_cfa_1 (cfi, loc); - if (fde_table_in_use) - { - dw_fde_ref fde = &fde_table[fde_table_in_use - 1]; - for (cfi = fde->dw_fde_cfi; cfi; cfi = cfi->dw_cfi_next) - lookup_cfa_1 (cfi, loc); - } + fde = current_fde (); + if (fde) + for (cfi = fde->dw_fde_cfi; cfi; cfi = cfi->dw_cfi_next) + lookup_cfa_1 (cfi, loc); } /* The current rule for calculating the DWARF2 canonical frame address. */ @@ -2686,7 +2695,8 @@ dwarf2out_end_epilogue (unsigned int line ATTRIBUTE_UNUSED, ASM_GENERATE_INTERNAL_LABEL (label, FUNC_END_LABEL, current_function_funcdef_no); ASM_OUTPUT_LABEL (asm_out_file, label); - fde = &fde_table[fde_table_in_use - 1]; + fde = current_fde (); + gcc_assert (fde != NULL); fde->dw_fde_end = xstrdup (label); } @@ -2739,11 +2749,10 @@ dwarf2out_note_section_used (void) void dwarf2out_switch_text_section (void) { - dw_fde_ref fde; + dw_fde_ref fde = current_fde (); - gcc_assert (cfun); + gcc_assert (cfun && fde); - fde = &fde_table[fde_table_in_use - 1]; fde->dw_fde_switched_sections = true; fde->dw_fde_hot_section_label = crtl->subsections.hot_section_label; fde->dw_fde_hot_section_end_label = crtl->subsections.hot_section_end_label; @@ -10985,7 +10994,8 @@ convert_cfa_to_fb_loc_list (HOST_WIDE_INT offset) dw_cfa_location last_cfa, next_cfa; const char *start_label, *last_label, *section; - fde = &fde_table[fde_table_in_use - 1]; + fde = current_fde (); + gcc_assert (fde != NULL); section = secname_for_decl (current_function_decl); list_tail = &list; diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9e4cb23583e..d879a4c4ec7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2008-05-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/36316 + * trans-array.c (gfc_set_loop_bounds_from_array_spec): + Add missing fold_convert. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + * fortran/cpp.c (cpp_define_builtins): Remove usage of TARGET_* macros, + added FIXME instead. + 2008-05-26 Daniel Franke <franke.daniel@gmail.com> PR fortran/18428 diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index 3260d26c49a..865e2efc79d 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -9,6 +9,7 @@ #include "options.h" #include "gfortran.h" +#include "tm_p.h" /* Target prototypes. */ #include "target.h" #include "toplev.h" #include "diagnostic.h" @@ -218,9 +219,18 @@ cpp_define_builtins (cpp_reader *pfile) # define builtin_define_std(TXT) # define builtin_assert(TXT) cpp_assert (pfile, TXT) + /* FIXME: Pandora's Box + Using the macros below results in multiple breakages: + - mingw will fail to compile this file as dependent macros + assume to be used in c-cppbuiltin.c only. Further, they use + flags only valid/defined in C (same as noted above). + [config/i386/mingw32.h, config/i386/cygming.h] + - other platforms (not as popular) break similarly + [grep for 'builtin_define_with_int_value' in gcc/config/] + TARGET_CPU_CPP_BUILTINS (); TARGET_OS_CPP_BUILTINS (); - TARGET_OBJFMT_CPP_BUILTINS (); + TARGET_OBJFMT_CPP_BUILTINS (); */ #undef builtin_define #undef builtin_define_std diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a691ad5ffef..bc6d13a7fa8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -472,14 +472,14 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); gfc_add_block_to_block (&se->pre, &tmpse.pre); gfc_add_block_to_block (&se->post, &tmpse.post); - lower = tmpse.expr; + lower = fold_convert (gfc_array_index_type, tmpse.expr); /* ...and the upper bound. */ gfc_init_se (&tmpse, NULL); gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); gfc_add_block_to_block (&se->pre, &tmpse.pre); gfc_add_block_to_block (&se->post, &tmpse.post); - upper = tmpse.expr; + upper = fold_convert (gfc_array_index_type, tmpse.expr); /* Set the upper bound of the loop to UPPER - LOWER. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); diff --git a/gcc/genoutput.c b/gcc/genoutput.c index ba7fd4c2462..be4fb00bc7c 100644 --- a/gcc/genoutput.c +++ b/gcc/genoutput.c @@ -1122,7 +1122,10 @@ note_constraint (rtx exp, int lineno) unsigned int namelen = strlen (name); struct constraint_data **iter, **slot, *new; - if (strchr (indep_constraints, name[0])) + /* The 'm' constraint is special here since that constraint letter + can be overridden by the back end by defining the + TARGET_MEM_CONSTRAINT macro. */ + if (strchr (indep_constraints, name[0]) && name[0] != 'm') { if (name[1] == '\0') message_with_line (lineno, "constraint letter '%s' cannot be " diff --git a/gcc/genpreds.c b/gcc/genpreds.c index bc20b16f70e..b292784247a 100644 --- a/gcc/genpreds.c +++ b/gcc/genpreds.c @@ -690,8 +690,11 @@ static struct constraint_data **last_constraint_ptr = &first_constraint; for (iter_ = first_constraint; iter_; iter_ = iter_->next_textual) /* These letters, and all names beginning with them, are reserved for - generic constraints. */ -static const char generic_constraint_letters[] = "EFVXgimnoprs"; + generic constraints. + The 'm' constraint is not mentioned here since that constraint + letter can be overridden by the back end by defining the + TARGET_MEM_CONSTRAINT macro. */ +static const char generic_constraint_letters[] = "EFVXginoprs"; /* Machine-independent code expects that constraints with these (initial) letters will allow only (a subset of all) CONST_INTs. */ diff --git a/gcc/ipa-inline.c b/gcc/ipa-inline.c index c3e58f33301..6ac851a5bc9 100644 --- a/gcc/ipa-inline.c +++ b/gcc/ipa-inline.c @@ -296,7 +296,7 @@ cgraph_mark_inline (struct cgraph_edge *edge) struct cgraph_node *what = edge->callee; struct cgraph_edge *e, *next; - gcc_assert (!CALL_CANNOT_INLINE_P (edge->call_stmt)); + gcc_assert (!CALL_STMT_CANNOT_INLINE_P (edge->call_stmt)); /* Look for all calls, mark them inline and clone recursively all inlined functions. */ for (e = what->callers; e; e = next) @@ -967,7 +967,7 @@ cgraph_decide_inlining_of_small_functions (void) else { struct cgraph_node *callee; - if (CALL_CANNOT_INLINE_P (edge->call_stmt) + if (CALL_STMT_CANNOT_INLINE_P (edge->call_stmt) || !cgraph_check_inline_limits (edge->caller, edge->callee, &edge->inline_failed, true)) { @@ -1093,7 +1093,7 @@ cgraph_decide_inlining (void) for (e = node->callers; e; e = next) { next = e->next_caller; - if (!e->inline_failed || CALL_CANNOT_INLINE_P (e->call_stmt)) + if (!e->inline_failed || CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) continue; if (cgraph_recursive_inlining_p (e->caller, e->callee, &e->inline_failed)) @@ -1134,7 +1134,7 @@ cgraph_decide_inlining (void) if (node->callers && !node->callers->next_caller && !node->needed && node->local.inlinable && node->callers->inline_failed - && !CALL_CANNOT_INLINE_P (node->callers->call_stmt) + && !CALL_STMT_CANNOT_INLINE_P (node->callers->call_stmt) && !DECL_EXTERNAL (node->decl) && !DECL_COMDAT (node->decl)) { if (dump_file) @@ -1297,7 +1297,7 @@ cgraph_decide_inlining_incrementally (struct cgraph_node *node, if (!e->callee->local.disregard_inline_limits && (mode != INLINE_ALL || !e->callee->local.inlinable)) continue; - if (CALL_CANNOT_INLINE_P (e->call_stmt)) + if (CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) continue; /* When the edge is already inlined, we just need to recurse into it in order to fully flatten the leaves. */ @@ -1399,7 +1399,7 @@ cgraph_decide_inlining_incrementally (struct cgraph_node *node, } if (!cgraph_check_inline_limits (node, e->callee, &e->inline_failed, false) - || CALL_CANNOT_INLINE_P (e->call_stmt)) + || CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) { if (dump_file) { diff --git a/gcc/postreload.c b/gcc/postreload.c index 7e40728e876..15a14f001c6 100644 --- a/gcc/postreload.c +++ b/gcc/postreload.c @@ -542,12 +542,12 @@ reload_cse_simplify_operands (rtx insn, rtx testreg) case '*': case '%': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - case 'm': case '<': case '>': case 'V': case 'o': + case '<': case '>': case 'V': case 'o': case 'E': case 'F': case 'G': case 'H': case 's': case 'i': case 'n': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': - case 'p': case 'X': + case 'p': case 'X': case TARGET_MEM_CONSTRAINT: /* These don't say anything we care about. */ break; diff --git a/gcc/recog.c b/gcc/recog.c index 9ede30f90fd..ee5837dc1ec 100644 --- a/gcc/recog.c +++ b/gcc/recog.c @@ -60,6 +60,14 @@ along with GCC; see the file COPYING3. If not see #endif #endif +#ifndef HAVE_ATTR_enabled +static inline bool +get_attr_enabled (rtx insn ATTRIBUTE_UNUSED) +{ + return true; +} +#endif + static void validate_replace_rtx_1 (rtx *, rtx, rtx, rtx); static void validate_replace_src_1 (rtx *, void *); static rtx split_insn (rtx); @@ -1543,7 +1551,7 @@ asm_operand_ok (rtx op, const char *constraint) result = 1; break; - case 'm': + case TARGET_MEM_CONSTRAINT: case 'V': /* non-offsettable */ if (memory_operand (op, VOIDmode)) result = 1; @@ -1920,11 +1928,9 @@ extract_insn (rtx insn) int noperands; rtx body = PATTERN (insn); - recog_data.insn = NULL; recog_data.n_operands = 0; recog_data.n_alternatives = 0; recog_data.n_dups = 0; - which_alternative = -1; switch (GET_CODE (body)) { @@ -2004,6 +2010,22 @@ extract_insn (rtx insn) : OP_IN); gcc_assert (recog_data.n_alternatives <= MAX_RECOG_ALTERNATIVES); + + if (INSN_CODE (insn) < 0) + for (i = 0; i < recog_data.n_alternatives; i++) + recog_data.alternative_enabled_p[i] = true; + else + { + recog_data.insn = insn; + for (i = 0; i < recog_data.n_alternatives; i++) + { + which_alternative = i; + recog_data.alternative_enabled_p[i] = get_attr_enabled (insn); + } + } + + recog_data.insn = NULL; + which_alternative = -1; } /* After calling extract_insn, you can use this function to extract some @@ -2033,6 +2055,12 @@ preprocess_constraints (void) op_alt[j].matches = -1; op_alt[j].matched = -1; + if (!recog_data.alternative_enabled_p[j]) + { + p = skip_alternative (p); + continue; + } + if (*p == '\0' || *p == ',') { op_alt[j].anything_ok = 1; @@ -2082,7 +2110,7 @@ preprocess_constraints (void) } continue; - case 'm': + case TARGET_MEM_CONSTRAINT: op_alt[j].memory_ok = 1; break; case '<': @@ -2202,6 +2230,17 @@ constrain_operands (int strict) int lose = 0; funny_match_index = 0; + if (!recog_data.alternative_enabled_p[which_alternative]) + { + int i; + + for (i = 0; i < recog_data.n_operands; i++) + constraints[i] = skip_alternative (constraints[i]); + + which_alternative++; + continue; + } + for (opno = 0; opno < recog_data.n_operands; opno++) { rtx op = recog_data.operand[opno]; @@ -2355,7 +2394,7 @@ constrain_operands (int strict) win = 1; break; - case 'm': + case TARGET_MEM_CONSTRAINT: /* Memory operands must be valid, to the extent required by STRICT. */ if (MEM_P (op)) diff --git a/gcc/recog.h b/gcc/recog.h index cdc438c8892..6a2a2caf1da 100644 --- a/gcc/recog.h +++ b/gcc/recog.h @@ -50,7 +50,8 @@ struct operand_alternative /* Nonzero if '&' was found in the constraint string. */ unsigned int earlyclobber:1; - /* Nonzero if 'm' was found in the constraint string. */ + /* Nonzero if TARGET_MEM_CONSTRAINT was found in the constraint + string. */ unsigned int memory_ok:1; /* Nonzero if 'o' was found in the constraint string. */ unsigned int offmem_ok:1; @@ -142,6 +143,19 @@ recog_memoized (rtx insn) } #endif +/* Skip chars until the next ',' or the end of the string. This is + useful to skip alternatives in a constraint string. */ +static inline const char * +skip_alternative (const char *p) +{ + const char *r = p; + while (*r != '\0' && *r != ',') + r++; + if (*r == ',') + r++; + return r; +} + /* Nonzero means volatile operands are recognized. */ extern int volatile_ok; @@ -201,6 +215,12 @@ struct recog_data /* The number of alternatives in the constraints for the insn. */ char n_alternatives; + /* Specifies whether an insn alternative is enabled using the + `enabled' attribute in the insn pattern definition. For back + ends not using the `enabled' attribute the array fields are + always set to `true' in expand_insn. */ + bool alternative_enabled_p [MAX_RECOG_ALTERNATIVES]; + /* In case we are caching, hold insn data was generated for. */ rtx insn; }; diff --git a/gcc/regclass.c b/gcc/regclass.c index 200f3eefa58..8b9e86b1411 100644 --- a/gcc/regclass.c +++ b/gcc/regclass.c @@ -1143,8 +1143,9 @@ record_operand_costs (rtx insn, struct costs *op_costs, record_address_regs (GET_MODE (recog_data.operand[i]), XEXP (recog_data.operand[i], 0), 0, MEM, SCRATCH, frequency * 2); - else if (constraints[i][0] == 'p' - || EXTRA_ADDRESS_CONSTRAINT (constraints[i][0], constraints[i])) + else if (recog_data.alternative_enabled_p[0] + && (constraints[i][0] == 'p' + || EXTRA_ADDRESS_CONSTRAINT (constraints[i][0], constraints[i]))) record_address_regs (VOIDmode, recog_data.operand[i], 0, ADDRESS, SCRATCH, frequency * 2); } @@ -1701,7 +1702,7 @@ record_reg_classes (int n_alts, int n_ops, rtx *ops, [(int) base_reg_class (VOIDmode, ADDRESS, SCRATCH)]; break; - case 'm': case 'o': case 'V': + case TARGET_MEM_CONSTRAINT: case 'o': case 'V': /* It doesn't seem worth distinguishing between offsettable and non-offsettable addresses here. */ allows_mem[i] = 1; @@ -1932,6 +1933,9 @@ record_reg_classes (int n_alts, int n_ops, rtx *ops, if (alt_fail) continue; + if (!recog_data.alternative_enabled_p[alt]) + continue; + /* Finally, update the costs with the information we've calculated about this alternative. */ diff --git a/gcc/reload.c b/gcc/reload.c index 0492ee8cc64..7472272d9c4 100644 --- a/gcc/reload.c +++ b/gcc/reload.c @@ -2523,7 +2523,7 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, int noperands; /* These start out as the constraints for the insn and they are chewed up as we consider alternatives. */ - char *constraints[MAX_RECOG_OPERANDS]; + const char *constraints[MAX_RECOG_OPERANDS]; /* These are the preferred classes for an operand, or NO_REGS if it isn't a register. */ enum reg_class preferred_class[MAX_RECOG_OPERANDS]; @@ -2630,7 +2630,8 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, memcpy (operand_mode, recog_data.operand_mode, noperands * sizeof (enum machine_mode)); - memcpy (constraints, recog_data.constraints, noperands * sizeof (char *)); + memcpy (constraints, recog_data.constraints, + noperands * sizeof (const char *)); commutative = -1; @@ -2641,8 +2642,9 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, for (i = 0; i < noperands; i++) { - char *p; + const char *p; int c; + char *end; substed_operand[i] = recog_data.operand[i]; p = constraints[i]; @@ -2686,7 +2688,8 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - c = strtoul (p - 1, &p, 10); + c = strtoul (p - 1, &end, 10); + p = end; operands_match[c][i] = operands_match_p (recog_data.operand[c], @@ -2914,11 +2917,21 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, a bad register class to only count 1/3 as much. */ int reject = 0; + if (!recog_data.alternative_enabled_p[this_alternative_number]) + { + int i; + + for (i = 0; i < recog_data.n_operands; i++) + constraints[i] = skip_alternative (constraints[i]); + + continue; + } + this_earlyclobber = 0; for (i = 0; i < noperands; i++) { - char *p = constraints[i]; + const char *p = constraints[i]; char *end; int len; int win = 0; @@ -3182,7 +3195,7 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, badop = 0; break; - case 'm': + case TARGET_MEM_CONSTRAINT: if (force_reload) break; if (MEM_P (operand) @@ -3717,7 +3730,7 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, address_reloaded[commutative + 1] = t; memcpy (constraints, recog_data.constraints, - noperands * sizeof (char *)); + noperands * sizeof (const char *)); goto try_swapped; } else @@ -4522,7 +4535,7 @@ alternative_allows_const_pool_ref (rtx mem, const char *constraint, int altnum) while (*constraint++ != ','); altnum--; } - /* Scan the requested alternative for 'm' or 'o'. + /* Scan the requested alternative for TARGET_MEM_CONSTRAINT or 'o'. If one of them is present, this alternative accepts the result of passing a constant-pool reference through find_reloads_toplev. @@ -4533,7 +4546,7 @@ alternative_allows_const_pool_ref (rtx mem, const char *constraint, int altnum) for (; (c = *constraint) && c != ',' && c != '#'; constraint += CONSTRAINT_LEN (c, constraint)) { - if (c == 'm' || c == 'o') + if (c == TARGET_MEM_CONSTRAINT || c == 'o') return true; #ifdef EXTRA_CONSTRAINT_STR if (EXTRA_MEMORY_CONSTRAINT (c, constraint) diff --git a/gcc/reload1.c b/gcc/reload1.c index 13b8e6f7ef0..51d3f4c4d19 100644 --- a/gcc/reload1.c +++ b/gcc/reload1.c @@ -1454,11 +1454,11 @@ maybe_fix_stack_asms (void) switch (c) { case '=': case '+': case '*': case '%': case '?': case '!': - case '0': case '1': case '2': case '3': case '4': case 'm': - case '<': case '>': case 'V': case 'o': case '&': case 'E': - case 'F': case 's': case 'i': case 'n': case 'X': case 'I': - case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': - case 'P': + case '0': case '1': case '2': case '3': case '4': case '<': + case '>': case 'V': case 'o': case '&': case 'E': case 'F': + case 's': case 'i': case 'n': case 'X': case 'I': case 'J': + case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': + case TARGET_MEM_CONSTRAINT: break; case 'p': diff --git a/gcc/stmt.c b/gcc/stmt.c index 4dba88196cf..57e8ad4db7e 100644 --- a/gcc/stmt.c +++ b/gcc/stmt.c @@ -363,7 +363,7 @@ parse_output_constraint (const char **constraint_p, int operand_num, } break; - case 'V': case 'm': case 'o': + case 'V': case TARGET_MEM_CONSTRAINT: case 'o': *allows_mem = true; break; @@ -462,7 +462,7 @@ parse_input_constraint (const char **constraint_p, int input_num, } break; - case 'V': case 'm': case 'o': + case 'V': case TARGET_MEM_CONSTRAINT: case 'o': *allows_mem = true; break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5f0d17b26ab..814970176cd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,80 @@ +2008-05-27 Andy Hutchinson <hutchinsonandy@aim.com> + + * gcc.dg/tree-ssa/data-dep-1.c: Skip test for avr-*-* too much code. + * gcc.dg/tree-ssa/ldist-3.c: Ditto. + * gcc.dg/tree-ssa/ldist-5.c: Ditto. + * gcc.dg/tree-ssa/ifc-20040816-2 .c: Adjust for int size < 4 bytes. + * gcc.dg/tree-ssa/pr32540-1.c: Ditto. + * gcc.dg/tree-ssa/pr32540-2.c: Ditto. + * gcc.dg/tree-ssa/ssa-lim-5.c: Ditto. + * gcc.dg/tree-ssa/pr23115.c: Adjust test for double size < 8 bytes. + +2008-05-27 H.J. Lu <hongjiu.lu@intel.com> + + PR target/35767 + PR target/35771 + * gcc.target/i386/pr35767-1.c: New. + * gcc.target/i386/pr35767-1d.c: Likewise. + * gcc.target/i386/pr35767-1i.c: Likewise. + * gcc.target/i386/pr35767-2.c: Likewise. + * gcc.target/i386/pr35767-2d.c: Likewise. + * gcc.target/i386/pr35767-2i.c: Likewise. + * gcc.target/i386/pr35767-3.c: Likewise. + * gcc.target/i386/pr35767-4.c: Likewise. + * gcc.target/i386/pr35767-5.c: Likewise. + +2008-05-27 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/assignment_3.f90: Add missing cleanup-modules. + +2008-05-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/36316 + * gfortran.dg/assignment_3.f90: New. + +2008-05-27 Richard Sandiford <rdsandiford@googlemail.com> + + * lib/fortran-torture.exp (get-fortran-torture-options): + New function, replacing old FORTRAN_TORTURE_OPTIONS code. + * gfortran.fortran-torture/compile/compile.exp: Use + [get-fortran-torture-options] instead of $FORTRAN_TORTURE_OPTIONS. + * gfortran.fortran-torture/execute/execute.exp: Likewise. + +2008-05-27 Michael Matz <matz@suse.de> + + PR c++/27975 + * g++.dg/warn/Wenum-compare.C: New testcase. + * g++.dg/warn/Wenum-compare-no.C: Ditto. + +2008-05-27 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36339 + * gcc.c-torture/execute/pr36339.c: New testcase. + * gcc.dg/tree-ssa/loadpre8.c: XFAIL. + +2008-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/pack9.ad[sb]: New test. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/sync1.ad[sb]: New test. + * gnat.dg/interface5.ad[sb]: New test. + +2008-05-27 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> + + * gcc.c-torture/compile/pr11832.c: XFAIL on (x86 && ilp32 && pic). + * gcc.c-torture/compile/pr33009.c: Likewise. + +2008-05-27 Alexandre Oliva <aoliva@redhat.com> + + PR c++/35909 + * g++.dg/conversion/bitfield9.C: New. + +2008-05-26 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/specs/array_no_def_init.ads: New test. + 2008-05-26 Kai Tietz <kai.tietz@onevision.com> * gcc-c.torture/execute/pr36321.c: New. diff --git a/gcc/testsuite/g++.dg/conversion/bitfield9.C b/gcc/testsuite/g++.dg/conversion/bitfield9.C new file mode 100644 index 00000000000..998dd4873c8 --- /dev/null +++ b/gcc/testsuite/g++.dg/conversion/bitfield9.C @@ -0,0 +1,17 @@ +// PR c++/35909 +// { dg-do compile } + +struct MidiCommand +{ + unsigned data1 : 8; +}; + +void g(const unsigned char &); +void h(const unsigned int &); + +void f(MidiCommand mc) +{ + g(mc.data1); + h(mc.data1); +} + diff --git a/gcc/testsuite/g++.dg/warn/Wenum-compare-no.C b/gcc/testsuite/g++.dg/warn/Wenum-compare-no.C new file mode 100644 index 00000000000..7dc27d3fe72 --- /dev/null +++ b/gcc/testsuite/g++.dg/warn/Wenum-compare-no.C @@ -0,0 +1,10 @@ +/* Test disabling -Wenum-compare (on by default). See PR27975. */ +/* { dg-do compile } */ +/* { dg-options "-Wno-enum-compare" } */ +enum E1 { a }; +enum E2 { b }; + +int foo (E1 e1, E2 e2) +{ + return e1 == e2; /* { dg-bogus "comparison between" } */ +} diff --git a/gcc/testsuite/g++.dg/warn/Wenum-compare.C b/gcc/testsuite/g++.dg/warn/Wenum-compare.C new file mode 100644 index 00000000000..f60080039fb --- /dev/null +++ b/gcc/testsuite/g++.dg/warn/Wenum-compare.C @@ -0,0 +1,10 @@ +/* Test that we get the -Wenum-compare by default. See PR27975. */ +/* { dg-do compile } */ +/* { dg-options "" } */ +enum E1 { a }; +enum E2 { b }; + +int foo (E1 e1, E2 e2) +{ + return e1 == e2; /* { dg-warning "comparison between" } */ +} diff --git a/gcc/testsuite/gcc.c-torture/compile/pr11832.c b/gcc/testsuite/gcc.c-torture/compile/pr11832.c index 4eba49f0645..88469ff6940 100644 --- a/gcc/testsuite/gcc.c-torture/compile/pr11832.c +++ b/gcc/testsuite/gcc.c-torture/compile/pr11832.c @@ -1,6 +1,8 @@ /* { dg-do compile } */ /* Currently ICEs for MIPS and PowerPC; see PR33642. */ /* { dg-xfail-if "PR33642" { mips*-*-* powerpc*-*-linux* } { "*" } { "" } } */ +/* Currently ICEs for (x86 && ilp32 && pic). */ +/* { dg-xfail-if "PR33642/36240" { { i?86-*-* x86_64-*-* } && { ilp32 && { ! nonpic } } } { "*" } { "" } } */ /* { dg-prune-output ".*internal compiler error.*" } /* { dg-options "-frtl-abstract-sequences" } */ diff --git a/gcc/testsuite/gcc.c-torture/compile/pr33009.c b/gcc/testsuite/gcc.c-torture/compile/pr33009.c index 811fdb5f844..79a4b62a3a6 100644 --- a/gcc/testsuite/gcc.c-torture/compile/pr33009.c +++ b/gcc/testsuite/gcc.c-torture/compile/pr33009.c @@ -1,6 +1,8 @@ /* { dg-do compile } */ /* Currently ICEs for MIPS and PowerPC; see PR33642. */ /* { dg-xfail-if "PR33642" { mips*-*-* powerpc*-*-linux* } { "*" } { "" } } */ +/* Currently ICEs for (x86 && ilp32 && pic). */ +/* { dg-xfail-if "PR33642/36240" { { i?86-*-* x86_64-*-* } && { ilp32 && { ! nonpic } } } { "*" } { "" } } */ /* { dg-prune-output ".*internal compiler error.*" } /* { dg-options "-frtl-abstract-sequences" } */ diff --git a/gcc/testsuite/gcc.c-torture/execute/pr36339.c b/gcc/testsuite/gcc.c-torture/execute/pr36339.c new file mode 100644 index 00000000000..c4f36ddcace --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr36339.c @@ -0,0 +1,32 @@ +extern void abort (void); + +typedef unsigned long my_uintptr_t; + +int check_a(my_uintptr_t tagged_ptr); + +int __attribute__((noinline)) try_a(my_uintptr_t x) +{ + my_uintptr_t heap[2]; + my_uintptr_t *hp = heap; + + hp[0] = x; + hp[1] = 0; + return check_a((my_uintptr_t)(void*)((char*)hp + 1)); +} + +int __attribute__((noinline)) check_a(my_uintptr_t tagged_ptr) +{ + my_uintptr_t *hp = (my_uintptr_t*)(void*)((char*)tagged_ptr - 1); + + if (hp[0] == 42 && hp[1] == 0) + return 0; + return -1; +} + +int main(void) +{ + if (try_a(42) < 0) + abort (); + return 0; +} + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c b/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c index b0225e13ebc..5eb71d9be9e 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c @@ -1,4 +1,5 @@ /* { dg-do compile } */ +/* { dg-skip-if "too much code for avr" { "avr-*-*" } { "*" } { "" } } */ /* { dg-options "-O2 -ftree-loop-linear -fdump-tree-ltrans-all" } */ int foo (int n, int m) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c index 49cca20857d..f37a4d3361a 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c @@ -11,7 +11,11 @@ void foo(const int * __restrict__ zr_in, { unsigned int pi; int tmp_r, tmp_i, tmp_k; +#if __SIZEOF_INT__ >= 4 for (pi = 0; pi < (512)*(512); pi++) { +#else + for (pi = 0; pi < (32)*(32); pi++) { +#endif int zr = zr_in[pi]; int zi = zi_in[pi]; int zk = zk_in[pi]; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c index 524fb4542b8..a76f36fb196 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c @@ -1,4 +1,5 @@ /* { dg-do compile } */ +/* { dg-skip-if "too much code for avr" { "avr-*-*" } { "*" } { "" } } */ /* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-all" } */ int loop1 (int k) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c index af74557024e..39b52607179 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c @@ -1,4 +1,5 @@ /* { dg-do compile } */ +/* { dg-skip-if "too much code for avr" { "avr-*-*" } { "*" } { "" } } */ /* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-all" } */ int loop1 (int k) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c b/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c index a4d2e50c461..6be2b3ec7fd 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c @@ -93,5 +93,5 @@ rewrite_add_phi_arguments (basic_block bb) get_reaching_def ((get_def_from_ptr (get_phi_result_ptr (phi)))->ssa_name.var); } } -/* { dg-final { scan-tree-dump-times "Eliminated: 1" 1 "pre"} } */ +/* { dg-final { scan-tree-dump-times "Eliminated: 1" 1 "pre" { xfail *-*-* } } } */ /* { dg-final { cleanup-tree-dump "pre" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c b/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c index 6a52aafb458..61408e47a80 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c @@ -12,9 +12,13 @@ int main() { long j; double R, n, x; - +#if __SIZEOF_DOUBLE__ >= 8 n = 1.e300; x = -1.e300; +#else + n = 1.e30; + x = -1.e30; +#endif for( j=0; j < 2; j++ ) { x = MAX2(x,p[j]); diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c index ce8e0ae824f..f5a444806a1 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c @@ -19,6 +19,7 @@ void acceptloop_th(int *t) { if (f()) options |= 0x1 << 13; if (f()) options |= 0x1 << 14; if (f()) options |= 0x1 << 15; +#if(__SIZEOF_INT__ >= 4) if (f()) options |= 0x1 << 16; if (f()) options |= 0x1 << 17; if (f()) options |= 0x1 << 18; @@ -30,5 +31,6 @@ void acceptloop_th(int *t) { if (f()) options |= 0x1 << 24; if (f()) options |= 0x1 << 25; if (f()) options |= 0x1 << 26; +#endif if (f()) *t = options; } diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c index 29a5e3c55d0..f7fa38de114 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c @@ -19,6 +19,7 @@ void acceptloop_th(int *t, int options) { if (f()) options |= 0x1 << 13; if (f()) options |= 0x1 << 14; if (f()) options |= 0x1 << 15; +#if(__SIZEOF_INT__ >= 4) if (f()) options |= 0x1 << 16; if (f()) options |= 0x1 << 17; if (f()) options |= 0x1 << 18; @@ -30,6 +31,8 @@ void acceptloop_th(int *t, int options) { if (f()) options |= 0x1 << 24; if (f()) options |= 0x1 << 25; if (f()) options |= 0x1 << 26; +#endif if (f()) *t = options; } + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c index 18ca905bf8e..4a428515dd9 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c @@ -13,10 +13,14 @@ void link_error(); int foo(struct BUF1 * p) { - int i = 0; +#if(__SIZEOF_INT__ >= 4) for (i = 0; i < 1024*1024; i++) +#else + for (i = 0; i < 128*128; i++) +#endif p->b1 = 1; + if (p->b1 != 1) link_error (); return 0; diff --git a/gcc/testsuite/gcc.target/i386/pr35767-1.c b/gcc/testsuite/gcc.target/i386/pr35767-1.c new file mode 100644 index 00000000000..5ed5b858866 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-1.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef struct { __m128 f __attribute__((packed)); } packed; + +__m128 __attribute__((noinline)) +foo (__m128 a1, __m128 a2, __m128 a3, __m128 a4, + __m128 a5, __m128 a6, __m128 a7, __m128 a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, packed y) +{ + return y.f; +} + +void +sse2_test (void) +{ + packed x; + __m128 y = { 0 }; + x.f = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x.f, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-1d.c b/gcc/testsuite/gcc.target/i386/pr35767-1d.c new file mode 100644 index 00000000000..cdf17fa61b3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-1d.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef struct { __m128d f __attribute__((packed)); } packed; + +__m128d __attribute__((noinline)) +foo (__m128d a1, __m128d a2, __m128d a3, __m128d a4, + __m128d a5, __m128d a6, __m128d a7, __m128d a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, packed y) +{ + return y.f; +} + +void +sse2_test (void) +{ + packed x; + __m128d y = { 0 }; + x.f = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x.f, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-1i.c b/gcc/testsuite/gcc.target/i386/pr35767-1i.c new file mode 100644 index 00000000000..188e8e737bd --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-1i.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef struct { __m128i f __attribute__((packed)); } packed; + +__m128i __attribute__((noinline)) +foo (__m128i a1, __m128i a2, __m128i a3, __m128i a4, + __m128i a5, __m128i a6, __m128i a7, __m128i a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, packed y) +{ + return y.f; +} + +void +sse2_test (void) +{ + packed x; + __m128i y = { 0 }; + x.f = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x.f, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-2.c b/gcc/testsuite/gcc.target/i386/pr35767-2.c new file mode 100644 index 00000000000..82062ff9ee7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-2.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef __m128 __attribute__((aligned(1))) unaligned; + +__m128 __attribute__((noinline)) +foo (__m128 a1, __m128 a2, __m128 a3, __m128 a4, + __m128 a5, __m128 a6, __m128 a7, __m128 a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + __m128 y = { 0 }; + x = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-2d.c b/gcc/testsuite/gcc.target/i386/pr35767-2d.c new file mode 100644 index 00000000000..ae96cd852d0 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-2d.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef __m128d __attribute__((aligned(1))) unaligned; + +__m128d __attribute__((noinline)) +foo (__m128d a1, __m128d a2, __m128d a3, __m128d a4, + __m128d a5, __m128d a6, __m128d a7, __m128d a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + __m128d y = { 0 }; + x = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-2i.c b/gcc/testsuite/gcc.target/i386/pr35767-2i.c new file mode 100644 index 00000000000..d241644b62b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-2i.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef __m128i __attribute__((aligned(1))) unaligned; + +__m128i __attribute__((noinline)) +foo (__m128i a1, __m128i a2, __m128i a3, __m128i a4, + __m128i a5, __m128i a6, __m128i a7, __m128i a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + __m128i y = { 0 }; + x = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-3.c b/gcc/testsuite/gcc.target/i386/pr35767-3.c new file mode 100644 index 00000000000..e7592ff7bcb --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-3.c @@ -0,0 +1,26 @@ +/* { dg-do run } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-O -msse2 -std=gnu99" } */ + +#include "sse2-check.h" + +typedef _Decimal128 unaligned __attribute__((aligned(1))); + +_Decimal128 __attribute__((noinline)) +foo (_Decimal128 a1, _Decimal128 a2, _Decimal128 a3, _Decimal128 a4, + _Decimal128 a5, _Decimal128 a6, _Decimal128 a7, _Decimal128 a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + _Decimal128 y = -1; + x = y; + y = foo (0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y))) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-4.c b/gcc/testsuite/gcc.target/i386/pr35767-4.c new file mode 100644 index 00000000000..e12f64ffe98 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-4.c @@ -0,0 +1,14 @@ +/* Test that we generate aligned load when memory is aligned. */ +/* { dg-do compile } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-O -march=x86-64 -mtune=generic -std=gnu99" } */ +/* { dg-final { scan-assembler-not "movdqu" } } */ +/* { dg-final { scan-assembler "movdqa" } } */ + +extern _Decimal128 foo (_Decimal128, _Decimal128, _Decimal128); + +void +bar (void) +{ + foo (0, 0, 0); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-5.c b/gcc/testsuite/gcc.target/i386/pr35767-5.c new file mode 100644 index 00000000000..4372d2e5746 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-5.c @@ -0,0 +1,17 @@ +/* Test that we generate aligned load when memory is aligned. */ +/* { dg-do compile } */ +/* { dg-options "-O -msse2 -mtune=generic" } */ +/* { dg-final { scan-assembler-not "movups" } } */ +/* { dg-final { scan-assembler "movaps" } } */ + +typedef float v4sf __attribute__ ((__vector_size__ (16))); + +extern void foo(v4sf, v4sf, v4sf, v4sf, v4sf, v4sf, v4sf, v4sf, v4sf); + +int test(void) +{ + v4sf x = { 0.0, 1.0, 2.0, 3.0 }; + + foo (x, x, x, x, x, x, x, x, x); + return 0; +} diff --git a/gcc/testsuite/gcc.target/spu/muldivti3.c b/gcc/testsuite/gcc.target/spu/muldivti3.c new file mode 100644 index 00000000000..0363e342075 --- /dev/null +++ b/gcc/testsuite/gcc.target/spu/muldivti3.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-options "-std=c99" } */ +#include <stdlib.h> +typedef unsigned int uqword __attribute__((mode(TI))); +typedef int qword __attribute__((mode(TI))); + +typedef union +{ + uqword uq; + qword q; + unsigned long long ull[2]; +} u; + +int main(void) +{ + uqword e, f; + qword g, h; + + e = 0x1111111111111111ULL; + f = 0xFULL; + g = 0x0000000000111100ULL; + h = 0x0000000000000000ULL; + + u m, n, o, p, q; + + m.ull[0] = f; + m.ull[1] = e; + n.ull[0] = h; + n.ull[1] = g; + + /* __multi3 */ + o.q = m.q * n.q; + + o.q = o.q + n.q + 0x1110FF; + /* __udivti3, __umodti3 */ + p.uq = o.uq / n.uq; + q.uq = o.uq % n.uq; + if (p.uq != (m.uq+1)) abort(); + if (q.uq != 0x1110FF) abort(); + /* __divti3, __modti3 */ + p.q = -o.q / n.q; + q.q = -o.q % n.q; + if ((-p.q * n.q - q.q) != o.q) abort(); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/assignment_3.f90 b/gcc/testsuite/gfortran.dg/assignment_3.f90 new file mode 100644 index 00000000000..cdaaa8c5a4f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assignment_3.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! PR fortran/36316 +! +! gfortran generated a mismatching tree ("type mismatch in binary expression") +! for array bounds (mixing integer kind=4/kind=8 without fold_convert). +! +MODULE YOMCAIN + +IMPLICIT NONE +SAVE + +TYPE distributed_vector +REAL, pointer :: local(:) +INTEGER(4) :: global_length,local_start +INTEGER(8) :: local_end +END TYPE distributed_vector + +INTERFACE ASSIGNMENT (=) +MODULE PROCEDURE assign_ar_dv +END INTERFACE + +INTERFACE OPERATOR (*) +MODULE PROCEDURE multiply_dv_dv +END INTERFACE + +CONTAINS + +SUBROUTINE assign_ar_dv (handle,pvec) + +! copy array to the distributed_vector + +REAL, INTENT(IN) :: pvec(:) +TYPE (distributed_vector), INTENT(INOUT) :: handle + +handle%local(:) = pvec(:) + +RETURN +END SUBROUTINE assign_ar_dv + +FUNCTION multiply_dv_dv (handle1,handle2) + +! multiply two distributed_vectors + +TYPE (distributed_vector), INTENT(IN) :: handle2 +TYPE (distributed_vector), INTENT(IN) :: handle1 +REAL :: multiply_dv_dv(handle1%local_start:handle1%local_end) + +multiply_dv_dv = handle1%local(:) * handle2%local(:) + +RETURN +END FUNCTION multiply_dv_dv + + +SUBROUTINE CAININAD_SCALE_DISTVEC () +TYPE (distributed_vector) :: PVAZG +TYPE (distributed_vector) :: ZTEMP +TYPE (distributed_vector) :: SCALP_DV + +ZTEMP = PVAZG * SCALP_DV +END SUBROUTINE CAININAD_SCALE_DISTVEC +END MODULE YOMCAIN + +! { dg-final { cleanup-modules "yomcain" } } diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 index 995fd806a96..4b0bce779db 100644 --- a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 +++ b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 @@ -58,4 +58,4 @@ PROGRAM test WRITE (*,*) ispriv_t (5) ! { dg-error "has no IMPLICIT type" } END PROGRAM test -! { dg-final { cleanup-modules privmod } } +! { dg-final { cleanup-modules "privmod" } } diff --git a/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp b/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp index b18e25c5f6f..6c4890d7b72 100644 --- a/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp +++ b/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp @@ -26,7 +26,7 @@ load_lib fortran-torture.exp load_lib torture-options.exp torture-init -set-torture-options $FORTRAN_TORTURE_OPTIONS +set-torture-options [get-fortran-torture-options] foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] { # If we're only testing specific files and this isn't one of them, skip it. diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp b/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp index 157c2404601..2dd408df2d6 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp +++ b/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp @@ -30,7 +30,7 @@ load_lib fortran-torture.exp load_lib torture-options.exp torture-init -set-torture-options $FORTRAN_TORTURE_OPTIONS +set-torture-options [get-fortran-torture-options] foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] { # If we're only testing specific files and this isn't one of them, skip it. diff --git a/gcc/testsuite/gnat.dg/interface5.adb b/gcc/testsuite/gnat.dg/interface5.adb new file mode 100644 index 00000000000..80d240a9fcf --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface5.adb @@ -0,0 +1,7 @@ +-- { dg-do compile } +package body interface5 is + function F (Object : Child) return access Child is + begin + return null; + end F; +end interface5; diff --git a/gcc/testsuite/gnat.dg/interface5.ads b/gcc/testsuite/gnat.dg/interface5.ads new file mode 100644 index 00000000000..e1bd0bac2a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface5.ads @@ -0,0 +1,9 @@ +package interface5 is + type B is tagged null record; + + type I is interface; + function F (Object : I) return access I is abstract; + + type Child is new B and I with null record; + function F (Object : Child) return access Child; +end interface5; diff --git a/gcc/testsuite/gnat.dg/pack9.adb b/gcc/testsuite/gnat.dg/pack9.adb new file mode 100644 index 00000000000..894ecd6bb06 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack9.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -cargs --param sra-max-structure-size=24 --param sra-max-structure-count=6 -fdump-tree-final_cleanup" } + +package body Pack9 is + + procedure Copy (X, Y : R2_Ptr) is + T : R2 := Y.all; + begin + if T.I2 /= Y.I2 then + raise Program_Error; + end if; + X.all := T; + end; + +end Pack9; + +-- { dg-final { scan-tree-dump-not "__gnat_rcheck" "final_cleanup" } } +-- { dg-final { cleanup-tree-dump "final_cleanup" } } diff --git a/gcc/testsuite/gnat.dg/pack9.ads b/gcc/testsuite/gnat.dg/pack9.ads new file mode 100644 index 00000000000..00202a97fa9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack9.ads @@ -0,0 +1,18 @@ +package Pack9 is + + type R1 is record + I : Integer; + C : Character; + end record; + + type R2 is record + I1, I2 : Integer; + A : R1; + end record; + pragma Pack(R2); + + type R2_Ptr is access all R2; + + procedure Copy (X, Y : R2_Ptr); + +end Pack9; diff --git a/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads b/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads new file mode 100644 index 00000000000..b7a024d6fd6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +pragma Restrictions (No_Default_Initialization); +package Array_No_Def_Init is + + type Int_Array is array (Natural range <>) of Integer; + IA : Int_Array (1 .. 10); + +end Array_No_Def_Init; diff --git a/gcc/testsuite/gnat.dg/sync1.adb b/gcc/testsuite/gnat.dg/sync1.adb new file mode 100644 index 00000000000..08be6395d68 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync1.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +package body sync1 is + protected body Chopstick is + + entry Pick_Up when not Busy is + begin + Busy := True; + end Pick_Up; + + procedure Put_Down is + begin + Busy := False; + end Put_Down; + end Chopstick; +end sync1; diff --git a/gcc/testsuite/gnat.dg/sync1.ads b/gcc/testsuite/gnat.dg/sync1.ads new file mode 100644 index 00000000000..81c2f4aabeb --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync1.ads @@ -0,0 +1,12 @@ +package sync1 is + type Chopstick_Type is synchronized interface; + + type Chopstick is new Chopstick_Type with private; +private + protected type Chopstick is new Chopstick_Type with + entry Pick_Up; + procedure Put_Down; + private + Busy : Boolean := False; + end Chopstick; +end sync1; diff --git a/gcc/testsuite/lib/fortran-torture.exp b/gcc/testsuite/lib/fortran-torture.exp index 3286ad91e8a..6e49fac834c 100644 --- a/gcc/testsuite/lib/fortran-torture.exp +++ b/gcc/testsuite/lib/fortran-torture.exp @@ -22,12 +22,16 @@ load_lib target-supports.exp +# Return the list of options to use for fortran torture tests. # The default option list can be overridden by # TORTURE_OPTIONS="{ { list1 } ... { listN } }" +proc get-fortran-torture-options { } { + global TORTURE_OPTIONS + + if [info exists TORTURE_OPTIONS] { + return $TORTURE_OPTIONS + } -if [info exists TORTURE_OPTIONS] { - set FORTRAN_TORTURE_OPTIONS $TORTURE_OPTIONS -} else { # determine if host supports vectorization, and the necessary set # of options, based on code from testsuite/vect/vect.exp @@ -61,17 +65,22 @@ if [info exists TORTURE_OPTIONS] { set test_tree_vectorize 0 } - set FORTRAN_TORTURE_OPTIONS [list \ - { -O0 } { -O1 } { -O2 } \ + set options {} + + lappend options \ + { -O0 } \ + { -O1 } \ + { -O2 } \ { -O2 -fomit-frame-pointer -finline-functions } \ { -O2 -fomit-frame-pointer -finline-functions -funroll-loops } \ { -O2 -fbounds-check } \ { -O3 -g } \ - { -Os }] - + { -Os } if { $test_tree_vectorize } { - lappend FORTRAN_TORTURE_OPTIONS $vectorizer_options + lappend options $vectorizer_options } + + return $options } diff --git a/gcc/tree-gimple.c b/gcc/tree-gimple.c index da84777725a..2334e126343 100644 --- a/gcc/tree-gimple.c +++ b/gcc/tree-gimple.c @@ -113,13 +113,8 @@ bool is_gimple_mem_rhs (tree t) { /* If we're dealing with a renamable type, either source or dest must be - a renamed variable. Also force a temporary if the type doesn't need - to be stored in memory, since it's cheap and prevents erroneous - tailcalls (PR 17526). */ - if (is_gimple_reg_type (TREE_TYPE (t)) - || (TYPE_MODE (TREE_TYPE (t)) != BLKmode - && (TREE_CODE (t) != CALL_EXPR - || ! aggregate_value_p (t, t)))) + a renamed variable. */ + if (is_gimple_reg_type (TREE_TYPE (t))) return is_gimple_val (t); else return is_gimple_formal_tmp_rhs (t); diff --git a/gcc/tree-gimple.h b/gcc/tree-gimple.h index 2c4aa2d9379..3864d5d9d3e 100644 --- a/gcc/tree-gimple.h +++ b/gcc/tree-gimple.h @@ -96,6 +96,9 @@ extern bool is_gimple_non_addressable (tree t); extern bool is_gimple_call_addr (tree); /* If T makes a function call, returns the CALL_EXPR operand. */ extern tree get_call_expr_in (tree t); +/* Returns true iff T contains a CALL_EXPR not suitable for inlining. */ +#define CALL_STMT_CANNOT_INLINE_P(T) \ + CALL_CANNOT_INLINE_P (get_call_expr_in (T)) extern void recalculate_side_effects (tree); diff --git a/gcc/tree-sra.c b/gcc/tree-sra.c index 9e15f928bf3..244219ffe79 100644 --- a/gcc/tree-sra.c +++ b/gcc/tree-sra.c @@ -268,6 +268,7 @@ sra_type_can_be_decomposed_p (tree type) { /* Reject incorrectly represented bit fields. */ if (DECL_BIT_FIELD (t) + && INTEGRAL_TYPE_P (TREE_TYPE (t)) && (tree_low_cst (DECL_SIZE (t), 1) != TYPE_PRECISION (TREE_TYPE (t)))) goto fail; diff --git a/gcc/tree-ssa-address.c b/gcc/tree-ssa-address.c index a5119d8c2bd..55d43a5e362 100644 --- a/gcc/tree-ssa-address.c +++ b/gcc/tree-ssa-address.c @@ -423,9 +423,13 @@ add_to_parts (struct mem_address *parts, tree elt) /* Add ELT to base. */ type = TREE_TYPE (parts->base); - parts->base = fold_build2 (POINTER_PLUS_EXPR, type, - parts->base, - fold_convert (sizetype, elt)); + if (POINTER_TYPE_P (type)) + parts->base = fold_build2 (POINTER_PLUS_EXPR, type, + parts->base, + fold_convert (sizetype, elt)); + else + parts->base = fold_build2 (PLUS_EXPR, type, + parts->base, elt); } /* Finds the most expensive multiplication in ADDR that can be diff --git a/gcc/tree-ssa-alias.c b/gcc/tree-ssa-alias.c index 7ce016b9096..983e321521d 100644 --- a/gcc/tree-ssa-alias.c +++ b/gcc/tree-ssa-alias.c @@ -571,6 +571,22 @@ set_initial_properties (struct alias_info *ai) mark_call_clobbered (alias, pi->escape_mask); } } + else if (pi->pt_anything) + { + bitmap_iterator bi; + unsigned int j; + + /* If we do not have the points-to set filled out we + still need to honor that this escaped pointer points + to anything. */ + EXECUTE_IF_SET_IN_BITMAP (gimple_addressable_vars (cfun), + 0, j, bi) + { + tree var = referenced_var (j); + if (!unmodifiable_var_p (var)) + mark_call_clobbered (var, pi->escape_mask); + } + } } /* If the name tag is call clobbered, so is the symbol tag diff --git a/gcc/tree-ssa-sccvn.c b/gcc/tree-ssa-sccvn.c index 86777c784f0..c4c13f96ded 100644 --- a/gcc/tree-ssa-sccvn.c +++ b/gcc/tree-ssa-sccvn.c @@ -1139,8 +1139,8 @@ defs_to_varying (tree stmt) return changed; } -static tree -try_to_simplify (tree stmt, tree rhs); +static bool expr_has_constants (tree expr); +static tree try_to_simplify (tree stmt, tree rhs); /* Visit a copy between LHS and RHS, return true if the value number changed. */ @@ -1245,6 +1245,7 @@ visit_reference_op_load (tree lhs, tree op, tree stmt) /* Initialize value-number information properly. */ VN_INFO_GET (result)->valnum = result; VN_INFO (result)->expr = val; + VN_INFO (result)->has_constants = expr_has_constants (val); VN_INFO (result)->needs_insertion = true; /* As all "inserted" statements are singleton SCCs, insert to the valid table. This is strictly needed to diff --git a/gcc/tree-tailcall.c b/gcc/tree-tailcall.c index 7481de59325..09a2eafe119 100644 --- a/gcc/tree-tailcall.c +++ b/gcc/tree-tailcall.c @@ -429,6 +429,20 @@ find_tail_calls (basic_block bb, struct tailcall **ret) return; } + /* If the LHS of our call is not just a simple register, we can't + transform this into a tail or sibling call. This situation happens, + in (e.g.) "*p = foo()" where foo returns a struct. In this case + we won't have a temporary here, but we need to carry out the side + effect anyway, so tailcall is impossible. + + ??? In some situations (when the struct is returned in memory via + invisible argument) we could deal with this, e.g. by passing 'p' + itself as that argument to foo, but it's too early to do this here, + and expand_call() will not handle it anyway. If it ever can, then + we need to revisit this here, to allow that situation. */ + if (ass_var && !is_gimple_reg (ass_var)) + return; + /* We found the call, check whether it is suitable. */ tail_recursion = false; func = get_callee_fndecl (call); diff --git a/gcc/tree.h b/gcc/tree.h index 6ac75e6e89a..014f9e93680 100644 --- a/gcc/tree.h +++ b/gcc/tree.h @@ -1249,7 +1249,7 @@ extern void omp_clause_range_check_failed (const_tree, const char *, int, (CASE_LABEL_EXPR_CHECK (NODE)->base.static_flag) /* Used to mark a CALL_EXPR as not suitable for inlining. */ -#define CALL_CANNOT_INLINE_P(NODE) ((NODE)->base.static_flag) +#define CALL_CANNOT_INLINE_P(NODE) (CALL_EXPR_CHECK (NODE)->base.static_flag) /* In an expr node (usually a conversion) this means the node was made implicitly and should not lead to any sort of warning. In a decl node, diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 6fae3e258df..1c023cfe827 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,23 @@ +2008-05-26 Paolo Carlini <paolo.carlini@oracle.com> + + * include/c_global/cmath (pow(float, int), pow(double, int), + pow(long double, int)): Do not define in C++0x mode, per DR 550. + * include/tr1_impl/cmath (pow): Do not bring in unconditionally + from namespace std. + * include/tr1/cmath (pow(double, double), pow(float, float), + pow(long double, long double), pow(_Tp, _Up)): Define. + * include/tr1/complex (pow): Do not bring in from namespace std. + (pow(const std::complex<_Tp>&, int), pow(const std::complex<_Tp>&, + const _Tp&), pow(const _Tp&, const std::complex<_Tp>&), + pow(const std::complex<_Tp>&, const std::complex<_Tp>&)): Define. + * include/tr1_impl/complex (pow(const std::complex<_Tp>&, + const _Up&), pow(const _Tp&, const std::complex<_Up>&), + pow(const std::complex<_Tp>&, const std::complex<_Up>&)): Always + define. + * doc/xml/manual/intro.xml: Add an entry for DR 550. + * testsuite/26_numerics/headers/cmath/dr550.cc: New. + * testsuite/tr1/8_c_compatibility/cmath/overloads.cc: Adjust. + 2008-05-25 Paolo Carlini <paolo.carlini@oracle.com> * include/std/tuple: Ifndef __GXX_EXPERIMENTAL_CXX0X__ just error out. diff --git a/libstdc++-v3/doc/xml/manual/intro.xml b/libstdc++-v3/doc/xml/manual/intro.xml index 55c48a6d1fc..1f6708dac9a 100644 --- a/libstdc++-v3/doc/xml/manual/intro.xml +++ b/libstdc++-v3/doc/xml/manual/intro.xml @@ -611,6 +611,12 @@ <listitem><para>Follow the straightforward proposed resolution. </para></listitem></varlistentry> + <varlistentry><term><ulink url="../ext/lwg-active.html#550">550</ulink>: + <emphasis>What should the return type of pow(float,int) be?</emphasis> + </term> + <listitem><para>In C++0x mode, remove the pow(float,int), etc., signatures. + </para></listitem></varlistentry> + <varlistentry><term><ulink url="../ext/lwg-defects.html#586">586</ulink>: <emphasis>string inserter not a formatted function</emphasis> </term> diff --git a/libstdc++-v3/include/c_global/cmath b/libstdc++-v3/include/c_global/cmath index 21e21507b08..dd26db1a718 100644 --- a/libstdc++-v3/include/c_global/cmath +++ b/libstdc++-v3/include/c_global/cmath @@ -367,7 +367,9 @@ _GLIBCXX_BEGIN_NAMESPACE(std) pow(long double __x, long double __y) { return __builtin_powl(__x, __y); } - // DR 550. +#ifndef __GXX_EXPERIMENTAL_CXX0X__ + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 550. What should the return type of pow(float,int) be? inline double pow(double __x, int __i) { return __builtin_powi(__x, __i); } @@ -379,6 +381,7 @@ _GLIBCXX_BEGIN_NAMESPACE(std) inline long double pow(long double __x, int __n) { return __builtin_powil(__x, __n); } +#endif template<typename _Tp, typename _Up> inline diff --git a/libstdc++-v3/include/tr1/cmath b/libstdc++-v3/include/tr1/cmath index 63e6a2e5fda..a9c5aecf018 100644 --- a/libstdc++-v3/include/tr1/cmath +++ b/libstdc++-v3/include/tr1/cmath @@ -56,6 +56,34 @@ # undef _GLIBCXX_INCLUDE_AS_TR1 #endif +namespace std +{ +namespace tr1 +{ + // DR 550. What should the return type of pow(float,int) be? + // NB: C++0x and TR1 != C++03. + inline double + pow(double __x, double __y) + { return std::pow(__x, __y); } + + inline float + pow(float __x, float __y) + { return std::pow(__x, __y); } + + inline long double + pow(long double __x, long double __y) + { return std::pow(__x, __y); } + + template<typename _Tp, typename _Up> + inline typename __gnu_cxx::__promote_2<_Tp, _Up>::__type + pow(_Tp __x, _Up __y) + { + typedef typename __gnu_cxx::__promote_2<_Tp, _Up>::__type __type; + return std::pow(__type(__x), __type(__y)); + } +} +} + #include <bits/stl_algobase.h> #include <limits> #include <tr1/type_traits> diff --git a/libstdc++-v3/include/tr1/complex b/libstdc++-v3/include/tr1/complex index 8d14681e955..b571a5982ed 100644 --- a/libstdc++-v3/include/tr1/complex +++ b/libstdc++-v3/include/tr1/complex @@ -75,9 +75,27 @@ namespace tr1 } using std::real; - using std::pow; + + template<typename _Tp> + inline std::complex<_Tp> + pow(const std::complex<_Tp>& __x, int __n) + { return std::pow(__x, __n); } + + template<typename _Tp> + inline std::complex<_Tp> + pow(const std::complex<_Tp>& __x, const _Tp& __y) + { return std::pow(__x, __y); } + + template<typename _Tp> + inline std::complex<_Tp> + pow(const _Tp& __x, const std::complex<_Tp>& __y) + { return std::pow(__x, __y); } + + template<typename _Tp> + inline std::complex<_Tp> + pow(const std::complex<_Tp>& __x, const std::complex<_Tp>& __y) + { return std::pow(__x, __y); } } } #endif // _GLIBCXX_TR1_COMPLEX - diff --git a/libstdc++-v3/include/tr1_impl/cmath b/libstdc++-v3/include/tr1_impl/cmath index afb05e2aa71..d969a8feada 100644 --- a/libstdc++-v3/include/tr1_impl/cmath +++ b/libstdc++-v3/include/tr1_impl/cmath @@ -763,7 +763,9 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 return nexttoward(__type(__x), __y); } - using std::pow; + // DR 550. What should the return type of pow(float,int) be? + // NB: C++0x and TR1 != C++03. + // using std::pow; inline float remainder(float __x, float __y) diff --git a/libstdc++-v3/include/tr1_impl/complex b/libstdc++-v3/include/tr1_impl/complex index 8b4f97401f6..46560deaa4b 100644 --- a/libstdc++-v3/include/tr1_impl/complex +++ b/libstdc++-v3/include/tr1_impl/complex @@ -301,12 +301,11 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 fabs(const std::complex<_Tp>& __z) { return std::abs(__z); } - + /// Additional overloads [8.1.9]. #if (defined(_GLIBCXX_INCLUDE_AS_CXX0X) \ || (defined(_GLIBCXX_INCLUDE_AS_TR1) \ && !defined(__GXX_EXPERIMENTAL_CXX0X__))) - /// Additional overloads [8.1.9]. template<typename _Tp> inline typename __gnu_cxx::__promote<_Tp>::__type arg(_Tp __x) @@ -338,6 +337,8 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 real(_Tp __x) { return __x; } +#endif + template<typename _Tp, typename _Up> inline std::complex<typename __gnu_cxx::__promote_2<_Tp, _Up>::__type> pow(const std::complex<_Tp>& __x, const _Up& __y) @@ -363,7 +364,5 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 std::complex<__type>(__y)); } -#endif - _GLIBCXX_END_NAMESPACE_TR1 } diff --git a/libstdc++-v3/testsuite/26_numerics/headers/cmath/dr550.cc b/libstdc++-v3/testsuite/26_numerics/headers/cmath/dr550.cc new file mode 100644 index 00000000000..b3a9ce0255d --- /dev/null +++ b/libstdc++-v3/testsuite/26_numerics/headers/cmath/dr550.cc @@ -0,0 +1,47 @@ +// { dg-options "-std=gnu++0x" } +// 2008-05-26 Paolo Carlini <paolo.carlini@oracle.com> +// +// Copyright (C) 2008 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free +// software; you can redistribute it and/or modify it under the +// terms of the GNU General Public License as published by the +// Free Software Foundation; either version 2, or (at your option) +// any later version. +// +// This library is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License along +// with this library; see the file COPYING. If not, write to the Free +// Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +// USA. + +#include <cmath> +#include <testsuite_hooks.h> +#include <testsuite_tr1.h> + +// DR 550. What should the return type of pow(float,int) be? +void test01() +{ + bool test __attribute__((unused)) = true; + using __gnu_test::check_ret_type; + + const int i1 = 1; + const float f1 = 1.0f; + const double d1 = 1.0; + const long double ld1 = 1.0l; + + check_ret_type<double>(std::pow(f1, i1)); + VERIFY( std::pow(f1, i1) == std::pow(double(f1), double(i1)) ); + check_ret_type<double>(std::pow(d1, i1)); + check_ret_type<long double>(std::pow(ld1, i1)); +} + +int main() +{ + test01(); + return 0; +} diff --git a/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc b/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc index e925340081e..fea560fc293 100644 --- a/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc +++ b/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc @@ -206,9 +206,7 @@ void test01() check_ret_type<long double>(std::tr1::pow(ld0, d0)); check_ret_type<double>(std::tr1::pow(i0, i0)); check_ret_type<double>(std::tr1::pow(d0, i0)); - // DR 550. - // check_ret_type<double>(std::tr1::pow(f0, i0)); - check_ret_type<float>(std::tr1::pow(f0, i0)); + check_ret_type<double>(std::tr1::pow(f0, i0)); check_ret_type<double>(std::tr1::remainder(d0, d0)); check_ret_type<double>(std::tr1::remainder(d0, f0)); |