diff options
Diffstat (limited to 'gcc/ada')
46 files changed, 991 insertions, 472 deletions
diff --git a/gcc/ada/3zsoccon.ads b/gcc/ada/3zsoccon.ads index ddf2485c4da..27dcb0c7a9e 100644 --- a/gcc/ada/3zsoccon.ads +++ b/gcc/ada/3zsoccon.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2004 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- -- @@ -150,9 +150,9 @@ package GNAT.Sockets.Constants is SO_LINGER : constant := 128; -- Defer close to flush data SO_ERROR : constant := 4103; -- Get/clear error status SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff --git a/gcc/ada/56tpopsp.adb b/gcc/ada/56tpopsp.adb index ade612c8387..2673d0e30b6 100644 --- a/gcc/ada/56tpopsp.adb +++ b/gcc/ada/56tpopsp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -104,7 +104,7 @@ package body Specific is -- If the key value is Null, then it is a non-Ada task. if Value /= System.Null_Address then - return To_Task_Id (Value); + return To_Task_ID (Value); else return Register_Foreign_Thread; end if; diff --git a/gcc/ada/5vtpopde.adb b/gcc/ada/5vtpopde.adb index 1e5c6ca3135..001507a07a2 100644 --- a/gcc/ada/5vtpopde.adb +++ b/gcc/ada/5vtpopde.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2004 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -84,8 +84,7 @@ package body System.Task_Primitives.Operations.DEC is procedure Interrupt_AST_Handler (ID : Address) is Result : Interfaces.C.int; - AST_Self_ID : Task_ID := To_Task_Id (ID); - + AST_Self_ID : Task_ID := To_Task_ID (ID); begin Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -122,8 +121,7 @@ package body System.Task_Primitives.Operations.DEC is procedure Starlet_AST_Handler (ID : Address) is Result : Interfaces.C.int; - AST_Self_ID : Task_ID := To_Task_Id (ID); - + AST_Self_ID : Task_ID := To_Task_ID (ID); begin AST_Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); @@ -136,6 +134,7 @@ package body System.Task_Primitives.Operations.DEC is procedure Task_Synch is Synch_Self_ID : constant Task_ID := Self; + begin if Single_Lock then Lock_RTS; diff --git a/gcc/ada/5ztpopsp.adb b/gcc/ada/5ztpopsp.adb index 6a69c38b511..02983287d2c 100644 --- a/gcc/ada/5ztpopsp.adb +++ b/gcc/ada/5ztpopsp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,7 +68,7 @@ package body Specific is function Self return Task_ID is begin - return To_Task_Id (ATCB_Key); + return To_Task_ID (ATCB_Key); end Self; end Specific; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dcb898c4684..1b923c69e19 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,203 @@ +2004-03-15 Jerome Guitton <guitton@act-europe.fr> + + * 3zsoccon.ads: Fix multicast options. + + * s-thread.ads: Move unchecked conversion from ATSD_Access to Address + in the spec. + +2004-03-15 Robert Dewar <dewar@gnat.com> + + * sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when + pragma used for a private type. + + * lib-xref.adb (Generate_Reference): Do not generate warning if + reference is in a different unit from the pragma Unreferenced. + + * 5vtpopde.adb: Minor reformatting + Fix casing of To_Task_ID + + * sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing + flag if we have an unchecked conversion to an access type in the same + unit. + +2004-03-15 Geert Bosch <bosch@gnat.com> + + * a-ngcoty.adb (Modulus): In alternate formula for large real or + imaginary parts, use Double precision throughout. + + * a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only + we want to be able to compile run-time with -gnata for testing, but + this may also be instantiated in user code that is compiled with -gnata. + +2004-03-15 Olivier Hainque <hainque@act-europe.fr> + + * s-stalib.ads (Exception_Code): New type, to represent Import/Export + codes. Having a separate type for this is useful to enforce consistency + throughout the various run-time units. + (Exception_Data): Use Exception_Code for Import_Code. + + * s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of + Natural and Integer in various places. + (Register_VMS_Exception): Use Base_Code_In to compute the exception code + with the severity bits masked off. + (Register_VMS_Exception): Handle the additional exception data pointer + argument. + + * raise.c (_GNAT_Exception structure): Remove the handled_by_others + component, now reflected by an exported accessor. + (is_handled_by): New routine to compute whether the propagated + occurrence matches some handler choice specification. Extracted out of + get_action_description_for, and expanded to take care of the VMS + specifities. + (get_action_description_for): Use is_handled_by instead of an explicit + complex condition to decide if the current choice at hand catches the + propagated occurrence. + + * raise.h (Exception_Code): New type for C. + + * rtsfind.ads (RE_Id, RE_Unit_Table): Add + System.Standard_Library.Exception_Code, to allow references from the + pragma import/export expander. + + * a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For): + New accessors to allow easy access to GNAT exception data + characteristics. + (GNAT_GCC_Exception record, Propagate_Exception): Get rid of the + redundant Handled_By_Others component, helper for the personality + routine which will now be able to call the appropriate exception data + accessor instead. + + * cstand.adb (Create_Standard): Adjust the type of the Import_Code + component of Standard_Exception_Type to be the closest possible to + Exception_Code in System.Standard_Library, that we cannot get at this + point. Expand a ??? comment to notify that this type node should + probably be rewritten later on. + + * exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the + registration call to include a pointer to the exception object in the + arguments. + + * init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In + instead of int and explicit bitmasks. + +2004-03-15 Vincent Celier <celier@gnat.com> + + * vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED + equivalent to /STATIC and /NOSTATIC equivalent to /SHARED. + + * a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no + longer needed now that it is in the spec of + System.Tasking.Task_Attributes. + + * adaint.h, adaint.c: (__gnat_create_output_file): New function + + * gnatcmd.adb: Fix bug introduced in previous rev: /= instead of = + + * g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function. + + * make.adb (Gnatmake): Do not check the executable suffix; it is being + taken care of in Scan_Make_Arg. + (Scan_Make_Arg): Add the executable suffix only if the argument + following -o, in canonical case, does not end with the executable + suffix. When in verbose mode and executable file name does not end + with executable suffix, output the executable name, in canonical case. + + * s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing + to avoid warnings when instantiating Ada.Task_Attributes. + Minor reformating. + + * mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries + in the correct order. + + * prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but + redirect standard output and error to a file for the invocation of the + compiler, then read the file. + + * prj-nmsc.adb (Find_Sources): Use the Display_Value for each + directory, instead of the Value. + (Find_Source_Dirs): Remove useless code & comments. + +2004-03-15 Ed Schonberg <schonberg@gnat.com> + + * exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a + tagged type is inherited, and the parent operation is not frozen yet, + force generation of a freeze node for the inherited operation, so the + corresponding dispatch entry is properly initialized. + (Make_Predefined_Primitive_Specs): Check that return type is Boolean + when looking for user-defined equality operation. + + * exp_ch4.adb (Expand_Composite_Equality): Check that return type is + boolean when locating primitive equality of tagged component. + + * exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a + bit-aligned field and the right-hand side a string literal, introduce + a temporary before expanding assignment into a loop. + + * exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for + priority in full, to ensure that any expanded subepxressions of it are + elaborated in the scope of the init_proc. + + * exp_prag.adb (Expand_Pragma_Import): Search for initialization call + after object declaration, skipping over code that may have been + generated for validity checks. + + * sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown + discriminants, ignore the known discriminants of its full view, if + any, to check legality. + + * sem_ch3.adb (Complete_Private_Subtype): Do not create constrained + component if type has unknown discriminants. + (Analyze_Private_Extension_Declaration): Discriminant constraint is + null if type has unknown discriminants. + + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference + for end label when present. + + * s-fileio.adb (Open): When called with a C_Stream, use given name for + temporary file, rather than an empty string. + +2004-03-15 Ed Falis <falis@gnat.com> + + * s-thread.adb: Removed, no longer used. + +2004-03-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> + + * decl.c (target.h): Now include. + (gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE + in new build_pointer_from_mode calls for non-fat/non-thin pointer. + (validate_size): For POINTER_TYPE, get smallest size permitted on + machine. + + * fe.h: Sort Einfo decls and add Set_Mechanism. + + * Makefile.in: (LIBGNAT_SRCS): Remove types.h. + (ada/decl.o): Depends on target.h. + + * trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use + FUNCTION_BOUNDARY; always use TYPE_ALIGN. + +2004-03-15 Thomas Quinot <quinot@act-europe.fr> + + * 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID. + + * exp_ch4.adb (Expand_N_Indexed_Component): Do not call + Insert_Dereference_Action when rewriting an implicit dereference into + an explicit one, this will be taken care of during expansion of the + explicit dereference. + (Expand_N_Slice): Same. Always do the rewriting, even for the case + of non-packed slices, since the dereference action generated by + expansion of the explicit dereference is needed in any case. + (Expand_N_Selected_Component): When rewriting an implicit dereference, + analyze and resolve the rewritten explicit dereference so it is seen + by the expander. + (Insert_Dereference_Action): This procedure is now called only for the + expansion of an N_Explcit_Dereference_Node. Do insert a check even for + dereferences that do not come from source (including explicit + dereferences resulting from rewriting implicit ones), but do not + recursively insert a check for the dereference nodes contained within + the check. + (Insert_Dereference_Action): Clarify and correct comment. + 2004-03-08 Paolo Bonzini <bonzini@gnu.org> PR ada/14131 diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 94d3c33d52d..3b0c016d624 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -1201,9 +1201,10 @@ ada/cuintp.o : ada/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ ada/elists.h ada/nlists.h ada/fe.h ada/gigi.h ada/decl.o : ada/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - flags.h toplev.h convert.h ada/ada.h ada/types.h ada/atree.h ada/nlists.h \ - ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/snames.h ada/namet.h \ - ada/stringt.h ada/repinfo.h ada/fe.h $(ADA_TREE_H) ada/gigi.h gt-ada-decl.h + flags.h toplev.h convert.h target.h ada/ada.h ada/types.h ada/atree.h \ + ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/snames.h \ + ada/namet.h ada/stringt.h ada/repinfo.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \ + gt-ada-decl.h ada/misc.o : ada/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ $(RTL_H) expr.h insn-codes.h insn-flags.h insn-config.h recog.h flags.h \ diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index f8df3945c92..48b16e45a0a 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1308,7 +1308,7 @@ endif # subdirectory and copied. LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \ errno.c exit.c cal.c ctrl_c.c \ - raise.h raise.c sysdep.c types.h aux-io.c init.c \ + raise.h raise.c sysdep.c aux-io.c init.c \ final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c \ $(EXTRA_LIBGNAT_SRCS) diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index 3d8e44c41d9..faa89a3744c 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -145,11 +145,6 @@ package body Exception_Propagation is -- routine to determine if the context it examines contains a -- handler for the exception beeing propagated. - Handled_By_Others : Boolean; - -- Is this exception handled by "when others" ? This is used by the - -- personality routine to determine if an "others" handler in the - -- context it examines may catch the exception beeing propagated. - N_Cleanups_To_Trigger : Integer; -- Number of cleanup only frames encountered in SEARCH phase. -- This is used to control the forced unwinding triggered when @@ -174,8 +169,7 @@ package body Exception_Propagation is function Remove (Top : EOA; - Excep : GNAT_GCC_Exception_Access) - return Boolean; + Excep : GNAT_GCC_Exception_Access) return Boolean; -- Remove Excep from the stack starting at Top. -- Return True if Excep was found and removed, false otherwise. @@ -195,8 +189,7 @@ package body Exception_Propagation is UW_Eclass : Exception_Class; UW_Exception : access GNAT_GCC_Exception; UW_Context : System.Address; - UW_Argument : System.Address) - return Unwind_Reason_Code; + UW_Argument : System.Address) return Unwind_Reason_Code; -- Hook called at each step of the forced unwinding we perform to -- trigger cleanups found during the propagation of an unhandled -- exception. @@ -215,14 +208,32 @@ package body Exception_Propagation is UW_Argument : System.Address); pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + ------------------------------------------------------------ + -- Accessors to basic components of a GNAT exception data -- + ------------------------------------------------------------ + + -- As of today, these are only used by the C implementation of the + -- propagation personality routine to avoid having to rely on a C + -- counterpart of the whole exception_data structure, which is both + -- painful and error prone. These subprograms could be moved to a + -- more widely visible location if need be. + + function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean; + pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); + + function Language_For (E : Exception_Data_Ptr) return Character; + pragma Export (C, Language_For, "__gnat_language_for"); + + function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code; + pragma Export (C, Import_Code_For, "__gnat_import_code_for"); + ------------ -- Remove -- ------------ function Remove (Top : EOA; - Excep : GNAT_GCC_Exception_Access) - return Boolean + Excep : GNAT_GCC_Exception_Access) return Boolean is Prev : GNAT_GCC_Exception_Access := null; Iter : EOA := Top; @@ -285,8 +296,7 @@ package body Exception_Propagation is UW_Eclass : Exception_Class; UW_Exception : access GNAT_GCC_Exception; UW_Context : System.Address; - UW_Argument : System.Address) - return Unwind_Reason_Code + UW_Argument : System.Address) return Unwind_Reason_Code is begin -- Terminate as soon as we know there is nothing more to run. The @@ -401,7 +411,6 @@ package body Exception_Propagation is -- frame via Unwind_RaiseException below. GCC_Exception.Id := Excep.Id; - GCC_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others; GCC_Exception.N_Cleanups_To_Trigger := 0; -- Compute the backtrace for this occurrence if the corresponding @@ -459,6 +468,39 @@ package body Exception_Propagation is Unhandled_Exception_Terminate; end Propagate_Exception; + --------------------- + -- Import_Code_For -- + --------------------- + + function Import_Code_For + (E : SSL.Exception_Data_Ptr) return Exception_Code + is + begin + return E.all.Import_Code; + end Import_Code_For; + + -------------------------- + -- Is_Handled_By_Others -- + -------------------------- + + function Is_Handled_By_Others + (E : SSL.Exception_Data_Ptr) return Boolean + is + begin + return not E.all.Not_Handled_By_Others; + end Is_Handled_By_Others; + + ------------------ + -- Language_For -- + ------------------ + + function Language_For + (E : SSL.Exception_Data_Ptr) return Character + is + begin + return E.all.Lang; + end Language_For; + ----------- -- Notes -- ----------- diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb index c5b27699910..09a052b72e0 100644 --- a/gcc/ada/a-ngcoty.adb +++ b/gcc/ada/a-ngcoty.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -566,14 +566,18 @@ package body Ada.Numerics.Generic_Complex_Types is -- we can use an explicit comparison to determine whether to use -- the scaling expression. + -- The scaling expression is computed in double format throughout + -- in order to prevent inaccuracies on machines where not all + -- immediate expressions are rounded, such as PowerPC. + if Re2 > R'Last then raise Constraint_Error; end if; exception when Constraint_Error => - return abs (X.Re) - * R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2))); + return R (Double (abs (X.Re)) + * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); end; begin @@ -585,8 +589,8 @@ package body Ada.Numerics.Generic_Complex_Types is exception when Constraint_Error => - return abs (X.Im) - * R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2))); + return R (Double (abs (X.Im)) + * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); end; -- Now deal with cases of underflow. If only one of the squares @@ -606,12 +610,12 @@ package body Ada.Numerics.Generic_Complex_Types is else if abs (X.Re) > abs (X.Im) then return - abs (X.Re) - * R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2))); + R (Double (abs (X.Re)) + * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); else return - abs (X.Im) - * R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2))); + R (Double (abs (X.Im)) + * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); end if; end if; diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 92f9f7921bd..873b3870409 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +-- Copyright (C) 1995-2004, Ada Core Technologies -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -322,10 +322,6 @@ package body Ada.Task_Attributes is (Access_Node, Access_Address); -- To store pointer to list of indirect attributes - function To_Access_Node is new Unchecked_Conversion - (Access_Address, Access_Node); - -- To fetch pointer to list of indirect attributes - pragma Warnings (Off); function To_Access_Wrapper is new Unchecked_Conversion (Access_Dummy_Wrapper, Access_Wrapper); diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb index 52f8e706458..9e360386ef9 100644 --- a/gcc/ada/a-tifiio.adb +++ b/gcc/ada/a-tifiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -432,7 +432,6 @@ package body Ada.Text_IO.Fixed_IO is + Boolean'Pos (not Exact) * (Scale - 1); - procedure Put_Character (C : Character); pragma Inline (Put_Character); -- Add C to the output string To, updating Last @@ -550,7 +549,6 @@ package body Ada.Text_IO.Fixed_IO is E : Integer) is N : constant Natural := (A + Max_Digits - 1) / Max_Digits + 1; - pragma Debug (Put_Line ("N =" & N'Img)); Q : array (1 .. N) of Int64 := (others => 0); XX : Int64 := X; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 6c3f71a6dfc..c99c1f0fbec 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -616,6 +616,21 @@ __gnat_open_create (char *path, int fmode) } int +__gnat_create_output_file (char *path) +{ + int fd; +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM, + "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk", + "shr=del,get,put,upd"); +#else + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +int __gnat_open_append (char *path, int fmode) { int fd; diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 33c2bdcba95..bcfb453e221 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2003 Free Software Foundation, Inc. * + * Copyright (C) 1992-2004 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- * @@ -63,6 +63,7 @@ extern int __gnat_stat (char *, extern int __gnat_open_read (char *, int); extern int __gnat_open_rw (char *, int); extern int __gnat_open_create (char *, int); +extern int __gnat_create_output_file (char *); extern int __gnat_open_append (char *, int); extern long __gnat_file_length (int); extern void __gnat_tmp_name (char *); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 83e892fad80..7c133248c07 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1100,6 +1100,13 @@ package body CStand is -- Build standard exception type. Note that the type name here is -- actually used in the generated code, so it must be set correctly + -- ??? Also note that the Import_Code component is now declared + -- as a System.Standard_Library.Exception_Code to enforce run-time + -- library implementation consistency. It's too early here to resort + -- to rtsfind to get the proper node for that type, so we use the + -- closest possible available type node at hand instead. We should + -- probably be fixing this up at some point. + Standard_Exception_Type := New_Standard_Entity; Set_Ekind (Standard_Exception_Type, E_Record_Type); Set_Etype (Standard_Exception_Type, Standard_Exception_Type); @@ -1120,7 +1127,7 @@ package body CStand is "Full_Name"); Make_Component (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr"); - Make_Component (Standard_Exception_Type, Standard_Integer, + Make_Component (Standard_Exception_Type, Standard_Unsigned, "Import_Code"); Make_Component (Standard_Exception_Type, Standard_A_Char, "Raise_Hook"); diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index f7e55f3b509..8891f607b06 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -34,6 +34,7 @@ #include "convert.h" #include "ggc.h" #include "obstack.h" +#include "target.h" #include "ada.h" #include "types.h" @@ -2801,6 +2802,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) int got_fat_p = 0; int made_dummy = 0; tree gnu_desig_type = 0; + enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0); + + if (!targetm.valid_pointer_mode (p_mode)) + p_mode = ptr_mode; if (No (gnat_desig_full) && (Ekind (gnat_desig_type) == E_Class_Wide_Type @@ -2950,7 +2955,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } else if (gnat_desig_type == gnat_entity) { - gnu_type = build_pointer_type (make_node (VOID_TYPE)); + gnu_type = build_pointer_type_for_mode (make_node (VOID_TYPE), + p_mode); TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; } else @@ -3002,7 +3008,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } } - gnu_type = build_pointer_type (gnu_desig_type); + gnu_type = build_pointer_type_for_mode (gnu_desig_type, p_mode); } /* If we are not defining this object and we made a dummy pointer, @@ -5794,12 +5800,8 @@ compute_field_positions (tree gnu_type, it means that a size of zero should be treated as an unspecified size. */ static tree -validate_size (Uint uint_size, - tree gnu_type, - Entity_Id gnat_object, - enum tree_code kind, - int component_p, - int zero_ok) +validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, + enum tree_code kind, int component_p, int zero_ok) { Node_Id gnat_error_node; tree type_size @@ -5871,6 +5873,20 @@ validate_size (Uint uint_size, else if (TYPE_FAT_POINTER_P (gnu_type)) type_size = bitsize_int (POINTER_SIZE); + /* If this is an access type, the minimum size is that given by the smallest + integral mode that's valid for pointers. */ + if (TREE_CODE (gnu_type) == POINTER_TYPE) + { + enum machine_mode p_mode; + + for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT); + !targetm.valid_pointer_mode (p_mode); + p_mode = GET_MODE_WIDER_MODE (p_mode)) + ; + + type_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); + } + /* If the size of the object is a constant, the new size must not be smaller. */ if (TREE_CODE (type_size) != INTEGER_CST diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 92295eb8102..e6e42315eb2 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4184,23 +4184,35 @@ package body Exp_Ch3 is -- (usually the inherited primitive address is inserted in the -- DT by Inherit_DT) - if Is_CPP_Class (Etype (Def_Id)) then - declare - Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); - Subp : Entity_Id; + -- Similarly, if this is an inherited operation whose parent + -- is not frozen yet, it is not in the DT of the parent, and + -- we generate an explicit freeze node for the inherited + -- operation, so that it is properly inserted in the DT of the + -- current type. - begin - while Present (Elmt) loop - Subp := Node (Elmt); + declare + Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); + Subp : Entity_Id; + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Def_Id)) then + Set_Has_Delayed_Freeze (Subp); - if Present (Alias (Subp)) then + elsif Has_Delayed_Freeze (Alias (Subp)) + and then not Is_Frozen (Alias (Subp)) + then + Set_Is_Frozen (Subp, False); Set_Has_Delayed_Freeze (Subp); end if; + end if; - Next_Elmt (Elmt); - end loop; - end; - end if; + Next_Elmt (Elmt); + end loop; + end; if Underlying_Type (Etype (Def_Id)) = Def_Id then Expand_Tagged_Root (Def_Id); @@ -5275,6 +5287,7 @@ package body Exp_Ch3 is N_Subprogram_Renaming_Declaration) and then Etype (First_Formal (Node (Prim))) = Etype (Next_Formal (First_Formal (Node (Prim)))) + and then Base_Type (Etype (Node (Prim))) = Standard_Boolean then Eq_Needed := False; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b1764174e45..e1440f2ead6 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -154,8 +154,9 @@ package body Exp_Ch4 is -- local access type to have a usable finalization list. procedure Insert_Dereference_Action (N : Node_Id); - -- N is an expression whose type is an access. When the type is derived - -- from Checked_Pool, expands a call to the primitive 'dereference'. + -- N is an expression whose type is an access. When the type of the + -- associated storage pool is derived from Checked_Pool, generate a + -- call to the 'Dereference' primitive operation. function Make_Array_Comparison_Op (Typ : Entity_Id; @@ -1401,7 +1402,8 @@ package body Exp_Ch4 is Eq_Op := Node (Prim); exit when Chars (Eq_Op) = Name_Op_Eq and then Etype (First_Formal (Eq_Op)) = - Etype (Next_Formal (First_Formal (Eq_Op))); + Etype (Next_Formal (First_Formal (Eq_Op))) + and then Base_Type (Etype (Eq_Op)) = Standard_Boolean; Next_Elmt (Prim); pragma Assert (Present (Prim)); end loop; @@ -2968,12 +2970,6 @@ package body Exp_Ch4 is -- was necessary, but it cleans up the code to do it all the time. if Is_Access_Type (T) then - - -- Check whether the prefix comes from a debug pool, and generate - -- the check before rewriting. - - Insert_Dereference_Action (P); - Rewrite (P, Make_Explicit_Dereference (Sloc (N), Prefix => Relocate_Node (P))); @@ -5124,6 +5120,7 @@ package body Exp_Ch4 is if Is_Access_Type (Ptyp) then Insert_Explicit_Dereference (P); + Analyze_And_Resolve (P, Designated_Type (Ptyp)); if Ekind (Etype (P)) = E_Private_Subtype and then Is_For_Access_Subtype (Etype (P)) @@ -5396,23 +5393,13 @@ package body Exp_Ch4 is if Is_Access_Type (Ptp) then - -- Check for explicit dereference required for checked pool - - Insert_Dereference_Action (Pfx); - - -- If we have an access to a packed array type, then put in an - -- explicit dereference. We do this in case the slice must be - -- expanded, and we want to make sure we get an access check. - Ptp := Designated_Type (Ptp); - if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then - Rewrite (Pfx, - Make_Explicit_Dereference (Sloc (N), - Prefix => Relocate_Node (Pfx))); + Rewrite (Pfx, + Make_Explicit_Dereference (Sloc (N), + Prefix => Relocate_Node (Pfx))); - Analyze_And_Resolve (Pfx, Ptp); - end if; + Analyze_And_Resolve (Pfx, Ptp); end if; -- Range checks are potentially also needed for cases involving @@ -6532,6 +6519,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Pool : constant Entity_Id := Associated_Storage_Pool (Typ); + Pnod : constant Node_Id := Parent (N); function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; -- Return true if type of P is derived from Checked_Pool; @@ -6563,7 +6551,17 @@ package body Exp_Ch4 is -- Start of processing for Insert_Dereference_Action begin - if not Comes_From_Source (Parent (N)) then + pragma Assert (Nkind (Pnod) = N_Explicit_Dereference); + + -- Do not recursively add a dereference check for the + -- attribute references contained within the generated check. + + if not Comes_From_Source (Pnod) + and then Nkind (Pnod) = N_Explicit_Dereference + and then Nkind (Parent (Pnod)) = N_Attribute_Reference + and then (Attribute_Name (Parent (Pnod)) = Name_Size + or else Attribute_Name (Parent (Pnod)) = Name_Alignment) + then return; elsif not Is_Checked_Storage_Pool (Pool) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 0b35cefd6ca..a08cd1f145c 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -478,7 +478,29 @@ package body Exp_Ch5 is end if; end if; - -- Come here to compelete the analysis + -- If the right-hand side is a string literal, introduce a temporary + -- for it, for use in the generated loop that will follow. + + if Nkind (Rhs) = N_String_Literal then + declare + Temp : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_T); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (L_Type, Loc), + Expression => Relocate_Node (Rhs)); + + Insert_Action (N, Decl); + Rewrite (Rhs, New_Occurrence_Of (Temp, Loc)); + R_Type := Etype (Temp); + end; + end if; + + -- Come here to complete the analysis -- Loop_Required: Set to True if we know that a loop is required -- regardless of overlap considerations. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 62ed2af0c5d..0864da74696 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -7237,7 +7237,7 @@ package body Exp_Ch9 is Expr := Expression (Expr); end if; - Expr := New_Copy (Expr); + Expr := New_Copy_Tree (Expr); -- Add conversion to proper type to do range check if required -- Note that for runtime units, we allow out of range interrupt diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index f58ce1b5703..1ffbf5bc18c 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -272,7 +272,9 @@ package body Exp_Prag is -- When applied to a variable, the default initialization must not be -- done. As it is already done when the pragma is found, we just get rid -- of the call the initialization procedure which followed the object - -- declaration. + -- declaration. The call is inserted after the declaration, but validity + -- checks may also have been inserted and the initialization call does + -- not necessarily appear immediately after the object declaration. -- We can't use the freezing mechanism for this purpose, since we -- have to elaborate the initialization expression when it is first @@ -281,19 +283,27 @@ package body Exp_Prag is procedure Expand_Pragma_Import (N : Node_Id) is Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N))); Typ : Entity_Id; - After_Def : Node_Id; + Init_Call : Node_Id; begin if Ekind (Def_Id) = E_Variable then Typ := Etype (Def_Id); - After_Def := Next (Parent (Def_Id)); - if Has_Non_Null_Base_Init_Proc (Typ) - and then Nkind (After_Def) = N_Procedure_Call_Statement - and then Is_Entity_Name (Name (After_Def)) - and then Entity (Name (After_Def)) = Base_Init_Proc (Typ) - then - Remove (After_Def); + -- Loop to ??? + + Init_Call := Next (Parent (Def_Id)); + while Present (Init_Call) and then Init_Call /= N loop + if Has_Non_Null_Base_Init_Proc (Typ) + and then Nkind (Init_Call) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (Init_Call)) + and then Entity (Name (Init_Call)) = Base_Init_Proc (Typ) + then + Remove (Init_Call); + exit; + else + Next (Init_Call); + end if; + end loop; -- Any default initialization expression should be removed -- (e.g., null defaults for access objects, zero initialization @@ -301,7 +311,9 @@ package body Exp_Prag is -- have explicit initialization, so the expression must have -- been generated by the compiler. - elsif Present (Expression (Parent (Def_Id))) then + if No (Init_Call) + and then Present (Expression (Parent (Def_Id))) + then Set_Expression (Parent (Def_Id), Empty); end if; end if; @@ -391,7 +403,7 @@ package body Exp_Prag is Make_Object_Declaration (Loc, Defining_Identifier => Excep_Internal, Object_Definition => - New_Reference_To (Standard_Integer, Loc)); + New_Reference_To (RTE (RE_Exception_Code), Loc)); Insert_Action (N, Excep_Object); Analyze (Excep_Object); @@ -453,7 +465,7 @@ package body Exp_Prag is else Code := - Unchecked_Convert_To (Standard_Integer, + Unchecked_Convert_To (RTE (RE_Exception_Code), Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Import_Value), Loc), @@ -466,9 +478,14 @@ package body Exp_Prag is Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Register_VMS_Exception), Loc), - Parameter_Associations => New_List (Code))); - - Analyze_And_Resolve (Code, Standard_Integer); + Parameter_Associations => New_List ( + Code, + Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Id, Loc), + Attribute_Name => Name_Unrestricted_Access))))); + + Analyze_And_Resolve (Code, RTE (RE_Exception_Code)); Analyze (Call); end if; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 18b63471447..f3228dc0b3e 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -57,17 +57,19 @@ extern Boolean Debug_Flag_NN; Present_Expr for N_Variant nodes. */ #define Set_Alignment einfo__set_alignment -#define Set_Esize einfo__set_esize -#define Set_RM_Size einfo__set_rm_size #define Set_Component_Bit_Offset einfo__set_component_bit_offset #define Set_Component_Size einfo__set_component_size +#define Set_Esize einfo__set_esize +#define Set_Mechanism einfo__set_mechanism +#define Set_RM_Size einfo__set_rm_size #define Set_Present_Expr sinfo__set_present_expr extern void Set_Alignment (Entity_Id, Uint); +extern void Set_Component_Bit_Offset (Entity_Id, Uint); extern void Set_Component_Size (Entity_Id, Uint); extern void Set_Esize (Entity_Id, Uint); +extern void Set_Mechanism (Entity_Id, Mechanism_Type); extern void Set_RM_Size (Entity_Id, Uint); -extern void Set_Component_Bit_Offset (Entity_Id, Uint); extern void Set_Present_Expr (Node_Id, Uint); /* Test if the node N is the name of an entity (i.e. is an identifier, diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index d568d364a7a..7c321b64fef 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1995-2004 Ada Core Technologies, 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- -- @@ -660,6 +660,23 @@ package body GNAT.OS_Lib is return Create_New_File (C_Name (C_Name'First)'Address, Fmode); end Create_New_File; + ----------------------------- + -- Create_Output_Text_File -- + ----------------------------- + + function Create_Output_Text_File (Name : String) return File_Descriptor is + function C_Create_File + (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_Output_Text_File; + ---------------------- -- Create_Temp_File -- ---------------------- diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads index 8b317fdc2ca..6cd6b82f787 100644 --- a/gcc/ada/g-os_lib.ads +++ b/gcc/ada/g-os_lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2004 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- -- @@ -191,7 +191,12 @@ pragma Elaborate_Body (OS_Lib); Fmode : Mode) return File_Descriptor; -- Creates new file with given name for writing, returning file descriptor -- for subsequent use in Write calls. File descriptor returned is - -- Invalid_FD if file cannot be successfully created + -- Invalid_FD if file cannot be successfully created. + + function Create_Output_Text_File (Name : String) return File_Descriptor; + -- Creates new text file with given name suitable to redirect standard + -- output, returning file descriptor. File descriptor returned is + -- Invalid_FD if file cannot be successfully created. function Create_New_File (Name : String; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index f3ff3632c36..b793b48a7de 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -1338,7 +1338,7 @@ begin -- Check if there is at least one argument that is not a switch for Index in 1 .. Last_Switches.Last loop - if Last_Switches.Table (Index)(1) = '-' then + if Last_Switches.Table (Index)(1) /= '-' then Add_Sources := False; exit; end if; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 13b891d93ed..c3742563299 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1344,7 +1344,10 @@ extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */ extern struct Exception_Data Non_Ada_Error; #define Coded_Exception system__vms_exception_table__coded_exception -extern struct Exception_Data *Coded_Exception (int); +extern struct Exception_Data *Coded_Exception (Exception_Code); + +#define Base_Code_In system__vms_exception_table__base_code_in +extern Exception_Code Base_Code_In (Exception_Code); #endif /* Define macro symbols for the VMS conditions that become Ada exceptions. @@ -1374,6 +1377,8 @@ long __gnat_error_handler (int *sigargs, void *mechargs) { struct Exception_Data *exception = 0; + Exception_Code base_code; + char *msg = ""; char message[256]; long prvhnd; @@ -1410,8 +1415,11 @@ __gnat_error_handler (int *sigargs, void *mechargs) } #ifdef IN_RTS - /* See if it's an imported exception. Mask off severity bits. */ - exception = Coded_Exception (sigargs[1] & 0xfffffff8); + /* See if it's an imported exception. Beware that registered exceptions + are bound to their base code, with the severity bits masked off. */ + base_code = Base_Code_In ((Exception_Code) sigargs [1]); + exception = Coded_Exception (base_code); + if (exception) { msgdesc.len = 256; @@ -1424,7 +1432,7 @@ __gnat_error_handler (int *sigargs, void *mechargs) exception->Name_Length = 19; /* The full name really should be get sys$getmsg returns. ??? */ exception->Full_Name = "IMPORTED_EXCEPTION"; - exception->Import_Code = sigargs[1] & 0xfffffff8; + exception->Import_Code = base_code; } #endif diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 64ae4b7fcf1..200ad6a5730 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -275,10 +275,12 @@ package body Lib.Xref is Set_Referenced (E); end if; - -- Check for pragma Unreferenced given - - if Has_Pragma_Unreferenced (E) then + -- Check for pragma Unreferenced given and reference is within + -- this source unit (occasion for possible warning to be issued) + if Has_Pragma_Unreferenced (E) + and then In_Same_Extended_Unit (Sloc (E), Sloc (N)) + then -- A reference as a named parameter in a call does not count -- as a violation of pragma Unreferenced for this purpose. diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 9c0cd18985d..15d6ed01b3e 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -180,7 +180,6 @@ package body Make is Table_Name => "Make.Q"); -- This is the actual Q. - -- Package Mains is used to store the mains specified on the command line -- and to retrieve them when a project file is used, to verify that the -- files exist and that they belong to a project file. @@ -4345,39 +4344,6 @@ package body Make is Name_Len := Linker_Switches.Table (J + 1)'Length; Name_Buffer (1 .. Name_Len) := Linker_Switches.Table (J + 1).all; - - -- Put in canonical case to detect suffixs such as ".EXE" on - -- Windows or VMS. - - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - - -- If target has an executable suffix and it has not been - -- specified then it is added here. - - if Executable_Suffix'Length /= 0 - and then Name_Buffer - (Name_Len - Executable_Suffix'Length + 1 .. Name_Len) - /= Executable_Suffix - then - -- Get back the original name to keep the case on Windows - - Name_Buffer (1 .. Name_Len) := - Linker_Switches.Table (J + 1).all; - - -- Add the executable suffix - - Name_Buffer (Name_Len + 1 .. - Name_Len + Executable_Suffix'Length) := - Executable_Suffix; - Name_Len := Name_Len + Executable_Suffix'Length; - - else - -- Get back the original name to keep the case on Windows - - Name_Buffer (1 .. Name_Len) := - Linker_Switches.Table (J + 1).all; - end if; - Executable := Name_Enter; Verbose_Msg (Executable, "final executable"); @@ -6493,18 +6459,30 @@ package body Make is -- Automatically add the executable suffix if it has not been -- specified explicitly. - if Executable_Suffix'Length /= 0 - and then (Argv'Length <= Executable_Suffix'Length - or else Argv (Argv'Last - Executable_Suffix'Length + 1 - .. Argv'Last) /= Executable_Suffix) - then - Add_Switch - (Argv & Executable_Suffix, - Linker, - And_Save => And_Save); - else - Add_Switch (Argv, Linker, And_Save => And_Save); - end if; + declare + Canonical_Argv : String := Argv; + begin + -- Get the file name in canonical case to accept as is + -- names ending with ".EXE" on VMS and Windows. + + Canonical_Case_File_Name (Canonical_Argv); + + if Executable_Suffix'Length /= 0 + and then (Canonical_Argv'Length <= Executable_Suffix'Length + or else Canonical_Argv + (Canonical_Argv'Last - + Executable_Suffix'Length + 1 + .. Canonical_Argv'Last) + /= Executable_Suffix) + then + Add_Switch + (Argv & Executable_Suffix, + Linker, + And_Save => And_Save); + else + Add_Switch (Argv, Linker, And_Save => And_Save); + end if; + end; end if; -- If the previous switch has set the Object_Directory_Present flag diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 7c894e87775..4b82ffaef04 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -671,14 +671,9 @@ package body MLib.Prj is if not Processed_Projects.Get (Data.Name) then Processed_Projects.Set (Data.Name, True); - -- If it is a library project, add it to Library_Projs - - if Project /= For_Project and then Data.Library then - Library_Projs.Increment_Last; - Library_Projs.Table (Library_Projs.Last) := Project; - end if; - - -- Call Process_Project recursively for any imported project + -- Call Process_Project recursively for any imported project. + -- We first process the imported projects to guarantee that + -- we have a proper reverse order for the libraries. while Imported /= Empty_Project_List loop Element := Project_Lists.Table (Imported); @@ -689,69 +684,40 @@ package body MLib.Prj is Imported := Element.Next; end loop; + + -- If it is a library project, add it to Library_Projs + + if Project /= For_Project and then Data.Library then + Library_Projs.Increment_Last; + Library_Projs.Table (Library_Projs.Last) := Project; + end if; + end if; end Process_Project; -- Start of processing for Process_Imported_Libraries begin - -- Build list of library projects imported directly or indirectly + -- Build list of library projects imported directly or indirectly, + -- in the reverse order. Process_Project (For_Project); - -- If there are more that one library project file, make sure - -- that if libA depends on libB, libB is first in order. + -- Add the -L and -l switches and, if the Rpath option is supported, + -- add the directory to the Rpath. + -- As the library projects are in the wrong order, process from the + -- last to the first. - if Library_Projs.Last > 1 then - declare - Index : Integer := 1; - Proj1 : Project_Id; - Proj2 : Project_Id; - List : Project_List := Empty_Project_List; - - begin - Library_Loop : while Index < Library_Projs.Last loop - Proj1 := Library_Projs.Table (Index); - List := Projects.Table (Proj1).Imported_Projects; - - List_Loop : while List /= Empty_Project_List loop - Proj2 := Project_Lists.Table (List).Project; - - for J in Index + 1 .. Library_Projs.Last loop - if Proj2 = Library_Projs.Table (J) then - Library_Projs.Table (J) := Proj1; - Library_Projs.Table (Index) := Proj2; - exit List_Loop; - end if; - end loop; - - List := Project_Lists.Table (List).Next; - end loop List_Loop; - - if List = Empty_Project_List then - Index := Index + 1; - end if; - end loop Library_Loop; - end; - end if; - - -- Now that we have a correct order, add the -L and -l switches and, - -- if the Rpath option is supported, add the directory to the Rpath. - - for Index in 1 .. Library_Projs.Last loop + for Index in reverse 1 .. Library_Projs.Last loop Current := Library_Projs.Table (Index); + Get_Name_String (Projects.Table (Current).Library_Dir); Opts.Increment_Last; Opts.Table (Opts.Last) := - new String' - ("-L" & - Get_Name_String - (Projects.Table (Current).Library_Dir)); + new String'("-L" & Name_Buffer (1 .. Name_Len)); if Path_Option /= null then - Add_Rpath - (Get_Name_String - (Projects.Table (Current).Library_Dir)); + Add_Rpath (Name_Buffer (1 .. Name_Len)); end if; Opts.Increment_Last; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index efbbad2a0b8..dd16d034bcf 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2004 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- -- @@ -34,18 +34,26 @@ with Prj.Com; with Prj.Part; with Prj.PP; with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; with Snames; use Snames; with Table; use Table; with Ada.Characters.Handling; use Ada.Characters.Handling; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.Expect; use GNAT.Expect; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regexp; use GNAT.Regexp; -with GNAT.Regpat; use GNAT.Regpat; package body Prj.Makr is + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2); + + Gcc : constant String := "gcc"; + Gcc_Path : String_Access := null; + Non_Empty_Node : constant Project_Node_Id := 1; -- Used for the With_Clause of the naming project @@ -123,16 +131,7 @@ package body Prj.Makr is Source_List_FD : File_Descriptor; - Matcher : constant Pattern_Matcher := - Compile (Expression => "expected|Unit.*\)|No such"); - Args : Argument_List (1 .. Preproc_Switches'Length + 6); --- (1 => new String'("-c"), --- 2 => new String'("-gnats"), --- 3 => new String'("-gnatu"), --- 4 => new String'("-x"), --- 5 => new String'("ada"), --- 6 => null); type SFN_Pragma is record Unit : String_Access; @@ -164,13 +163,9 @@ package body Prj.Makr is Dir : Dir_Type; Process : Boolean := True; - begin - if Opt.Verbose_Mode then - Output.Write_Str ("Processing directory """); - Output.Write_Str (Dir_Name); - Output.Write_Line (""""); - end if; + Temp_File_Name : String_Access := null; + begin -- Avoid processing several times the same directory. for Index in 1 .. Processed_Directories.Last loop @@ -181,9 +176,16 @@ package body Prj.Makr is end loop; if Process then + if Opt.Verbose_Mode then + Output.Write_Str ("Processing directory """); + Output.Write_Str (Dir_Name); + Output.Write_Line (""""); + end if; + Processed_Directories. Increment_Last; Processed_Directories.Table (Processed_Directories.Last) := new String'(Dir_Name); + -- Get the source file names from the directory. -- Fails if the directory does not exist. @@ -248,158 +250,262 @@ package body Prj.Makr is if Matched = True then declare - PD : Process_Descriptor; - Result : Expect_Match; + FD : File_Descriptor; + Success : Boolean; + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor; begin + -- If we don't have yet the path of the compiler, + -- get it now. + + if Gcc_Path = null then + Gcc_Path := Locate_Exec_On_Path (Gcc); + + if Gcc_Path = null then + Prj.Com.Fail ("could not locate " & Gcc); + end if; + end if; + + -- If we don't have yet the file name of the + -- temporary file, get it now. + + if Temp_File_Name = null then + Create_Temp_File (FD, Temp_File_Name); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + Close (FD); + Delete_File (Temp_File_Name.all, Success); + end if; + Args (Args'Last) := new String' - (Dir_Name & - Directory_Separator & - Str (1 .. Last)); + (Dir_Name & + Directory_Separator & + Str (1 .. Last)); + + -- Create the temporary file + + FD := Create_Output_Text_File + (Name => Temp_File_Name.all); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + -- Save the standard output and error + + Saved_Output := Dup (Standout); + Saved_Error := Dup (Standerr); + + -- Set the standard output and error to the temporary + -- file. + + Dup2 (FD, Standout); + Dup2 (FD, Standerr); + + -- And spawn the compiler + + Spawn (Gcc_Path.all, Args, Success); + + -- Restore the standard output and error + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); + + -- Close the temporary file + + Close (FD); + + -- And close the saved standard output and error to + -- avoid too many file descriptors. + + Close (Saved_Output); + Close (Saved_Error); + + -- Now that standard output is restored, check if + -- the compiler ran correctly. + + -- Read the first line of the temporary file: + -- it should contain the kind and name of the unit. + + declare + File : Text_File; + Text_Line : String (1 .. 1_000); + Text_Last : Natural; begin - Non_Blocking_Spawn - (PD, "gcc", Args, Err_To_Out => True); - Expect (PD, Result, Matcher); + Open (File, Temp_File_Name.all); + + if not Is_Valid (File) then + Prj.Com.Fail + ("could not read temporary file"); + end if; - exception - when Process_Died => + if End_Of_File (File) then if Opt.Verbose_Mode then - Output.Write_Str ("(process died) "); + if not Success then + Output.Write_Str ("(process died) "); + end if; + + Output.Write_Line ("not a unit"); end if; - Result := Expect_Timeout; - end; + else + Get_Line (File, Text_Line, Text_Last); + Close (File); - if Result /= Expect_Timeout then + -- Now that we have read the line, delete the + -- temporary file, it is not needed anymore. + -- On VMS, this avoids several version of the + -- file, if it were only delete after all + -- sources were parsed. - -- If we got a unit name, this is a valid source - -- file. + Delete_File (Temp_File_Name.all, Success); - declare - S : constant String := Expect_Out_Match (PD); + -- Find the first closing parenthesis - begin - if S'Length >= 13 - and then S (S'First .. S'First + 3) = "Unit" - then - if Opt.Verbose_Mode then - Output.Write_Str - (S (S'Last - 4 .. S'Last - 1)); - Output.Write_Str (" of "); - Output.Write_Line - (S (S'First + 5 .. S'Last - 7)); + for J in 1 .. Text_Last loop + if Text_Line (J) = ')' then + Text_Last := J; + exit; end if; + end loop; + + declare + S : constant String := + Text_Line (1 .. Text_Last); + + begin + if S'Length >= 13 + and then S (S'First .. S'First + 3) = "Unit" + then + if Opt.Verbose_Mode then + Output.Write_Str + (S (S'Last - 4 .. S'Last - 1)); + Output.Write_Str (" of "); + Output.Write_Line + (S (S'First + 5 .. S'Last - 7)); + end if; - if Project_File then - - -- Add the corresponding attribute in the - -- Naming package of the naming project. - - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Declarative_Item); - - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Attribute_Declaration); - - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - And_Expr_Kind => Single); - - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - And_Expr_Kind => Single); - - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String, - And_Expr_Kind => Single); - - begin - Set_Next_Declarative_Item - (Decl_Item, - To => First_Declarative_Item_Of - (Naming_Package)); - Set_First_Declarative_Item_Of - (Naming_Package, To => Decl_Item); - Set_Current_Item_Node - (Decl_Item, To => Attribute); - - if - S (S'Last - 5 .. S'Last) = "(spec)" + if Project_File then + + -- Add the corresponding attribute in + -- the Naming package of the naming + -- project. + + declare + Decl_Item : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => + N_Declarative_Item); + + Attribute : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => + N_Attribute_Declaration); + + Expression : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Literal_String, + And_Expr_Kind => + Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package)); + Set_First_Declarative_Item_Of + (Naming_Package, To => Decl_Item); + Set_Current_Item_Node + (Decl_Item, To => Attribute); + + -- Is it a spec or a body? + + if S (S'Last - 5 .. S'Last) = + "(spec)" + then + Set_Name_Of + (Attribute, To => Name_Spec); + else + Set_Name_Of + (Attribute, + To => Name_Body); + end if; + + -- Get the name of the unit + + Name_Len := S'Last - S'First - 11; + Name_Buffer (1 .. Name_Len) := + (To_Lower + (S (S'First + 5 .. + S'Last - 7))); + Set_Associative_Array_Index_Of + (Attribute, To => Name_Find); + + Set_Expression_Of + (Attribute, To => Expression); + Set_First_Term + (Expression, To => Term); + Set_Current_Term (Term, To => Value); + + -- And set the name of the file + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := + Str (1 .. Last); + Set_String_Value_Of + (Value, To => Name_Find); + end; + + -- Add source file name to source list + -- file. + + Last := Last + 1; + Str (Last) := ASCII.LF; + + if Write (Source_List_FD, + Str (1)'Address, + Last) /= Last then - Set_Name_Of - (Attribute, To => Name_Spec); - else - Set_Name_Of - (Attribute, - To => Name_Body); + Prj.Com.Fail ("disk full"); end if; - - Name_Len := S'Last - S'First - 11; - Name_Buffer (1 .. Name_Len) := - (To_Lower - (S (S'First + 5 .. S'Last - 7))); - Set_Associative_Array_Index_Of - (Attribute, To => Name_Find); - - Set_Expression_Of - (Attribute, To => Expression); - Set_First_Term (Expression, To => Term); - Set_Current_Term (Term, To => Value); - - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := - Str (1 .. Last); - Set_String_Value_Of - (Value, To => Name_Find); - end; - - -- Add source file name to source list - -- file. - - Last := Last + 1; - Str (Last) := ASCII.LF; - - if Write (Source_List_FD, - Str (1)'Address, - Last) /= Last - then - Prj.Com.Fail ("disk full"); + else + -- Add an entry in the SFN_Pragmas + -- table. + + SFN_Pragmas.Increment_Last; + SFN_Pragmas.Table (SFN_Pragmas.Last) := + (Unit => new String' + (S (S'First + 5 .. S'Last - 7)), + File => new String'(Str (1 .. Last)), + Spec => S (S'Last - 5 .. S'Last) + = "(spec)"); end if; - else - -- Add an entry in the SFN_Pragmas table - - SFN_Pragmas.Increment_Last; - SFN_Pragmas.Table (SFN_Pragmas.Last) := - (Unit => new String' - (S (S'First + 5 .. S'Last - 7)), - File => new String'(Str (1 .. Last)), - Spec => S (S'Last - 5 .. S'Last) - = "(spec)"); - end if; - else - if Opt.Verbose_Mode then - Output.Write_Line ("not a unit"); + else + if Opt.Verbose_Mode then + Output.Write_Line ("not a unit"); + end if; end if; - end if; - end; - - else - if Opt.Verbose_Mode then - Output.Write_Line ("not a unit"); + end; end if; - end if; - - Close (PD); + end; end; else diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index aed4838cf62..7ad849b1a4c 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -667,7 +667,7 @@ package body Prj.Nmsc is if Element.Value /= No_Name then declare Source_Directory : constant String := - Get_Name_String (Element.Value); + Get_Name_String (Element.Display_Value); begin if Current_Verbosity = High then @@ -691,9 +691,6 @@ package body Prj.Nmsc is exit when Name_Len = 0; - -- Canonical_Case_File_Name - -- (Name_Buffer (1 .. Name_Len)); - declare File_Name : constant Name_Id := Name_Find; Dir : constant String := @@ -2721,15 +2718,6 @@ package body Prj.Nmsc is begin if Current_Verbosity = High then Write_Str ("Find_Source_Dirs ("""); - end if; - - Get_Name_String (From); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - - -- Directory := Name_Buffer (1 .. Name_Len); - -- Why is above line commented out ??? - - if Current_Verbosity = High then Write_Str (Directory); Write_Line (""")"); end if; diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index 8b1d082b0f4..9a965ef1515 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2003, Free Software Foundation, Inc. * + * Copyright (C) 1992-2004, 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- * @@ -482,12 +482,6 @@ typedef struct This is compared against the ttype entries associated with actions in the examined context to see if one of these actions matches. */ - bool handled_by_others; - /* Indicates wether a "when others" may catch this exception, also filled by - Propagate_Exception. - - This is used to decide if a GNAT_OTHERS ttype entry matches. */ - int n_cleanups_to_trigger; /* Number of cleanups on the propagation way for the occurrence. This is initialized to 0 by Propagate_Exception and computed by the personality @@ -846,6 +840,59 @@ get_call_site_action_for (_Unwind_Context *uw_context, #endif +/* With CHOICE an exception choice representing an "exception - when" + argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated + occurrence, return true iif the latter matches the former, that is, if + PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE. + This takes care of the special Non_Ada_Error case on VMS. */ + +#define Is_Handled_By_Others __gnat_is_handled_by_others +#define Language_For __gnat_language_for +#define Import_Code_For __gnat_import_code_for + +extern bool Is_Handled_By_Others (_Unwind_Ptr e); +extern char Language_For (_Unwind_Ptr e); + +extern Exception_Code Import_Code_For (_Unwind_Ptr e); + +static int +is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) +{ + /* Pointer to the GNAT exception data corresponding to the propagated + occurrence. */ + _Unwind_Ptr E = propagated_exception->id; + + /* Base matching rules: An exception data (id) matches itself, "when + all_others" matches anything and "when others" matches anything unless + explicitely stated otherwise in the propagated occurrence. */ + + bool is_handled = + choice == E + || choice == GNAT_ALL_OTHERS + || (choice == GNAT_OTHERS && Is_Handled_By_Others (E)); + + /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we + may have different exception data pointers that should match for the + same condition code, if both an export and an import have been + registered. The import code for both the choice and the propagated + occurrence are expected to have been masked off regarding severity + bits already (at registration time for the former and from within the + low level exception vector for the latter). */ +#ifdef VMS + #define Non_Ada_Error system__aux_dec__non_ada_error + extern struct Exception_Data Non_Ada_Error; + + is_handled |= + (Language_For (E) == 'V' + && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS + && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0 + && Import_Code_For (choice) == Import_Code_For (E)) + || choice == (_Unwind_Ptr)&Non_Ada_Error)); +#endif + + return is_handled; +} + /* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to UW_CONTEXT in REGION. */ @@ -907,14 +954,12 @@ get_action_description_for (_Unwind_Context *uw_context, { /* See if the filter we have is for an exception which matches the one we are propagating. */ - _Unwind_Ptr eid = get_ttype_entry_for (region, ar_filter); + _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter); - if (eid == gnat_exception->id - || eid == GNAT_ALL_OTHERS - || (eid == GNAT_OTHERS && gnat_exception->handled_by_others)) + if (is_handled_by (choice, gnat_exception)) { action->ttype_filter = ar_filter; - action->ttype_entry = eid; + action->ttype_entry = choice; action->kind = handler; return; } diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index 1176be4611c..f9eb02aff72 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2003, Free Software Foundation, Inc. * + * Copyright (C) 1992-2004, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -30,13 +30,17 @@ * * ****************************************************************************/ + +typedef unsigned Exception_Code; +/* C counterpart of what System.Standard_Library defines. */ + struct Exception_Data { char Handled_By_Others; char Lang; int Name_Length; char *Full_Name, Htable_Ptr; - int Import_Code; + Exception_Code Import_Code; }; typedef struct Exception_Data *Exception_Id; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 3ecd94842bd..04ef5b9dcd6 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -1049,6 +1049,7 @@ package Rtsfind is RE_Shared_Var_WOpen, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library + RE_Exception_Code, -- System.Standard_Library RE_Exception_Data_Ptr, -- System.Standard_Library RE_Integer_Address, -- System.Storage_Elements @@ -1989,6 +1990,7 @@ package Rtsfind is RE_Shared_Var_WOpen => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, + RE_Exception_Code => System_Standard_Library, RE_Exception_Data_Ptr => System_Standard_Library, RE_Integer_Address => System_Storage_Elements, diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index cf29b249533..006cf933716 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -774,12 +774,12 @@ package body System.File_IO is end; -- If we were given a stream (call from xxx.C_Streams.Open), then set - -- full name to null and that is all we have to do in this case so - -- skip to end of processing. + -- the full name to the given one, and skip to end of processing. if Stream /= NULL_Stream then - Fullname (1) := ASCII.Nul; - Full_Name_Len := 1; + Full_Name_Len := Name'Length + 1; + Fullname (1 .. Full_Name_Len - 1) := Name; + Fullname (Full_Name_Len) := ASCII.Nul; -- Normal case of Open or Create diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads index bdd447538f8..84bf0b9e737 100644 --- a/gcc/ada/s-stalib.ads +++ b/gcc/ada/s-stalib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -97,6 +97,20 @@ package System.Standard_Library is type Exception_Data_Ptr is access all Exception_Data; -- An equivalent of Exception_Id that is public + type Exception_Code is mod 2 ** 32; + -- A scalar value bound to some exception data. Typically used for + -- imported or exported exceptions on VMS. Having a separate type for this + -- is useful to enforce consistency throughout the various run-time units + -- handling such codes, and having it unsigned is the most appropriate + -- choice for it's currently single use on VMS. + + -- ??? The construction in Cstand has no way to access the proper type + -- node for Exception_Code, and currently uses Standard_Unsigned as a + -- fallback. The representations shall match, and the size clause below + -- is aimed at ensuring that. + + for Exception_Code'Size use Integer'Size; + -- The following record defines the underlying representation of exceptions -- WARNING! Any changes to this may need to be reflectd in the following @@ -131,7 +145,7 @@ package System.Standard_Library is -- built (by Register_Exception in s-exctab.adb) for converting between -- identities and names. - Import_Code : Integer; + Import_Code : Exception_Code; -- Value for imported exceptions. Needed only for the handling of -- Import/Export_Exception for the VMS case, but present in all -- implementations (we might well extend this mechanism for other diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads index 622e0ebee59..821197593cc 100644 --- a/gcc/ada/s-tataat.ads +++ b/gcc/ada/s-tataat.ads @@ -57,9 +57,13 @@ package System.Tasking.Task_Attributes is type Dummy_Wrapper; type Access_Dummy_Wrapper is access all Dummy_Wrapper; + pragma No_Strict_Aliasing (Access_Dummy_Wrapper); + -- Needed to avoid possible incorrect aliasing situations from + -- instantiation of Unchecked_Conversion in body of Ada.Task_Attributes. + for Access_Dummy_Wrapper'Storage_Size use 0; - -- This is a stand-in for the generic type Wrapper defined in - -- Ada.Task_Attributes. The real objects allocated are always + -- Access_Dummy_Wrapper is a stand-in for the generic type Wrapper defined + -- in Ada.Task_Attributes. The real objects allocated are always -- of type Wrapper, no Dummy_Wrapper objects are ever created. type Deallocator is access procedure (P : in out Access_Node); diff --git a/gcc/ada/s-thread.ads b/gcc/ada/s-thread.ads index 29f0b3643f2..6798acbedbe 100644 --- a/gcc/ada/s-thread.ads +++ b/gcc/ada/s-thread.ads @@ -34,8 +34,9 @@ -- This package provides facilities to register a thread to the runtime, -- and allocate its task specific datas. --- pragma Thread_Body is currently supported for: --- VxWorks AE653 with the restricted / cert runtime +-- This package is currently implemented for: +-- VxWorks AE653 rts-cert +-- VxWorks AE653 rts-full (not rts-kernel) with Ada.Exceptions; -- used for Exception_Occurrence @@ -43,6 +44,8 @@ with Ada.Exceptions; with System.Soft_Links; -- used for TSD +with Unchecked_Conversion; + package System.Threads is subtype EO is Ada.Exceptions.Exception_Occurrence; @@ -54,6 +57,7 @@ package System.Threads is -- by the GNAT runtime. type ATSD_Access is access ATSD; + function From_Address is new Unchecked_Conversion (Address, ATSD_Access); -- Get/Set for the attributes of the current thread diff --git a/gcc/ada/s-vmexta.adb b/gcc/ada/s-vmexta.adb index b61955fb5d3..935ed1e7a39 100644 --- a/gcc/ada/s-vmexta.adb +++ b/gcc/ada/s-vmexta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2004, 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- -- @@ -38,7 +38,7 @@ pragma Elaborate_All (System.HTable); package body System.VMS_Exception_Table is - use System.Standard_Library; + use type SSL.Exception_Code; type HTable_Headers is range 1 .. 37; @@ -49,8 +49,8 @@ package body System.VMS_Exception_Table is -- Ada exception. type Exception_Code_Data is record - Code : Natural; - Except : Exception_Data_Ptr; + Code : SSL.Exception_Code; + Except : SSL.Exception_Data_Ptr; HTable_Ptr : Exception_Code_Data_Ptr; end record; @@ -61,8 +61,8 @@ package body System.VMS_Exception_Table is function Get_HT_Link (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr; - function Hash (F : Natural) return HTable_Headers; - function Get_Key (T : Exception_Code_Data_Ptr) return Natural; + function Hash (F : SSL.Exception_Code) return HTable_Headers; + function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code; package Exception_Code_HTable is new System.HTable.Static_HTable ( Header_Num => HTable_Headers, @@ -71,16 +71,29 @@ package body System.VMS_Exception_Table is Null_Ptr => null, Set_Next => Set_HT_Link, Next => Get_HT_Link, - Key => Natural, + Key => SSL.Exception_Code, Get_Key => Get_Key, Hash => Hash, Equal => "="); + ------------------ + -- Base_Code_In -- + ------------------ + + function Base_Code_In + (Code : SSL.Exception_Code) return SSL.Exception_Code + is + begin + return Code and not 2#0111#; + end Base_Code_In; + --------------------- -- Coded_Exception -- --------------------- - function Coded_Exception (X : Natural) return Exception_Data_Ptr is + function Coded_Exception + (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr + is Res : Exception_Code_Data_Ptr; begin @@ -98,8 +111,9 @@ package body System.VMS_Exception_Table is -- Get_HT_Link -- ----------------- - function Get_HT_Link (T : Exception_Code_Data_Ptr) - return Exception_Code_Data_Ptr is + function Get_HT_Link + (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr + is begin return T.HTable_Ptr; end Get_HT_Link; @@ -108,7 +122,9 @@ package body System.VMS_Exception_Table is -- Get_Key -- ------------- - function Get_Key (T : Exception_Code_Data_Ptr) return Natural is + function Get_Key (T : Exception_Code_Data_Ptr) + return SSL.Exception_Code + is begin return T.Code; end Get_Key; @@ -117,39 +133,44 @@ package body System.VMS_Exception_Table is -- Hash -- ---------- - function Hash (F : Natural) return HTable_Headers is + function Hash + (F : SSL.Exception_Code) return HTable_Headers + is + Headers_Magnitude : constant SSL.Exception_Code := + SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); + begin - return HTable_Headers - (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1); + return HTable_Headers (F mod Headers_Magnitude + 1); end Hash; ---------------------------- -- Register_VMS_Exception -- ---------------------------- - procedure Register_VMS_Exception (Code : Integer) is - Excode : constant Integer := (Code / 8) * 8; - -- Mask off lower 3 bits which are the severity + procedure Register_VMS_Exception + (Code : SSL.Exception_Code; + E : SSL.Exception_Data_Ptr) + is + -- We bind the exception data with the base code found in the + -- input value, that is with the severity bits masked off. + + Excode : constant SSL.Exception_Code := Base_Code_In (Code); begin - -- This allocates an empty exception that gets filled in by - -- __gnat_error_handler when the exception is raised. Allocating - -- it here prevents having to allocate it each time the exception - -- is raised. + -- The exception data registered here is mostly filled prior to this + -- call and by __gnat_error_handler when the exception is raised. We + -- still need to fill a couple of components for exceptions that will + -- be used as propagation filters (exception data pointer registered + -- as choices in the unwind tables): in some import/export cases, the + -- exception pointers for the choice and the propagated occurrence may + -- indeed be different for a single import code, and the personality + -- routine attempts to match the import codes in this case. + + E.Lang := 'V'; + E.Import_Code := Excode; if Exception_Code_HTable.Get (Excode) = null then - Exception_Code_HTable.Set - (new Exception_Code_Data' - (Excode, - new Exception_Data' - (Not_Handled_By_Others => False, - Lang => 'V', - Name_Length => 0, - Full_Name => null, - HTable_Ptr => null, - Import_Code => 0, - Raise_Hook => null), - null)); + Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null)); end if; end Register_VMS_Exception; diff --git a/gcc/ada/s-vmexta.ads b/gcc/ada/s-vmexta.ads index 7f2f08ed496..2aeed8c2a07 100644 --- a/gcc/ada/s-vmexta.ads +++ b/gcc/ada/s-vmexta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,9 +35,14 @@ -- where there is at least one Import/Export exception present. with System.Standard_Library; + package System.VMS_Exception_Table is - procedure Register_VMS_Exception (Code : Integer); + package SSL renames System.Standard_Library; + + procedure Register_VMS_Exception + (Code : SSL.Exception_Code; + E : SSL.Exception_Data_Ptr); -- Register an exception in the hash table mapping with a VMS -- condition code. @@ -45,9 +50,12 @@ package System.VMS_Exception_Table is private - function Coded_Exception (X : Natural) - return System.Standard_Library.Exception_Data_Ptr; + function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code; + -- Value of Code with the severity bits masked off. + + function Coded_Exception (X : SSL.Exception_Code) + return SSL.Exception_Data_Ptr; -- Given a VMS condition, find and return it's allocated Ada exception - -- (called only from a-init.c). + -- (called only from init.c). end System.VMS_Exception_Table; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4a83b46cc13..90f285c029f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7892,6 +7892,7 @@ package body Sem_Ch12 is -- actual must correspond to a discriminant of the formal. elsif Has_Discriminants (Act_T) + and then not Has_Unknown_Discriminants (Act_T) and then Has_Discriminants (Ancestor) then Actual_Discr := First_Discriminant (Act_T); @@ -7923,7 +7924,9 @@ package body Sem_Ch12 is -- for constrainedness, but the check here is added for -- completeness. - elsif Has_Discriminants (Act_T) then + elsif Has_Discriminants (Act_T) + and then not Has_Unknown_Discriminants (Act_T) + then Error_Msg_NE ("actual for & must not have discriminants", Actual, Gen_T); Abandon_Instantiation (Actual); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2a48fb9450e..e89041a0eb7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3852,15 +3852,16 @@ package body Sem_Ch13 is end if; end if; - -- In GNAT mode, if target is an access type, access type must be - -- declared in the same source unit as the unchecked conversion. - --- if GNAT_Mode and then Is_Access_Type (Target) then --- if not In_Same_Source_Unit (Target, N) then --- Error_Msg_NE --- ("unchecked conversion not in same unit as&", N, Target); --- end if; --- end if; + -- If unchecked conversion to access type, and access type is + -- declared in the same unit as the unchecked conversion, then + -- set the No_Strict_Aliasing flag (no strict aliasing is + -- implicit in this situation). + + if Is_Access_Type (Target) and then + In_Same_Source_Unit (Target, N) + then + Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); + end if; -- Generate N_Validate_Unchecked_Conversion node for back end in -- case the back end needs to perform special validation checks. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index fc3b12e70dd..c1cff22e39f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2142,6 +2142,10 @@ package body Sem_Ch3 is Set_Is_First_Subtype (T); Make_Class_Wide_Type (T); + if Unknown_Discriminants_Present (N) then + Set_Discriminant_Constraint (T, No_Elist); + end if; + Build_Derived_Record_Type (N, Parent_Type, T); end Analyze_Private_Extension_Declaration; @@ -6575,6 +6579,7 @@ package body Sem_Ch3 is if Ekind (Full_Base) = E_Record_Type and then Has_Discriminants (Full_Base) and then Has_Discriminants (Priv) -- might not, if errors + and then not Has_Unknown_Discriminants (Priv) and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) then Create_Constrained_Components diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d28109b1c54..55dbc2317b2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -401,6 +401,7 @@ package body Sem_Ch6 is Check_References (Gen_Id); end; + Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope); End_Scope; Check_Subprogram_Order (N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f0aad749e98..3d718d7b800 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7508,7 +7508,7 @@ package body Sem_Prag is Error_Pragma_Arg ("pragma% requires access type", Arg1); end if; - Set_No_Strict_Aliasing (Base_Type (E_Id)); + Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); end if; end No_Strict_Alias; diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 20d1fdc5a54..fb1b766da77 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -1695,9 +1695,7 @@ tree_transform (Node_Id gnat_node) { unsigned int align = known_alignment (gnu_result); tree gnu_obj_type = TREE_TYPE (gnu_result_type); - unsigned int oalign - = TREE_CODE (gnu_obj_type) == FUNCTION_TYPE - ? FUNCTION_BOUNDARY : TYPE_ALIGN (gnu_obj_type); + unsigned int oalign = TYPE_ALIGN (gnu_obj_type); if (align != 0 && align < oalign && ! TYPE_ALIGN_OK (gnu_obj_type)) post_error_ne_tree_2 diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 232940d05a4..fd9cb34057d 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -517,8 +517,8 @@ package VMS_Data is -- for a directory. S_Bind_Shared : aliased constant S := "/SHARED " & - "-shared"; - -- /SHARED (D) + "-shared,!-static"; + -- /SHARED -- /NOSHARED -- -- Link against a shared GNAT run time when available. @@ -537,6 +537,13 @@ package VMS_Data is -- -- When looking for source files also look in directories specified. + S_Bind_Static : aliased constant S := "/STATIC " & + "-static,!-shared"; + -- /STATIC + -- /NOSTATIC + -- + -- Link against a static GNAT run time. + S_Bind_Store : aliased constant S := "/STORE_TRACEBACKS " & "-E"; -- /STORE_TRACEBACKS (D) @@ -636,6 +643,7 @@ package VMS_Data is S_Bind_Shared 'Access, S_Bind_Slice 'Access, S_Bind_Source 'Access, + S_Bind_Static 'Access, S_Bind_Store 'Access, S_Bind_Time 'Access, S_Bind_Verbose 'Access, |
