* *
* C Implementation File *
* *
- * Copyright (C) 2001-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 2001-2012, 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- *
#include <stdio.h>
#include <ctype.h>
-#include "adaint.h"
+#include "adaint.h" /* for a macro version of xstrdup. */
#ifndef ISDIGIT
#define ISDIGIT(c) isdigit(c)
int in_task = 0;
int body_nested = 0;
+ /* Deal with empty input early. This allows assuming non-null length
+ later on, simplifying coding. In principle, it should be our callers
+ business not to call here for empty inputs. It is easy enough to
+ allow it, however, and might allow simplifications upstream so is not
+ a bad thing per se. We need a guard in any case. */
+
+ if (*coded_name == '\0')
+ {
+ *ada_name = '\0';
+ return;
+ }
+
/* Check for library level subprogram. */
- if (has_prefix (coded_name, "_ada_"))
+ else if (has_prefix (coded_name, "_ada_"))
{
strcpy (ada_name, coded_name + 5);
lib_subprog = 1;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
procedure Check_Current_Instance (Comp_Decl : Node_Id) is
- Rec_Type : constant Entity_Id :=
- Scope (Defining_Identifier (Comp_Decl));
-
- Decl : constant Node_Id := Parent (Rec_Type);
+ function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean;
+ -- Determine whether Typ is compatible with the rules for aliased
+ -- views of types as defined in RM 3.10 in the various dialects.
function Process (N : Node_Id) return Traverse_Result;
-- Process routine to apply check to given node
+ -----------------------------
+ -- Is_Aliased_View_Of_Type --
+ -----------------------------
+
+ function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is
+ Typ_Decl : constant Node_Id := Parent (Typ);
+
+ begin
+ -- Common case
+
+ if Nkind (Typ_Decl) = N_Full_Type_Declaration
+ and then Limited_Present (Type_Definition (Typ_Decl))
+ then
+ return True;
+
+ -- The following paragraphs describe what a legal aliased view of
+ -- a type is in the various dialects of Ada.
+
+ -- Ada 95
+
+ -- The current instance of a limited type, and a formal parameter
+ -- or generic formal object of a tagged type.
+
+ -- Ada 95 limited type
+ -- * Type with reserved word "limited"
+ -- * A protected or task type
+ -- * A composite type with limited component
+
+ elsif Ada_Version <= Ada_95 then
+ return Is_Limited_Type (Typ);
+
+ -- Ada 2005
+
+ -- The current instance of a limited tagged type, a protected
+ -- type, a task type, or a type that has the reserved word
+ -- "limited" in its full definition ... a formal parameter or
+ -- generic formal object of a tagged type.
+
+ -- Ada 2005 limited type
+ -- * Type with reserved word "limited", "synchronized", "task"
+ -- or "protected"
+ -- * A composite type with limited component
+ -- * A derived type whose parent is a non-interface limited type
+
+ elsif Ada_Version = Ada_2005 then
+ return
+ (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ))
+ or else
+ (Is_Derived_Type (Typ)
+ and then not Is_Interface (Etype (Typ))
+ and then Is_Limited_Type (Etype (Typ)));
+
+ -- Ada 2012 and beyond
+
+ -- The current instance of an immutably limited type ... a formal
+ -- parameter or generic formal object of a tagged type.
+
+ -- Ada 2012 limited type
+ -- * Type with reserved word "limited", "synchronized", "task"
+ -- or "protected"
+ -- * A composite type with limited component
+ -- * A derived type whose parent is a non-interface limited type
+ -- * An incomplete view
+
+ -- Ada 2012 immutably limited type
+ -- * Explicitly limited record type
+ -- * Record extension with "limited" present
+ -- * Non-formal limited private type that is either tagged
+ -- or has at least one access discriminant with a default
+ -- expression
+ -- * Task type, protected type or synchronized interface
+ -- * Type derived from immutably limited type
+
+ else
+ return
+ Is_Immutably_Limited_Type (Typ)
+ or else Is_Incomplete_Type (Typ);
+ end if;
+ end Is_Aliased_View_Of_Type;
+
-------------
-- Process --
-------------
procedure Traverse is new Traverse_Proc (Process);
- -- Start of processing for Check_Current_Instance
-
- begin
- -- In Ada 95, the (imprecise) rule is that the current instance
- -- of a limited type is aliased. In Ada 2005, limitedness must be
- -- explicit: either a tagged type, or a limited record.
+ -- Local variables
- if Is_Limited_Type (Rec_Type)
- and then (Ada_Version < Ada_2005 or else Is_Tagged_Type (Rec_Type))
- then
- return;
+ Rec_Type : constant Entity_Id :=
+ Scope (Defining_Identifier (Comp_Decl));
- elsif Nkind (Decl) = N_Full_Type_Declaration
- and then Limited_Present (Type_Definition (Decl))
- then
- return;
+ -- Start of processing for Check_Current_Instance
- else
+ begin
+ if not Is_Aliased_View_Of_Type (Rec_Type) then
Traverse (Comp_Decl);
end if;
end Check_Current_Instance;
(Etype (Comp)))))
then
Set_Has_Controlled_Component (Rec);
- exit;
end if;
if Has_Unchecked_Union (Etype (Comp)) then
Set_Has_Unchecked_Union (Rec);
end if;
- if Has_Per_Object_Constraint (Comp) then
-
- -- Scan component declaration for likely misuses of current
- -- instance, either in a constraint or a default expression.
+ -- Scan component declaration for likely misuses of current
+ -- instance, either in a constraint or a default expression.
+ if Has_Per_Object_Constraint (Comp) then
Check_Current_Instance (Parent (Comp));
end if;
OSDN Git Service
