From 77a37c057147e4181013130dd7300835b8e62912 Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 2 Sep 2011 09:52:36 +0000 Subject: [PATCH] 2011-09-02 Vincent Celier * prj-conf.adb (Add_Default_GNAT_Naming_Scheme): Declare "gcc" as the compiler driver so Is_Compilable returns True for sources. * prj-nmsc.adb (Override_Kind): When Kind is Sep, set the source for the body. 2011-09-02 Ed Schonberg * sem_prag.adb (Analyze_PPC_In_Decl_Part): for a class-wide condition, a reference to a controlling formal must be interpreted as having the class-wide type (or an access to such) so that the inherited condition can be properly applied to any overriding operation (see ARM12 6.6.1 (7)). 2011-09-02 Tristan Gingold * init.c (__gnat_is_vms_v7): Fix case and add prototype for LIB$GETSYI. 2011-09-02 Javier Miranda * exp_ch3.adb (Expand_N_Object_Declaration): Do not copy the initializing expression of a class-wide interface object declaration if its type is limited. 2011-09-02 Johannes Kanig * sem_util.adb (Unique_Name): To obtain a unique name for enumeration literals, take into account the type name; the type is *not* the scope for an enumeration literal. 2011-09-02 Ed Schonberg * sem_ch6.adb (Check_Overriding_Indicator): add special check to reject an overriding indicator on a user-defined Adjust subprogram for a limited controlled type. 2011-09-02 Ed Schonberg * sem_res.adb (Resolve_Actuals): add missing call to Resolve for an actual that is a function call returning an unconstrained limited controlled type. 2011-09-02 Tristan Gingold * g-socthi-vms.adb (c_sendmsg, c_recvmsg): Use unpacked msg if on vms 7 2011-09-02 Johannes Kanig * alfa.ads (Name_Of_Heap_Variable): Change value of the HEAP variable from "HEAP" to __HEAP Change comment that refers to that variable * put_alfa.adb: Change comment that refers to that variable git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178458 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 54 +++++++++++++++++++++++++ gcc/ada/alfa.ads | 11 +++--- gcc/ada/exp_ch3.adb | 42 ++++++++++++++------ gcc/ada/g-socthi-vms.adb | 44 +++++++++++++++++---- gcc/ada/init.c | 4 +- gcc/ada/prj-conf.adb | 2 + gcc/ada/prj-nmsc.adb | 9 ++++- gcc/ada/put_alfa.adb | 4 +- gcc/ada/sem_ch6.adb | 14 +++++++ gcc/ada/sem_prag.adb | 100 +++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_res.adb | 1 + gcc/ada/sem_util.adb | 2 + 12 files changed, 257 insertions(+), 30 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1f8cebf..0c81255 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,57 @@ +2011-09-02 Vincent Celier + + * prj-conf.adb (Add_Default_GNAT_Naming_Scheme): Declare "gcc" + as the compiler driver so Is_Compilable returns True for sources. + * prj-nmsc.adb (Override_Kind): When Kind is Sep, set the source + for the body. + +2011-09-02 Ed Schonberg + + * sem_prag.adb (Analyze_PPC_In_Decl_Part): for a class-wide + condition, a reference to a controlling formal must be interpreted + as having the class-wide type (or an access to such) so that the + inherited condition can be properly applied to any overriding + operation (see ARM12 6.6.1 (7)). + +2011-09-02 Tristan Gingold + + * init.c (__gnat_is_vms_v7): Fix case and add prototype + for LIB$GETSYI. + +2011-09-02 Javier Miranda + + * exp_ch3.adb (Expand_N_Object_Declaration): Do not copy the + initializing expression of a class-wide interface object declaration + if its type is limited. + +2011-09-02 Johannes Kanig + + * sem_util.adb (Unique_Name): To obtain a unique name for enumeration + literals, take into account the type name; the type is *not* + the scope for an enumeration literal. + +2011-09-02 Ed Schonberg + + * sem_ch6.adb (Check_Overriding_Indicator): add special check + to reject an overriding indicator on a user-defined Adjust + subprogram for a limited controlled type. + +2011-09-02 Ed Schonberg + + * sem_res.adb (Resolve_Actuals): add missing call to Resolve + for an actual that is a function call returning an unconstrained + limited controlled type. + +2011-09-02 Tristan Gingold + + * g-socthi-vms.adb (c_sendmsg, c_recvmsg): Use unpacked msg if on vms 7 + +2011-09-02 Johannes Kanig + + * alfa.ads (Name_Of_Heap_Variable): Change value of the HEAP variable + from "HEAP" to __HEAP Change comment that refers to that variable + * put_alfa.adb: Change comment that refers to that variable + 2011-09-02 Robert Dewar * exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting. diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index 95c4be3..7531f9e 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/alfa.ads @@ -91,8 +91,7 @@ package Alfa is -- FS . scope line type col entity (-> spec-file . spec-scope)? - -- What is the ? marke here, is it part of the actual syntax, or is - -- it a query about a problem, in which case it should be ??? + -- (The ? mark stands for an optional entry in the syntax) -- scope is the ones-origin scope number for the current file (e.g. 2 = -- reference to the second FS line in this FD block). @@ -176,9 +175,9 @@ package Alfa is -- s = subprogram reference in a static call -- Special entries for reads and writes to memory reference a special - -- variable called "HEAP". These special entries are present in every scope - -- where reads and writes to memory are present. Line and column for this - -- special variable are always 0. + -- variable called "__HEAP". These special entries are present in every + -- scope where reads and writes to memory are present. Line and column for + -- this special variable are always 0. -- Examples: ??? add examples here @@ -336,7 +335,7 @@ package Alfa is -- Constants -- --------------- - Name_Of_Heap_Variable : constant String := "HEAP"; + Name_Of_Heap_Variable : constant String := "__HEAP"; -- Name of special variable used in effects to denote reads and writes -- through explicit dereference. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 56d0fa2..a8cde1e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4841,11 +4841,11 @@ package body Exp_Ch3 is return; -- Ada 2005 (AI-251): Rewrite the expression that initializes a - -- class-wide object to ensure that we copy the full object, - -- unless we are targetting a VM where interfaces are handled by - -- VM itself. Note that if the root type of Typ is an ancestor - -- of Expr's type, both types share the same dispatch table and - -- there is no need to displace the pointer. + -- class-wide interface object to ensure that we copy the full + -- object, unless we are targetting a VM where interfaces are handled + -- by VM itself. Note that if the root type of Typ is an ancestor of + -- Expr's type, both types share the same dispatch table and there is + -- no need to displace the pointer. elsif Comes_From_Source (N) and then Is_Interface (Typ) @@ -4978,13 +4978,31 @@ package body Exp_Ch3 is -- Copy the object - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => - New_Occurrence_Of - (Etype (Object_Definition (N)), Loc), - Expression => New_Expr)); + if not Is_Limited_Record (Expr_Typ) then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => New_Expr)); + + -- Rename limited type object since they cannot be copied + -- This case occurs when the initialization expression + -- has been previously expanded into a temporary object. + + else pragma Assert (not Comes_From_Source (Expr_Q)); + + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Obj_Id, + Subtype_Mark => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Name => + Unchecked_Convert_To + (Etype (Object_Definition (N)), New_Expr))); + end if; -- Dynamically reference the tag associated with the -- interface. diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index c075ae5..51c28fb 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -42,7 +42,15 @@ package body GNAT.Sockets.Thin is pragma Pack (VMS_Msghdr); -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a -- specific derived type is required. This structure was not packed on - -- VMS 7.3, so sendmsg and recvmsg fail on earlier VMS versions. + -- VMS 7.3. + + function Is_VMS_V7 return Integer; + pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7"); + -- Helper (defined in init.c) that returns a non-zero value if the VMS + -- version is 7.x. + + VMS_V7 : constant Boolean := Is_VMS_V7 /= 0; + -- True if VMS version is 7.x. Non_Blocking_Sockets : aliased Fd_Set; -- When this package is initialized with Process_Blocking_IO set to True, @@ -295,15 +303,24 @@ package body GNAT.Sockets.Thin is is Res : C.int; + Msg_Addr : System.Address; + GNAT_Msg : Msghdr; for GNAT_Msg'Address use Msg; pragma Import (Ada, GNAT_Msg); - VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + VMS_Msg : aliased VMS_Msghdr; begin + if VMS_V7 then + Msg_Addr := Msg; + else + VMS_Msg := VMS_Msghdr (GNAT_Msg); + Msg_Addr := VMS_Msg'Address; + end if; + loop - Res := Syscall_Recvmsg (S, VMS_Msg'Address, Flags); + Res := Syscall_Recvmsg (S, Msg_Addr, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) @@ -311,7 +328,9 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - GNAT_Msg := Msghdr (VMS_Msg); + if not VMS_V7 then + GNAT_Msg := Msghdr (VMS_Msg); + end if; return System.CRTL.ssize_t (Res); end C_Recvmsg; @@ -327,15 +346,24 @@ package body GNAT.Sockets.Thin is is Res : C.int; + Msg_Addr : System.Address; + GNAT_Msg : Msghdr; for GNAT_Msg'Address use Msg; pragma Import (Ada, GNAT_Msg); - VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + VMS_Msg : aliased VMS_Msghdr; begin + if VMS_V7 then + Msg_Addr := Msg; + else + VMS_Msg := VMS_Msghdr (GNAT_Msg); + Msg_Addr := VMS_Msg'Address; + end if; + loop - Res := Syscall_Sendmsg (S, VMS_Msg'Address, Flags); + Res := Syscall_Sendmsg (S, Msg_Addr, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) @@ -343,7 +371,9 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - GNAT_Msg := Msghdr (VMS_Msg); + if not VMS_V7 then + GNAT_Msg := Msghdr (VMS_Msg); + end if; return System.CRTL.ssize_t (Res); end C_Sendmsg; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 02771d5..0cf32e8 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1749,6 +1749,8 @@ __gnat_set_features (void) /* Return true if the VMS version is 7.x. */ +extern unsigned int LIB$GETSYI (int *, ...); + #define SYI$_VERSION 0x1000 int @@ -1763,7 +1765,7 @@ __gnat_is_vms_v7 (void) desc.mbz = 0; desc.adr = version; - status = lib$getsyi (&code, 0, &desc); + status = LIB$GETSYI (&code, 0, &desc); if ((status & 1) == 1 && version[1] == '7' && version[2] == '.') return 1; else diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 9120ae7..8b86c46 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -436,6 +436,8 @@ package body Prj.Conf is Compiler := Create_Package (Project_Tree, Config_File, "compiler"); Create_Attribute + (Name_Driver, "gcc", "ada", Pkg => Compiler); + Create_Attribute (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler); Create_Attribute (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler); diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 0fa421e..5761209 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6766,8 +6766,13 @@ package body Prj.Nmsc is & " kind=" & Source.Kind'Img); end if; - if Source.Kind in Spec_Or_Body and then Source.Unit /= null then - Source.Unit.File_Names (Source.Kind) := Source; + if Source.Unit /= null then + if Source.Kind = Spec then + Source.Unit.File_Names (Spec) := Source; + + else + Source.Unit.File_Names (Impl) := Source; + end if; end if; end Override_Kind; diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb index adb41a8..49dfac8 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_alfa.adb @@ -151,8 +151,8 @@ begin Write_Info_Char (S.Scope_Name (N)); end loop; - -- Default value of (0,0) is used for the special HEAP variable - -- so use another default value. + -- Default value of (0,0) is used for the special __HEAP + -- variable so use another default value. Entity_Line := 0; Entity_Col := 1; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5919405..4b4e2ca 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4956,6 +4956,20 @@ package body Sem_Ch6 is ("subprogram & overrides inherited operation #", Spec, Subp); end if; + -- Special-case to fix a GNAT oddity: Limited_Controlled is declared + -- as an extension of Root_Controlled, and thus has a useless Adjust + -- operation. This operation should not be inherited by other limited + -- controlled types. An explicit Adjust for them is not overriding. + + elsif Must_Override (Spec) + and then Chars (Overridden_Subp) = Name_Adjust + and then Is_Limited_Type (Etype (First_Formal (Subp))) + and then Present (Alias (Overridden_Subp)) + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp)))) + then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + elsif Is_Subprogram (Subp) then if Is_Init_Proc (Subp) then null; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8f5909f..27f4c8a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -39,6 +39,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; @@ -261,6 +262,99 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + if Class_Present (N) then + declare + T : constant Entity_Id := Find_Dispatching_Type (S); + + ACW : Entity_Id := Empty; + -- Access to T'class, created if there is a controlling formal + -- that is an access parameter. + + function Get_ACW return Entity_Id; + -- If the expression has a reference to an controlling access + -- parameter, create an access to T'class for the necessary + -- conversions if one does not exist. + + function Process (N : Node_Id) return Traverse_Result; + -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class + -- aspect for a primitive subprogram of a tagged type T, a name + -- that denotes a formal parameter of type T is interpreted as + -- having type T'Class. Similarly, a name that denotes a formal + -- accessparameter of type access-to-T is interpreted as having + -- type access-to-T'Class. This ensures the expression is well- + -- defined for a primitive subprogram of a type descended from T. + + ------------- + -- Get_ACW -- + ------------- + + function Get_ACW return Entity_Id is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + + begin + if No (ACW) then + Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Class_Wide_Type (T), Loc), + All_Present => True)); + + Insert_Before (Unit_Declaration_Node (S), Decl); + Analyze (Decl); + ACW := Defining_Identifier (Decl); + Freeze_Before (Unit_Declaration_Node (S), ACW); + end if; + + return ACW; + end Get_ACW; + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; + + begin + if Is_Entity_Name (N) + and then Is_Formal (Entity (N)) + and then Nkind (Parent (N)) /= N_Type_Conversion + then + if Etype (Entity (N)) = T then + Typ := Class_Wide_Type (T); + + elsif Is_Access_Type (Etype (Entity (N))) + and then Designated_Type (Etype (Entity (N))) = T + then + Typ := Get_ACW; + else + Typ := Empty; + end if; + + if Present (Typ) then + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Expression => New_Occurrence_Of (Entity (N), Loc))); + Set_Etype (N, Typ); + end if; + end if; + + return OK; + end Process; + + procedure Replace_Type is new Traverse_Proc (Process); + + begin + Replace_Type (Get_Pragma_Arg (Arg1)); + end; + end if; + -- Remove the subprogram from the scope stack now that the pre-analysis -- of the precondition/postcondition is done. @@ -1838,6 +1932,12 @@ package body Sem_Prag is Chain_PPC (PO); return; + elsif Nkind (PO) = N_Subprogram_Declaration + and then In_Instance + then + Chain_PPC (PO); + return; + -- For all other cases of non source code, do nothing else diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3fe0719..7668aa9 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3446,6 +3446,7 @@ package body Sem_Res is and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) then Establish_Transient_Scope (A, False); + Resolve (A, Etype (F)); -- A small optimization: if one of the actuals is a concatenation -- create a block around a procedure call to recover stack space. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 658ca1a..23105c5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12747,6 +12747,8 @@ package body Sem_Util is then return Get_Name_String (Name_Standard) & "__" & Get_Name_String (Chars (E)); + elsif Ekind (E) = E_Enumeration_Literal then + return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); else return Get_Scoped_Name (E); -- 2.7.4