+2010-10-26 Robert Dewar <dewar@adacore.com>
+
+ * einfo.ads, einfo.adb (Is_Base_Type): New function, use it where
+ appropriate.
+ * exp_ch6.adb, exp_dbug.adb, exp_disp.adb, freeze.adb, lib-xref.adb,
+ sem_aux.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb (Is_Base_Type): Use
+ this new abstraction where appropriate.
+
+2010-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb: Code clean up.
+
+2010-10-26 Paul Hilfinger <hilfinger@adacore.com>
+
+ * exp_dbug.ads: Document effect of 'pragma Unchecked_Union' on
+ debugging data.
+
+2010-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Note_Possible_Modification): If the target of an
+ assignment is the bound variable in an iterator, the domain of
+ iteration, i.e. array or container, is modified as well.
+
+2010-10-26 Bob Duff <duff@adacore.com>
+
+ * Make-generated.in: Make the relevant make targets depend on
+ ceinfo.adb and csinfo.adb.
+ * csinfo.adb, ceinfo.adb: Make sure it raises an exception on failure,
+ so when called from xeinfo, the failure will be noticed.
+ * sinfo.ads: Update comments to reflect the fact that xsinfo runs csinfo
+ * xsinfo.adb, xeinfo.adb: Run ceinfo to check for errors. Close files.
+
+2010-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb: Set properly parent field of operands of concatenation.
+
+2010-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Check_Infinite_Recursion): A recursive call within a
+ conditional expression or a case expression should not generate an
+ infinite recursion warning.
+
2010-10-26 Javier Miranda <miranda@adacore.com>
* einfo.ads, einfo.adb (Is_Overriding_Operation): Removed.
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs
(cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs ../../treeprs.ads )
-$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb
+$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo
(cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo ../../einfo.h )
-$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/xsinfo.adb
+$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2010, 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- --
-- --
------------------------------------------------------------------------------
--- Program to check consistency of einfo.ads and einfo.adb. Checks that
--- field name usage is consistent, including comments mentioning fields.
+-- Check consistency of einfo.ads and einfo.adb. Checks that field name usage
+-- is consistent, including comments mentioning fields.
+
+-- Note that this is used both as a standalone program, and as a procedure
+-- called by XEinfo. This raises an unhandled exception if it finds any
+-- errors; we don't attempt any sophisticated error recovery.
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
Infil : File_Type;
Lineno : Natural := 0;
+ Err : exception;
+ -- Raised on error
+
Fieldnm : VString;
Accessfunc : VString;
Line : VString;
Put_Line
("*** unknown field name " & Fieldnm & " at line " & Lineno);
end if;
+ raise Err;
end if;
end if;
end loop;
Put_Line
("*** unknown field name " & Fieldnm & " at line " & Lineno);
end if;
+ raise Err;
end if;
end loop;
Put_Line ("*** incorrect field at line " & Lineno);
Put_Line (" found field " & Accessfunc);
Put_Line (" expecting field " & Get (Fields, Fieldnm));
+ raise Err;
end if;
end loop;
Put_Line ("*** incorrect field at line " & Lineno);
Put_Line (" found field " & Accessfunc);
Put_Line (" expecting field " & Get (Fields, Fieldnm));
+ raise Err;
end if;
end loop;
+ Close (Infil);
+
Put_Line ("All tests completed successfully, no errors detected");
end CEinfo;
-- --
------------------------------------------------------------------------------
--- Program to check consistency of sinfo.ads and sinfo.adb. Checks that field
--- name usage is consistent and that assertion cross-reference lists are
--- correct, as well as making sure that all the comments on field name usage
--- are consistent.
+-- Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage
+-- is consistent and that assertion cross-reference lists are correct, as well
+-- as making sure that all the comments on field name usage are consistent.
+
+-- Note that this is used both as a standalone program, and as a procedure
+-- called by XSinfo. This raises an unhandled exception if it finds any
+-- errors; we don't attempt any sophisticated error recovery.
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
New_Line;
Put_Line ("All tests completed successfully, no errors detected");
-exception
- when Done =>
- null;
-
end CSinfo;
procedure Set_Access_Disp_Table (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id));
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Associated_Storage_Pool (Id : E; V : E) is
begin
- pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Node22 (Id, V);
end Set_Associated_Storage_Pool;
procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is
begin
- pragma Assert (Is_Record_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag125 (Id, V);
end Set_C_Pass_By_Copy;
procedure Set_Component_Size (Id : E; V : U) is
begin
- pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
Set_Uint22 (Id, V);
end Set_Component_Size;
procedure Set_Component_Type (Id : E; V : E) is
begin
- pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
Set_Node20 (Id, V);
end Set_Component_Type;
procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id));
Set_Elist26 (Id, V);
end Set_Dispatch_Table_Wrappers;
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Access_Subprogram_Type (Id)
- and then Id = Base_Type (Id));
+ (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id));
Set_Flag229 (Id, V);
end Set_Can_Use_Internal_Rep;
procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag158 (Id, V);
end Set_Finalize_Storage_Only;
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
- pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
+ pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag86 (Id, V);
end Set_Has_Atomic_Components;
procedure Set_Has_Volatile_Components (Id : E; V : B := True) is
begin
- pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
+ pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag87 (Id, V);
end Set_Has_Volatile_Components;
procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is
begin
pragma Assert ((not V)
- or else (Is_Array_Type (Id) and then Id = Base_Type (Id)));
+ or else (Is_Array_Type (Id) and then Is_Base_Type (Id)));
Set_Flag122 (Id, V);
end Set_Is_Bit_Packed_Array;
procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Flag131 (Id, V);
end Set_No_Pool_Assigned;
procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Flag136 (Id, V);
end Set_No_Strict_Aliasing;
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag58 (Id, V);
end Set_Non_Binary_Modulus;
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Record_Type (Id) and then Id = Base_Type (Id));
+ (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag239 (Id, V);
end Set_OK_To_Reorder_Components;
procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
begin
- pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id));
Set_Node26 (Id, V);
end Set_Relative_Deadline_Variable;
procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Record_Type (Id) and then Id = Base_Type (Id));
+ (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag164 (Id, V);
end Set_Reverse_Bit_Order;
procedure Set_Universal_Aliasing (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag216 (Id, V);
end Set_Universal_Aliasing;
end if;
end Invariant_Procedure;
+ ------------------
+ -- Is_Base_Type --
+ ------------------
+
+ function Is_Base_Type (Id : E) return Boolean is
+ begin
+ return Id = Base_Type (Id);
+ end Is_Base_Type;
+
---------------------
-- Is_Boolean_Type --
---------------------
procedure Set_Component_Alignment (Id : E; V : C) is
begin
pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Id = Base_Type (Id));
+ and then Is_Base_Type (Id));
case V is
when Calign_Default =>
begin
if (Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Id = Base_Type (Id)
+ and then Is_Base_Type (Id)
then
Write_Str (Prefix);
Write_Str ("Component_Alignment = ");
-- Present in all type entities and in procedure entities. Set
-- if a pragma Asynchronous applies to the entity.
+-- Is_Base_Type (synthesized)
+-- Applies to type and subtype entities. True if entity is a base type
+
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
-- Present in all entities. This flag is set for a packed array type that
-- is bit packed (i.e. the component size is known by the front end and
function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
+ function Is_Base_Type (Id : E) return B;
function Is_Boolean_Type (Id : E) return B;
function Is_Constant_Object (Id : E) return B;
function Is_Discriminal (Id : E) return B;
-- things here which are small, but not of the canonical attribute
-- access/set format that can be handled by xeinfo.
+ pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
Opnd_Typ := Etype (Opnd);
-- The parent got messed up when we put the operands in a list,
- -- so now put back the proper parent for the saved operand.
+ -- so now put back the proper parent for the saved operand, that
+ -- is to say the concatenation node, to make sure that each operand
+ -- is seen as a subexpression, e.g. if actions must be inserted.
- Set_Parent (Opnd, Parent (Cnode));
+ Set_Parent (Opnd, Cnode);
-- Set will be True when we have setup one entry in the array
if Is_Derived_Type (Typ)
and then not Is_Private_Type (Typ)
and then In_Open_Scopes (Scope (Etype (Typ)))
- and then Typ = Base_Type (Typ)
+ and then Is_Base_Type (Typ)
then
-- Subp overrides an inherited private operation if there is an
-- inherited operation with a different name than Subp (see
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2010, 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- --
-- Or if this is an enumeration base type
- or else (Is_Enumeration_Type (E)
- and then E = Base_Type (E))
+ or else (Is_Enumeration_Type (E) and then Is_Base_Type (E))
-- Or if this is a dummy type for a renaming
-- where discrim is the unqualified name of the variant. This field name is
-- built by gigi (not by code in this unit). For Unchecked_Union record,
- -- this discriminant will not appear in the record, and the debugger must
- -- proceed accordingly (basically it can treat this case as it would a C
- -- union).
+ -- this discriminant will not appear in the record (see Unchecked Unions,
+ -- below).
-- The type corresponding to this field has a name that is obtained by
-- concatenating the type name with the above string and is similar to a C
-- The name of the union member is encoded to indicate the choices, and
-- is a string given by the following grammar:
- -- union_name ::= {choice} | others_choice
+ -- member_name ::= {choice} | others_choice
-- choice ::= simple_choice | range_choice
-- simple_choice ::= S number
-- range_choice ::= R number T number
-- V1 : Var;
- -- In this case, the type var is represented as a struct with three fields,
- -- the first two are "disc" and "m", representing the values of these
- -- record components.
-
- -- The third field is a union of two types, with field names S1 and O. S1
- -- is a struct with fields "r" and "s", and O is a struct with fields "t".
+ -- In this case, the type var is represented as a struct with three fields.
+ -- The first two are "disc" and "m", representing the values of these
+ -- record components. The third field is a union of two types, with field
+ -- names S1 and O. S1 is a struct with fields "r" and "s", and O is a
+ -- struct with field "t".
+
+ ----------------------
+ -- Unchecked Unions --
+ ----------------------
+
+ -- The encoding for variant records changes somewhat under the influence
+ -- of a "pragma Unchecked_Union" clause:
+
+ -- 1. The discriminant will not be present in the record, although its
+ -- name is still used in the encodings.
+ -- 2. Variants containing a single component named "x" of type "T" may
+ -- be encoded, as in ordinary C unions, as a single field of the
+ -- enclosing union type named "x" of type "T", dispensing with the
+ -- enclosing struct. In this case, of course, the discriminant values
+ -- corresponding to the variant are unavailable. As for normal
+ -- variants, the field name "x" may be suffixed with ___XVL if it
+ -- has dynamic size.
+
+ -- For example, the type Var in the preceding section, if followed by
+ -- "pragma Unchecked_Union (Var);" may be encoded as a struct with two
+ -- fields. The first is "m". The second field is a union of two types,
+ -- with field names S1 and "t". As before, S1 is a struct with fields
+ -- "r" and "s". "t" is a field of type Integer.
------------------------------------------------
-- Subprograms for Handling Variant Encodings --
(Nkind (Parent (Typ)) = N_Private_Extension_Declaration
and then Is_Generic_Type (Typ)))
and then In_Open_Scopes (Scope (Etype (Typ)))
- and then Typ = Base_Type (Typ)
+ and then Is_Base_Type (Typ)
then
Handle_Inherited_Private_Subprograms (Typ);
end if;
-- Set OK_To_Reorder_Components depending on debug flags
- if Rec = Base_Type (Rec)
- and then Convention (Rec) = Convention_Ada
- then
+ if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then
if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V)
or else
(not Has_Discriminants (Rec) and then Debug_Flag_Dot_R)
-- these till the freeze-point since we need the small and range
-- values. We only do these checks for base types
- if Is_Ordinary_Fixed_Point_Type (E)
- and then E = Base_Type (E)
- then
+ if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then
if Small_Value (E) < Ureal_2_M_80 then
Error_Msg_Name_1 := Name_Small;
Error_Msg_N
-- only to base types.
if Present (Default_Pool)
- and then E = Base_Type (E)
+ and then Is_Base_Type (E)
and then not Has_Storage_Size_Clause (E)
and then No (Associated_Storage_Pool (E))
then
if Is_Type (Ent)
and then Is_Tagged_Type (Ent)
- and then Ent = Base_Type (Ent)
+ and then Is_Base_Type (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
Generate_Prim_Op_References (Ent);
if Is_Type (Ent)
and then Is_Tagged_Type (Ent)
and then Is_Derived_Type (Ent)
- and then Ent = Base_Type (Ent)
+ and then Is_Base_Type (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
declare
-- If this is first subtype, or is a base type, then there is no
-- ancestor subtype, so we return Empty to indicate this fact.
- if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then
+ if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
return Empty;
end if;
and then Is_Private_Type (Designated_Type (T))
and then not Has_Private_View (N)
and then Present (Full_View (Designated_Type (T)))
+ and then Used_As_Generic_Actual (T)
then
Switch_View (Designated_Type (T));
Set_Direct_Primitive_Operations (Full,
Direct_Primitive_Operations (Priv));
- if Priv = Base_Type (Priv) then
+ if Is_Base_Type (Priv) then
Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
end if;
end if;
(Nkind (Parent (E)) = N_Private_Extension_Declaration
and then Is_Generic_Type (E)))
and then In_Open_Scopes (Scope (Etype (E)))
- and then E = Base_Type (E)
+ and then Is_Base_Type (E)
then
if Is_Tagged_Type (E) then
Op_List := Primitive_Operations (E);
------------------------------
procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
- Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
+ Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
begin
Set_Size_Info (Priv, (Full));
while Present (Id)
and then Id /= Priv_Id
loop
- if Is_Standard_Character_Type (Id)
- and then Id = Base_Type (Id)
- then
+ if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then
+
-- We replace the node with the literal itself, resolve as a
-- character, and set the type correctly.
when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor =>
while Id /= Priv_Id loop
- if Valid_Boolean_Arg (Id)
- and then Id = Base_Type (Id)
- then
+ if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then
Add_Implicit_Operator (Id);
return True;
end if;
while Id /= Priv_Id loop
if Is_Type (Id)
and then not Is_Limited_Type (Id)
- and then Id = Base_Type (Id)
+ and then Is_Base_Type (Id)
then
Add_Implicit_Operator (Standard_Boolean, Id);
return True;
when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
while Id /= Priv_Id loop
if (Is_Scalar_Type (Id)
- or else (Is_Array_Type (Id)
- and then Is_Scalar_Type (Component_Type (Id))))
- and then Id = Base_Type (Id)
+ or else (Is_Array_Type (Id)
+ and then Is_Scalar_Type (Component_Type (Id))))
+ and then Is_Base_Type (Id)
then
Add_Implicit_Operator (Standard_Boolean, Id);
return True;
Name_Op_Divide |
Name_Op_Expon =>
while Id /= Priv_Id loop
- if Is_Numeric_Type (Id)
- and then Id = Base_Type (Id)
- then
+ if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then
Add_Implicit_Operator (Id);
return True;
end if;
when Name_Op_Concat =>
while Id /= Priv_Id loop
- if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
- and then Id = Base_Type (Id)
+ if Is_Array_Type (Id)
+ and then Number_Dimensions (Id) = 1
+ and then Is_Base_Type (Id)
then
Add_Implicit_Operator (Id);
return True;
if Nkind_In (P, N_Or_Else,
N_And_Then,
- N_If_Statement,
- N_Case_Statement)
+ N_Case_Expression,
+ N_Case_Statement,
+ N_Conditional_Expression,
+ N_If_Statement)
then
return False;
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
- -- not need to test the case below for further warnings. Also if
+ -- not need to test the case below for further warnings. Also, if
-- we now have a raise SE node, we are all done.
if Nkind (N) = N_Raise_Storage_Error then
-- this situation can arise in source code.
elsif In_Instance or else In_Inlined_Body then
- return True;
+ return True;
-- Otherwise we need the conversion check
if Modification_Comes_From_Source then
Generate_Reference (Ent, Exp, 'm');
+
+ -- If the target of the assignment is the bound variable
+ -- in an iterator, indicate that the corresponding array
+ -- or container is also modified.
+
+ if Ada_Version >= Ada_2012
+ and then
+ Nkind (Parent (Ent)) = N_Iterator_Specification
+ then
+ declare
+ Domain : constant Node_Id := Name (Parent (Ent));
+
+ begin
+ -- TBD : in the full version of the construct, the
+ -- domain of iteration can be given by an expression.
+
+ if Is_Entity_Name (Domain) then
+ Generate_Reference (Entity (Domain), Exp, 'm');
+ Set_Is_True_Constant (Entity (Domain), False);
+ Set_Never_Set_In_Source (Entity (Domain), False);
+ end if;
+ end;
+ end if;
end if;
Check_Nested_Access (Ent);
-- Finally, four utility programs must be run:
- -- Run CSinfo to check that you have made the changes consistently. It
- -- checks most of the rules given above, with clear error messages. This
- -- utility reads sinfo.ads and sinfo.adb and generates a report to
- -- standard output.
+ -- (Optional.) Run CSinfo to check that you have made the changes
+ -- consistently. It checks most of the rules given above. This utility
+ -- reads sinfo.ads and sinfo.adb and generates a report to standard
+ -- output. This step is optional because XSinfo runs CSinfo.
-- Run XSinfo to create sinfo.h, the corresponding C header. This
-- utility reads sinfo.ads and generates sinfo.h. Note that it does
-- spec of the Nmake package which contains functions for constructing
-- nodes.
- -- All of the above steps except CSinfo are done automatically by the
- -- build scripts when you do a full bootstrap.
+ -- The above steps are done automatically by the build scripts when you do
+ -- a full bootstrap.
-- Note: sometime we could write a utility that actually generated the body
-- of sinfo from the spec instead of simply checking it, since, as noted
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
+with CEinfo;
+
procedure XEinfo is
package TB renames GNAT.Spitbol.Table_Boolean;
-- Start of processing for XEinfo
begin
+ -- First run CEinfo to check for errors. Note that CEinfo is also a
+ -- stand-alone program that can be run separately.
+
+ CEinfo;
+
Anchored_Mode := True;
if Argument_Count > 0 then
(Ofile,
"/* End of einfo.h (C version of Einfo package specification) */");
+ Close (InF);
+ Close (Ofile);
+
exception
when Err =>
Put_Line (Standard_Error, Lineno & ". " & Line);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- sinfo.h Corresponding c header file
--- Note: this program assumes that sinfo.ads has passed the error checks
--- which are carried out by the CSinfo utility, so it does not duplicate
--- these checks and assumes the source is correct.
-
-- An optional argument allows the specification of an output file name to
-- override the default sinfo.h file name for the generated output file.
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
+with CSinfo;
+
procedure XSinfo is
Done : exception;
-- Start of processing for XSinfo
begin
+ -- First run CSinfo to check for errors. Note that CSinfo is also a
+ -- stand-alone program that can be run separately.
+
+ CSinfo;
+
Set_Exit_Status (1);
Anchored_Mode := True;
Getline;
end loop;
+ -- Can't get here; above loop only left via raise
exception
when Done =>
+ Close (InS);
Put_Line (Ofile, "");
+ Close (Ofile);
Set_Exit_Status (0);
end XSinfo;
OSDN Git Service
