mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-03-22 22:51:32 +08:00
[multiple changes]
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. From-SVN: r165946
This commit is contained in:
Arnaud Charlet
parent
038140ede0
commit
d347f5722f
@ -1,3 +1,45 @@
|
||||
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.
|
||||
|
||||
@ -29,13 +29,13 @@ $(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/
|
||||
$(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
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -23,8 +23,12 @@
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
@ -42,6 +46,9 @@ procedure CEinfo is
|
||||
Infil : File_Type;
|
||||
Lineno : Natural := 0;
|
||||
|
||||
Err : exception;
|
||||
-- Raised on error
|
||||
|
||||
Fieldnm : VString;
|
||||
Accessfunc : VString;
|
||||
Line : VString;
|
||||
@ -126,6 +133,7 @@ begin
|
||||
Put_Line
|
||||
("*** unknown field name " & Fieldnm & " at line " & Lineno);
|
||||
end if;
|
||||
raise Err;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
@ -153,6 +161,7 @@ begin
|
||||
Put_Line
|
||||
("*** unknown field name " & Fieldnm & " at line " & Lineno);
|
||||
end if;
|
||||
raise Err;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
@ -172,6 +181,7 @@ begin
|
||||
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;
|
||||
|
||||
@ -196,9 +206,12 @@ begin
|
||||
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;
|
||||
|
||||
@ -23,10 +23,13 @@
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
@ -635,8 +638,4 @@ begin
|
||||
New_Line;
|
||||
Put_Line ("All tests completed successfully, no errors detected");
|
||||
|
||||
exception
|
||||
when Done =>
|
||||
null;
|
||||
|
||||
end CSinfo;
|
||||
|
||||
@ -2996,7 +2996,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3018,7 +3018,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3082,7 +3082,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3122,13 +3122,13 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3302,7 +3302,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3477,8 +3477,7 @@ package body Einfo is
|
||||
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;
|
||||
|
||||
@ -3489,7 +3488,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3597,7 +3596,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -3995,7 +3994,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -4118,7 +4117,7 @@ package body Einfo is
|
||||
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;
|
||||
@ -4736,7 +4735,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -4749,13 +4748,13 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -4800,7 +4799,7 @@ package body Einfo is
|
||||
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;
|
||||
|
||||
@ -4974,7 +4973,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -5023,7 +5022,7 @@ package body Einfo is
|
||||
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;
|
||||
|
||||
@ -5209,7 +5208,7 @@ package body Einfo is
|
||||
|
||||
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;
|
||||
|
||||
@ -6167,6 +6166,15 @@ package body Einfo is
|
||||
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 --
|
||||
---------------------
|
||||
@ -6977,7 +6985,7 @@ package body Einfo is
|
||||
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 =>
|
||||
@ -7264,7 +7272,7 @@ package body Einfo is
|
||||
|
||||
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 = ");
|
||||
|
||||
@ -1992,6 +1992,9 @@ package Einfo is
|
||||
-- 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
|
||||
@ -6341,6 +6344,7 @@ package Einfo is
|
||||
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;
|
||||
@ -7976,6 +7980,7 @@ package Einfo is
|
||||
-- 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);
|
||||
|
||||
@ -2493,9 +2493,11 @@ package body Exp_Ch4 is
|
||||
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
|
||||
|
||||
|
||||
@ -600,7 +600,7 @@ package body Exp_Ch6 is
|
||||
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
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -529,8 +529,7 @@ package body Exp_Dbug is
|
||||
|
||||
-- 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
|
||||
|
||||
|
||||
@ -1323,9 +1323,8 @@ package Exp_Dbug is
|
||||
|
||||
-- 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
|
||||
@ -1338,7 +1337,7 @@ package Exp_Dbug is
|
||||
-- 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
|
||||
@ -1377,12 +1376,34 @@ package Exp_Dbug is
|
||||
|
||||
-- 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.
|
||||
-- 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".
|
||||
|
||||
-- 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".
|
||||
----------------------
|
||||
-- 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 --
|
||||
|
||||
@ -7359,7 +7359,7 @@ package body Exp_Disp is
|
||||
(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;
|
||||
|
||||
@ -2062,9 +2062,7 @@ package body Freeze is
|
||||
|
||||
-- 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)
|
||||
@ -3818,9 +3816,7 @@ package body Freeze is
|
||||
-- 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
|
||||
@ -3865,7 +3861,7 @@ package body Freeze is
|
||||
-- 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
|
||||
|
||||
@ -1172,7 +1172,7 @@ package body Lib.Xref is
|
||||
|
||||
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);
|
||||
@ -1281,7 +1281,7 @@ package body Lib.Xref is
|
||||
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
|
||||
|
||||
@ -48,7 +48,7 @@ package body Sem_Aux is
|
||||
-- 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;
|
||||
|
||||
|
||||
@ -5501,6 +5501,7 @@ package body Sem_Ch12 is
|
||||
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));
|
||||
|
||||
|
||||
@ -11716,7 +11716,7 @@ package body Sem_Ch3 is
|
||||
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;
|
||||
|
||||
@ -1500,7 +1500,7 @@ package body Sem_Ch7 is
|
||||
(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);
|
||||
@ -2010,7 +2010,7 @@ package body Sem_Ch7 is
|
||||
------------------------------
|
||||
|
||||
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));
|
||||
|
||||
@ -6001,9 +6001,8 @@ package body Sem_Ch8 is
|
||||
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.
|
||||
|
||||
@ -6164,9 +6163,7 @@ package body Sem_Ch8 is
|
||||
|
||||
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;
|
||||
@ -6180,7 +6177,7 @@ package body Sem_Ch8 is
|
||||
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;
|
||||
@ -6194,9 +6191,9 @@ package body Sem_Ch8 is
|
||||
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;
|
||||
@ -6216,9 +6213,7 @@ package body Sem_Ch8 is
|
||||
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;
|
||||
@ -6230,8 +6225,9 @@ package body Sem_Ch8 is
|
||||
|
||||
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;
|
||||
|
||||
@ -819,8 +819,10 @@ package body Sem_Res is
|
||||
|
||||
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;
|
||||
|
||||
@ -5277,7 +5279,7 @@ package body Sem_Res is
|
||||
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
|
||||
@ -10095,7 +10097,7 @@ package body Sem_Res is
|
||||
-- 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
|
||||
|
||||
|
||||
@ -9648,6 +9648,29 @@ package body Sem_Util is
|
||||
|
||||
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);
|
||||
|
||||
@ -100,10 +100,10 @@ package Sinfo is
|
||||
|
||||
-- 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
|
||||
@ -120,8 +120,8 @@ package Sinfo is
|
||||
-- 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
|
||||
|
||||
@ -57,6 +57,8 @@ with GNAT.Spitbol; use GNAT.Spitbol;
|
||||
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;
|
||||
@ -241,6 +243,11 @@ procedure XEinfo is
|
||||
-- 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
|
||||
@ -489,6 +496,9 @@ begin
|
||||
(Ofile,
|
||||
"/* End of einfo.h (C version of Einfo package specification) */");
|
||||
|
||||
Close (InF);
|
||||
Close (Ofile);
|
||||
|
||||
exception
|
||||
when Err =>
|
||||
Put_Line (Standard_Error, Lineno & ". " & Line);
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -35,10 +35,6 @@
|
||||
|
||||
-- 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.
|
||||
|
||||
@ -50,6 +46,8 @@ with Ada.Text_IO; use Ada.Text_IO;
|
||||
with GNAT.Spitbol; use GNAT.Spitbol;
|
||||
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
||||
|
||||
with CSinfo;
|
||||
|
||||
procedure XSinfo is
|
||||
|
||||
Done : exception;
|
||||
@ -115,6 +113,11 @@ procedure XSinfo is
|
||||
-- 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;
|
||||
|
||||
@ -238,10 +241,13 @@ begin
|
||||
|
||||
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;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user