+2011-09-02 Vincent Celier <celier@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <gingold@adacore.com>
+
+ * init.c (__gnat_is_vms_v7): Fix case and add prototype
+ for LIB$GETSYI.
+
+2011-09-02 Javier Miranda <miranda@adacore.com>
+
+ * 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 <kanig@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <gingold@adacore.com>
+
+ * g-socthi-vms.adb (c_sendmsg, c_recvmsg): Use unpacked msg if on vms 7
+
+2011-09-02 Johannes Kanig <kanig@adacore.com>
+
+ * 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 <dewar@adacore.com>
* exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting.
-- 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).
-- 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
-- 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.
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)
-- 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.
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,
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)
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;
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)
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;
/* Return true if the VMS version is 7.x. */
+extern unsigned int LIB$GETSYI (int *, ...);
+
#define SYI$_VERSION 0x1000
int
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
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);
& " 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;
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;
("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;
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;
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.
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
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.
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);
projects / platform / upstream / gcc.git / commitdiff