OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Variable-sized node types 

gcc/ada/

	* atree.ads, atree.adb: Major rewrite to support variable-sized
	node types. Add pragmas Suppress and Assertion_Policy.  We now
	have an extra level of indirection: Node_Offsets is a table
	mapping Node_Ids to the offset of the start of each node in
	Slots. Slots is a table containing one or more contiguous slots
	for each node. Each slot is a 32-bit unchecked union that can
	contain any mixture of 1, 2, 4, 8, and 32-bit fields that fits.
	The old low-level getters and setters (e.g.  Flag123) are
	removed.
	* gen_il-fields.ads, gen_il-gen-gen_entities.adb,
	gen_il-gen-gen_nodes.adb, gen_il-gen.adb, gen_il-gen.ads,
	gen_il-main.adb, gen_il-types.ads, gen_il-utils.adb,
	gen_il-utils.ads, gen_il.adb, gen_il.ads: New gen_il program
	that generates various Ada and C++ files. In particular, the
	following files are generated by gen_il: einfo-entities.adb
	einfo-entities.ads, gnatvsn.ads, nmake.adb, nmake.ads,
	seinfo.ads, seinfo_tables.adb, seinfo_tables.ads,
	sinfo-nodes.adb, sinfo-nodes.ads, einfo.h, and sinfo.h.
	* sinfo-utils.adb, sinfo-utils.ads, einfo-utils.adb,
	einfo-utils.ads: New files containing code that needs to refer
	to Sinfo.Nodes and Einfo.Entities. This code is mostly moved
	here from Sinfo and Einfo to break cycles.
	* back_end.adb: Pass node_offsets_ptr and slots_ptr to gigi,
	instead of nodes_ptr and flags_ptr. The Nodes and Flags tables
	no longer exist. (Note that gigi never used the Flags table.)
	* sinfo-cn.ads (Change_Identifier_To_Defining_Identifier,
	Change_Character_Literal_To_Defining_Character_Literal,
	Change_Operator_Symbol_To_Defining_Operator_Symbol): Turn N into
	an IN formal.
	* sinfo-cn.adb: Update.  Add assertions, which can be removed at
	some point.  Rewrite to use higher-level facilities.  Make sure
	vanishing fields are zeroed out.  Add with/use for new packages.
	* sem_util.adb: Remove "Assert(False)" immediately followed by
	"raise Program_Error".  Use higher-level facilities such as
	Walk_Sinfo_Fields instead of depending on low-level Set_FieldN
	routines that no longer exist. Use Get_Comes_From_Source_Default
	instead of Default_Node.Comes_From_Source (Default_Node no
	longer exists).  Use Set_Basic_Convention instead of
	Basic_Set_Convention.  Add with/use for new packages.
	* sem_util.ads: The Convention field had getter Convention and
	setter Basic_Set_Convention. Make that more uniform: there is
	now a field called Basic_Convention, with Basic_Convention and
	Set_Basic_Convention as getter/setter, and write Convention and
	Set_Convention here.
	* nlists.adb: Rewrite to use abstractions, rather then depending
	on low-level implementation details of Atree. Necessary because
	those details have changed. Add with/use for new packages.
	* sem_ch12.adb: Use higher-level facilities such as
	Walk_Sinfo_Fields instead of depending on low-level Set_FieldN
	routines that no longer exist. Add with/use for new packages.
	* exp_cg.adb, sem_ch10.adb, sem_ch4.adb, sem_eval.adb,
	sem_prag.adb, sem_warn.adb: Change expanded names to refer to
	the new packages for things that moved. Add with/use for new
	packages.
	* sem_ch3.adb: Likewise. Reinitialize vanishing fields.
	* exp_disp.adb: Likewise. Remove failing assertion.
	* sinfo.ads, einfo.ads: Remove code that is now generated into
	Sinfo.Nodes and Einfo.Entities.
	* sinfo.adb, einfo.adb: Replace bodies with "pragma No_Body;".
	We should delete these at some point, but No_Body makes make
	files easier. Some code is moved to Sinfo.Nodes, Einfo.Entities,
	Sinfo.Utils, and Einfo.Utils. Some is no longer necessary.
	* treepr.adb: Rewrite to use new tables. We no longer need
	treeprs.ads.
	* treepr.ads: Add comment.
	* types.ads: Move types Component_Alignment_Kind and
	Float_Rep_Kind here.
	* atree.h: Major update to match atree.ads changes.  Add slot
	types, for use by getters/setters.
	* types.h: Move types Component_Alignment_Kind and
	Float_Rep_Kind here.
	* fe.h: Rewrite to deal with code that has changed or moved from
	Atree, Sinfo, Einfo.
	* nlists.h: Move some code to fe.h.
	* alloc.ads: Split Nodes_* constants into Node_Offsets and
	Slots, because Atree has two separate tables.  Increase values.
	Remove Nodes_Release_Threshold. Improve comment.
	* debug.adb, gnat1drv.adb: Remove obsolete gnatd.A and gnatd.N
	switches.  Add with/use for new packages.
	* opt.ads: Minor comment fix.
	* aspects.adb, checks.adb, comperr.adb, contracts.adb,
	cstand.adb, debug_a.adb, errout.adb, eval_fat.adb, exp_aggr.adb,
	exp_atag.adb, exp_attr.adb, exp_ch11.adb, exp_ch12.adb,
	exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch4.adb,
	exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch8.adb, exp_ch9.adb,
	exp_code.adb, exp_dbug.adb, exp_dist.adb, exp_fixd.adb,
	exp_imgv.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb,
	exp_put_image.adb, exp_sel.adb, exp_smem.adb, exp_spark.adb,
	exp_strm.adb, exp_tss.adb, exp_unst.adb, exp_util.adb,
	exp_util.ads, expander.adb, freeze.adb, frontend.adb,
	get_targ.ads, ghost.adb, gnat_cuda.adb, impunit.adb, inline.adb,
	itypes.adb, itypes.ads, layout.adb, lib.adb, lib-load.adb,
	lib-writ.adb, lib-xref.adb, lib-xref.ads,
	lib-xref-spark_specific.adb, live.adb, par.adb, par_sco.adb,
	pprint.adb, repinfo.adb, restrict.adb, rtsfind.adb, scil_ll.adb,
	scn.adb, sem.adb, sem.ads, sem_aggr.adb, sem_attr.adb,
	sem_aux.adb, sem_case.adb, sem_cat.adb, sem_ch11.adb,
	sem_ch13.adb, sem_ch2.adb, sem_ch5.adb, sem_ch6.adb,
	sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, sem_dim.adb,
	sem_disp.adb, sem_dist.adb, sem_elab.adb, sem_elim.adb,
	sem_intr.adb, sem_mech.adb, sem_res.adb, sem_scil.adb,
	sem_smem.adb, sem_type.adb, set_targ.ads, sinput.adb,
	sinput-l.adb, sprint.adb, style.adb, styleg.adb, tbuild.adb,
	tbuild.ads, uname.adb: Add with/use for new packages.
	* libgnat/a-stoubu.adb, libgnat/a-stouut.adb: Simplify to ease
	bootstrap.
	* libgnat/a-stobfi.adb, libgnat/a-stoufi.adb (Create_File,
	Create_New_File): Create file in binary format, to avoid
	introducing unwanted text conversions on Windows. Simplify to
	ease bootstrap.
	* libgnat/a-stteou__bootstrap.ads: New.
	* ceinfo.adb, csinfo.adb, nmake.adt, treeprs.adt, xeinfo.adb,
	xnmake.adb, xsinfo.adb, xtreeprs.adb: Delete.
	* Make-generated.in: Build and run the gen_il program to
	generate files. The files are generated in the ada/gen_il
	subdirectory, and then moved up to ada.  We rely on gnatmake (as
	opposed to make) to build the gen_il program efficiently (i.e.
	don't do anything if the sources didn't change).
	* gcc-interface/Makefile.in (ADAFLAGS): Add -gnatU.
	(GNATMAKE_OBJS): Add new object files.
	(GENERATED_FILES_FOR_TOOLS): New variable.
	(../stamp-tools): Create a link for all
	GENERATED_FILES_FOR_TOOLS.
	* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add new object
	files.  Remove ada/treeprs.o.
	(GNATBIND_OBJS): Add new object files.
	(ada.mostlyclean): Remove ada/sdefault.adb and add
	ada/stamp-gen_il.
	(ada.maintainer-clean): Remove ada/treeprs.ads.
	(update-sources): Remove obsolete target.
	(ada_generated_files): Rename to...
	(ADA_GENERATED_FILES): ... this.  Add new source files.  Add
	comment.

	* gcc-interface/trans.c: Remove obsolete Nodes_Ptr and
	Flags_ptr.  Add Node_Offsets_Ptr and Slots_Ptr, which point to
	the corresponding tables in Atree.
	* gcc-interface/gigi.h (gigi): New parameters for initializing
	Node_Offsets_Ptr and Slots_Ptr.
	* gcc-interface/decl.c: Numeric_Kind,
	Discrete_Or_Fixed_Point_Kind, and Record_Kind were
	nonhierarchical, and were therefore removed for simplicity.
	Replace uses with calls to Is_In_... functions.

gnattools/

	* Makefile.in (GENERATED_FILES_FOR_TOOLS): New variable.
	($(GCC_DIR)/stamp-tools): Walk it for the first copy operation.
This commit is contained in:
Bob Duff 2021-02-03 05:31:16 -05:00 committed by Pierre-Marie de Rodat
parent 476ed6bf66
commit 76f9c7f44f
167 changed files with 17800 additions and 43307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
gcc/ada/Make-generated.in
View File

@ -2,10 +2,6 @@
# Note: can't use ?= here, not supported by older versions of GNU Make
ifeq ($(origin ADA_GEN_SUBDIR), undefined)
ADA_GEN_SUBDIR=ada
endif
ifeq ($(origin CP), undefined)
CP=cp
endif
@ -14,60 +10,84 @@ ifeq ($(origin MKDIR), undefined)
MKDIR=mkdir -p
endif
ifeq ($(origin MOVE_IF_CHANGE), undefined)
MOVE_IF_CHANGE=mv -f
endif
fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND})
.PHONY: ada_extra_files
ada_extra_files : $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/nmake.adb \
$(ADA_GEN_SUBDIR)/nmake.ads $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb $(ADA_GEN_SUBDIR)/snames.h
GEN_IL_INCLUDES = -I$(fsrcdir)/ada
GEN_IL_FLAGS = -a -q -g -gnata -j0 -gnat2012 -gnatw.g -gnatyg -gnatU $(GEN_IL_INCLUDES)
# We delete the files before copying, below, in case they are read-only.
.PHONY: do_gen_il
do_gen_il:
$(MKDIR) ada/gen_il
$(MKDIR) ada/generated
# Copy recent runtime files needed by gen_il that may not be available
# in the base compiler.
$(CP) -f $(fsrcdir)/ada/libgnat/a-sto*.ad? ada/gen_il
$(CP) -f $(fsrcdir)/ada/libgnat/a-stteou__bootstrap.ads ada/gen_il/a-stteou.ads
cd ada/gen_il ; gnatmake $(GEN_IL_FLAGS) gen_il-main.adb
# ignore errors when running gen_il-main due to bootstrap
# considerations
-cd ada/gen_il ; ./gen_il-main
$(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/xtreeprs.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs
(cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs treeprs.ads )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/treeprs/treeprs.ads $(ADA_GEN_SUBDIR)/treeprs.ads
ada/seinfo_tables.ads: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.ads ada/seinfo_tables.ads
$(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 )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/einfo/einfo.h $(ADA_GEN_SUBDIR)/einfo.h
ada/seinfo_tables.adb: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.adb ada/seinfo_tables.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
(cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo sinfo.h )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/sinfo/sinfo.h $(ADA_GEN_SUBDIR)/sinfo.h
# We need -gnatX to compile seinfo_tables, because it uses extensions. This
# target is not currently used when building gnat, because these extensions
# would cause bootstrapping with older compilers to fail. You can call it by
# hand, as a sanity check that these files are legal.
ada/seinfo_tables.o: ada/seinfo_tables.ads ada/seinfo_tables.adb
cd ada ; time gnatmake $(GEN_IL_INCLUDES) seinfo_tables.adb -gnatU -gnatX
$(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true
$(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUBDIR)/snames.adb-tmpl $(ADA_GEN_SUBDIR)/snames.h-tmpl $(ADA_GEN_SUBDIR)/xsnamest.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/snamest
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/snamest/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/snamest
(cd $(ADA_GEN_SUBDIR)/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.ns $(ADA_GEN_SUBDIR)/snames.ads
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nb $(ADA_GEN_SUBDIR)/snames.adb
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h
touch $(ADA_GEN_SUBDIR)/stamp-snames
ada/sinfo.h: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/sinfo.h ada/sinfo.h
$(ADA_GEN_SUBDIR)/nmake.adb $(ADA_GEN_SUBDIR)/nmake.ads: $(ADA_GEN_SUBDIR)/stamp-nmake ; @true
$(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake
(cd $(ADA_GEN_SUBDIR)/bldtools/nmake; gnatmake -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads)
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.ads $(ADA_GEN_SUBDIR)/nmake.ads
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb
touch $(ADA_GEN_SUBDIR)/stamp-nmake
ada/einfo.h: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/einfo.h ada/einfo.h
$(ADA_GEN_SUBDIR)/sdefault.adb: $(ADA_GEN_SUBDIR)/stamp-sdefault ; @true
$(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile
ada/nmake.ads: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/nmake.ads ada/nmake.ads
$(CP) ada/nmake.ads ada/generated
ada/nmake.adb: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/nmake.adb ada/nmake.adb
$(CP) ada/nmake.adb ada/generated
ada/seinfo.ads: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/seinfo.ads ada/seinfo.ads
$(CP) ada/seinfo.ads ada/generated
ada/sinfo-nodes.ads: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/sinfo-nodes.ads ada/sinfo-nodes.ads
$(CP) ada/sinfo-nodes.ads ada/generated
ada/sinfo-nodes.adb: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/sinfo-nodes.adb ada/sinfo-nodes.adb
$(CP) ada/sinfo-nodes.adb ada/generated
ada/einfo-entities.ads: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/einfo-entities.ads ada/einfo-entities.ads
$(CP) ada/einfo-entities.ads ada/generated
ada/einfo-entities.adb: do_gen_il
$(fsrcdir)/../move-if-change ada/gen_il/einfo-entities.adb ada/einfo-entities.adb
$(CP) ada/einfo-entities.adb ada/generated
ada/snames.h ada/snames.ads ada/snames.adb : ada/stamp-snames ; @true
ada/stamp-snames : ada/snames.ads-tmpl ada/snames.adb-tmpl ada/snames.h-tmpl ada/xsnamest.adb ada/xutil.ads ada/xutil.adb
-$(MKDIR) ada/bldtools/snamest
$(RM) $(addprefix ada/bldtools/snamest/,$(notdir $^))
$(CP) $^ ada/bldtools/snamest
cd ada/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest
$(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.ns ada/snames.ads
$(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nb ada/snames.adb
$(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nh ada/snames.h
touch ada/stamp-snames
ada/sdefault.adb: ada/stamp-sdefault ; @true
ada/stamp-sdefault : $(srcdir)/version.c Makefile
$(ECHO) "pragma Style_Checks (Off);" >tmp-sdefault.adb
$(ECHO) "with Osint; use Osint;" >>tmp-sdefault.adb
$(ECHO) "package body Sdefault is" >>tmp-sdefault.adb
@ -93,5 +113,5 @@ $(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile
$(ECHO) " return Relocate_Path (S0, S4);" >>tmp-sdefault.adb
$(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb
$(ECHO) "end Sdefault;" >> tmp-sdefault.adb
$(MOVE_IF_CHANGE) tmp-sdefault.adb $(ADA_GEN_SUBDIR)/sdefault.adb
touch $(ADA_GEN_SUBDIR)/stamp-sdefault
$(fsrcdir)/../move-if-change tmp-sdefault.adb ada/sdefault.adb
touch ada/stamp-sdefault

10
gcc/ada/alloc.ads
View File

@ -35,7 +35,7 @@
package Alloc is
-- The comment shows the unit in which the table is defined
-- The comment shows the unit in which the tables are defined
All_Interp_Initial : constant := 1_000; -- Sem_Type
All_Interp_Increment : constant := 100;
@ -94,9 +94,11 @@ package Alloc is
Names_Initial : constant := 6_000; -- Namet
Names_Increment : constant := 100;
Nodes_Initial : constant := 50_000; -- Atree
Nodes_Increment : constant := 100;
Nodes_Release_Threshold : constant := 100_000;
Node_Offsets_Initial : constant := 500_000; -- Atree, Nlists
Node_Offsets_Increment : constant := 100;
Slots_Initial : constant := 2_000_000; -- Atree
Slots_Increment : constant := 100;
Notes_Initial : constant := 100; -- Lib
Notes_Increment : constant := 200;

12
gcc/ada/aspects.adb
View File

@ -24,9 +24,13 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with GNAT.HTable;
@ -224,7 +228,7 @@ package body Aspects is
while Present (Item) loop
if Nkind (Item) = N_Aspect_Specification
and then Get_Aspect_Id (Item) = A
and then Class_Present = Sinfo.Class_Present (Item)
and then Class_Present = Sinfo.Nodes.Class_Present (Item)
then
return Item;
end if;
@ -248,7 +252,7 @@ package body Aspects is
Spec := First (Aspect_Specifications (Decl));
while Present (Spec) loop
if Get_Aspect_Id (Spec) = A
and then Class_Present = Sinfo.Class_Present (Spec)
and then Class_Present = Sinfo.Nodes.Class_Present (Spec)
then
return Spec;
end if;

8996
gcc/ada/atree.adb
View File

File diff suppressed because it is too large Load Diff

3728
gcc/ada/atree.ads
View File

File diff suppressed because it is too large Load Diff

941
gcc/ada/atree.h
View File

@ -35,353 +35,12 @@
extern "C" {
#endif
/* Structure used for the first part of the node in the case where we have
an Nkind. */
struct NFK
{
Boolean is_extension : 1;
Boolean pflag1 : 1;
Boolean pflag2 : 1;
Boolean in_list : 1;
Boolean has_aspects : 1;
Boolean rewrite_ins : 1;
Boolean analyzed : 1;
Boolean c_f_s : 1;
Boolean error_posted : 1;
Boolean flag4 : 1;
Boolean flag5 : 1;
Boolean flag6 : 1;
Boolean flag7 : 1;
Boolean flag8 : 1;
Boolean flag9 : 1;
Boolean flag10 : 1;
Boolean flag11 : 1;
Boolean flag12 : 1;
Boolean flag13 : 1;
Boolean flag14 : 1;
Boolean flag15 : 1;
Boolean flag16 : 1;
Boolean flag17 : 1;
Boolean flag18 : 1;
unsigned char kind;
};
/* Structure for the first part of a node when Nkind is not present by
extra flag bits are. */
struct NFNK
{
Boolean is_extension : 1;
Boolean pflag1 : 1;
Boolean pflag2 : 1;
Boolean in_list : 1;
Boolean has_aspects : 1;
Boolean rewrite_ins : 1;
Boolean analyzed : 1;
Boolean c_f_s : 1;
Boolean error_posted : 1;
Boolean flag4 : 1;
Boolean flag5 : 1;
Boolean flag6 : 1;
Boolean flag7 : 1;
Boolean flag8 : 1;
Boolean flag9 : 1;
Boolean flag10 : 1;
Boolean flag11 : 1;
Boolean flag12 : 1;
Boolean flag13 : 1;
Boolean flag14 : 1;
Boolean flag15 : 1;
Boolean flag16 : 1;
Boolean flag17 : 1;
Boolean flag18 : 1;
Boolean flag65 : 1;
Boolean flag66 : 1;
Boolean flag67 : 1;
Boolean flag68 : 1;
Boolean flag69 : 1;
Boolean flag70 : 1;
Boolean flag71 : 1;
Boolean flag72 : 1;
};
/* Structure used for extra flags in third component overlaying Field12 */
struct Flag_Word
{
Boolean flag73 : 1;
Boolean flag74 : 1;
Boolean flag75 : 1;
Boolean flag76 : 1;
Boolean flag77 : 1;
Boolean flag78 : 1;
Boolean flag79 : 1;
Boolean flag80 : 1;
Boolean flag81 : 1;
Boolean flag82 : 1;
Boolean flag83 : 1;
Boolean flag84 : 1;
Boolean flag85 : 1;
Boolean flag86 : 1;
Boolean flag87 : 1;
Boolean flag88 : 1;
Boolean flag89 : 1;
Boolean flag90 : 1;
Boolean flag91 : 1;
Boolean flag92 : 1;
Boolean flag93 : 1;
Boolean flag94 : 1;
Boolean flag95 : 1;
Boolean flag96 : 1;
Byte convention : 8;
};
/* Structure used for extra flags in fourth component overlaying Field12 */
struct Flag_Word2
{
Boolean flag97 : 1;
Boolean flag98 : 1;
Boolean flag99 : 1;
Boolean flag100 : 1;
Boolean flag101 : 1;
Boolean flag102 : 1;
Boolean flag103 : 1;
Boolean flag104 : 1;
Boolean flag105 : 1;
Boolean flag106 : 1;
Boolean flag107 : 1;
Boolean flag108 : 1;
Boolean flag109 : 1;
Boolean flag110 : 1;
Boolean flag111 : 1;
Boolean flag112 : 1;
Boolean flag113 : 1;
Boolean flag114 : 1;
Boolean flag115 : 1;
Boolean flag116 : 1;
Boolean flag117 : 1;
Boolean flag118 : 1;
Boolean flag119 : 1;
Boolean flag120 : 1;
Boolean flag121 : 1;
Boolean flag122 : 1;
Boolean flag123 : 1;
Boolean flag124 : 1;
Boolean flag125 : 1;
Boolean flag126 : 1;
Boolean flag127 : 1;
Boolean flag128 : 1;
};
/* Structure used for extra flags in fourth component overlaying Field11 */
struct Flag_Word3
{
Boolean flag152 : 1;
Boolean flag153 : 1;
Boolean flag154 : 1;
Boolean flag155 : 1;
Boolean flag156 : 1;
Boolean flag157 : 1;
Boolean flag158 : 1;
Boolean flag159 : 1;
Boolean flag160 : 1;
Boolean flag161 : 1;
Boolean flag162 : 1;
Boolean flag163 : 1;
Boolean flag164 : 1;
Boolean flag165 : 1;
Boolean flag166 : 1;
Boolean flag167 : 1;
Boolean flag168 : 1;
Boolean flag169 : 1;
Boolean flag170 : 1;
Boolean flag171 : 1;
Boolean flag172 : 1;
Boolean flag173 : 1;
Boolean flag174 : 1;
Boolean flag175 : 1;
Boolean flag176 : 1;
Boolean flag177 : 1;
Boolean flag178 : 1;
Boolean flag179 : 1;
Boolean flag180 : 1;
Boolean flag181 : 1;
Boolean flag182 : 1;
Boolean flag183 : 1;
};
/* Structure used for extra flags in fifth component overlaying Field12 */
struct Flag_Word4
{
Boolean flag184 : 1;
Boolean flag185 : 1;
Boolean flag186 : 1;
Boolean flag187 : 1;
Boolean flag188 : 1;
Boolean flag189 : 1;
Boolean flag190 : 1;
Boolean flag191 : 1;
Boolean flag192 : 1;
Boolean flag193 : 1;
Boolean flag194 : 1;
Boolean flag195 : 1;
Boolean flag196 : 1;
Boolean flag197 : 1;
Boolean flag198 : 1;
Boolean flag199 : 1;
Boolean flag200 : 1;
Boolean flag201 : 1;
Boolean flag202 : 1;
Boolean flag203 : 1;
Boolean flag204 : 1;
Boolean flag205 : 1;
Boolean flag206 : 1;
Boolean flag207 : 1;
Boolean flag208 : 1;
Boolean flag209 : 1;
Boolean flag210 : 1;
Boolean flag211 : 1;
Boolean flag212 : 1;
Boolean flag213 : 1;
Boolean flag214 : 1;
Boolean flag215 : 1;
};
/* Structure used for extra flags in sixth component overlaying Field12 */
struct Flag_Word5
{
Boolean flag255 : 1;
Boolean flag256 : 1;
Boolean flag257 : 1;
Boolean flag258 : 1;
Boolean flag259 : 1;
Boolean flag260 : 1;
Boolean flag261 : 1;
Boolean flag262 : 1;
Boolean flag263 : 1;
Boolean flag264 : 1;
Boolean flag265 : 1;
Boolean flag266 : 1;
Boolean flag267 : 1;
Boolean flag268 : 1;
Boolean flag269 : 1;
Boolean flag270 : 1;
Boolean flag271 : 1;
Boolean flag272 : 1;
Boolean flag273 : 1;
Boolean flag274 : 1;
Boolean flag275 : 1;
Boolean flag276 : 1;
Boolean flag277 : 1;
Boolean flag278 : 1;
Boolean flag279 : 1;
Boolean flag280 : 1;
Boolean flag281 : 1;
Boolean flag282 : 1;
Boolean flag283 : 1;
Boolean flag284 : 1;
Boolean flag285 : 1;
Boolean flag286 : 1;
};
struct Non_Extended
{
Source_Ptr sloc;
Int link;
Int field1;
Int field2;
Int field3;
Int field4;
Int field5;
};
/* The Following structure corresponds to variant with is_extension = True. */
struct Extended
{
Int field6;
Int field7;
Int field8;
Int field9;
Int field10;
union
{
Int field11;
struct Flag_Word3 fw3;
} X;
union
{
Int field12;
struct Flag_Word fw;
struct Flag_Word2 fw2;
struct Flag_Word4 fw4;
struct Flag_Word5 fw5;
} U;
};
/* A tree node itself. */
struct Node
{
union kind
{
struct NFK K;
struct NFNK NK;
} U;
union variant
{
struct Non_Extended NX;
struct Extended EX;
} V;
};
/* The actual tree is an array of nodes. The pointer to this array is passed
as a parameter to the tree transformer procedure and stored in the global
variable Nodes_Ptr after adjusting it by subtracting Node_First_Entry, so
that Node_Id values can be used as subscripts. */
extern struct Node *Nodes_Ptr;
#define Parent atree__parent
extern Node_Id Parent (Node_Id);
#define Original_Node atree__original_node
extern Node_Id Original_Node (Node_Id);
/* The auxiliary flags array which is allocated in parallel to Nodes */
struct Flags
{
Boolean Flag0 : 1;
Boolean Flag1 : 1;
Boolean Flag2 : 1;
Boolean Flag3 : 1;
Boolean Spare0 : 1;
Boolean Spare1 : 1;
Boolean Spare2 : 1;
Boolean Spare3 : 1;
};
extern struct Flags *Flags_Ptr;
/* Overloaded Functions:
These functions are overloaded in the original Ada source, but there is
only one corresponding C function, which works as described below. */
/* Type used for union of Node_Id, List_Id, Elist_Id. */
typedef Int Tree_Id;
@ -400,7 +59,7 @@ No (Tree_Id N)
INLINE Boolean
Present (Tree_Id N)
{
return N != Empty;
return !No (N);
}
extern Node_Id Parent (Tree_Id);
@ -408,488 +67,150 @@ extern Node_Id Parent (Tree_Id);
#define Current_Error_Node atree__current_error_node
extern Node_Id Current_Error_Node;
/* Node Access Functions: */
// The following code corresponds to the Get_n_Bit_Field functions (for
// various n) in package Atree. The low-level getters in sinfo.h call
// these even-lower-level getters.
#define Nkind(N) ((Node_Kind) (Nodes_Ptr[(N) - First_Node_Id].U.K.kind))
#define Ekind(N) ((Entity_Kind) (Nodes_Ptr[N + 1].U.K.kind))
#define Sloc(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.sloc)
#define Paren_Count(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.pflag1 \
+ 2 * Nodes_Ptr[(N) - First_Node_Id].U.K.pflag2)
extern Field_Offset *Node_Offsets_Ptr;
extern slot* Slots_Ptr;
#define Field1(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field1)
#define Field2(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field2)
#define Field3(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field3)
#define Field4(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field4)
#define Field5(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field5)
#define Field6(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field6)
#define Field7(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field7)
#define Field8(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field8)
#define Field9(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field9)
#define Field10(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field10)
#define Field11(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.X.field11)
#define Field12(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.U.field12)
#define Field13(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field6)
#define Field14(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field7)
#define Field15(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field8)
#define Field16(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field9)
#define Field17(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field10)
#define Field18(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.X.field11)
#define Field19(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field6)
#define Field20(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field7)
#define Field21(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field8)
#define Field22(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9)
#define Field23(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field10)
#define Field24(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6)
#define Field25(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field7)
#define Field26(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field8)
#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
#define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10)
#define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11)
#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field6)
#define Field31(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field7)
#define Field32(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field8)
#define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9)
#define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10)
#define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11)
#define Field36(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field6)
#define Field37(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field7)
#define Field38(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field8)
#define Field39(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field9)
#define Field40(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field10)
#define Field41(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.X.field11)
static Union_Id Get_1_Bit_Field(Node_Id N, Field_Offset Offset);
static Union_Id Get_2_Bit_Field(Node_Id N, Field_Offset Offset);
static Union_Id Get_4_Bit_Field(Node_Id N, Field_Offset Offset);
static Union_Id Get_8_Bit_Field(Node_Id N, Field_Offset Offset);
static Union_Id Get_32_Bit_Field(Node_Id N, Field_Offset Offset);
static Union_Id Get_32_Bit_Field_With_Default
(Node_Id N, Field_Offset Offset, Union_Id Default_Value);
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
#define Node3(N) Field3 (N)
#define Node4(N) Field4 (N)
#define Node5(N) Field5 (N)
#define Node6(N) Field6 (N)
#define Node7(N) Field7 (N)
#define Node8(N) Field8 (N)
#define Node9(N) Field9 (N)
#define Node10(N) Field10 (N)
#define Node11(N) Field11 (N)
#define Node12(N) Field12 (N)
#define Node13(N) Field13 (N)
#define Node14(N) Field14 (N)
#define Node15(N) Field15 (N)
#define Node16(N) Field16 (N)
#define Node17(N) Field17 (N)
#define Node18(N) Field18 (N)
#define Node19(N) Field19 (N)
#define Node20(N) Field20 (N)
#define Node21(N) Field21 (N)
#define Node22(N) Field22 (N)
#define Node23(N) Field23 (N)
#define Node24(N) Field24 (N)
#define Node25(N) Field25 (N)
#define Node26(N) Field26 (N)
#define Node27(N) Field27 (N)
#define Node28(N) Field28 (N)
#define Node29(N) Field29 (N)
#define Node30(N) Field30 (N)
#define Node31(N) Field31 (N)
#define Node32(N) Field32 (N)
#define Node33(N) Field33 (N)
#define Node34(N) Field34 (N)
#define Node35(N) Field35 (N)
#define Node36(N) Field36 (N)
#define Node37(N) Field37 (N)
#define Node38(N) Field38 (N)
#define Node39(N) Field39 (N)
#define Node40(N) Field40 (N)
#define Node41(N) Field41 (N)
INLINE Union_Id
Get_1_Bit_Field(Node_Id N, Field_Offset Offset)
{
const Field_Offset L = 32;
slot_1_bit slot = (Slots_Ptr + (Node_Offsets_Ptr[N] + Offset/L))->slot_1;
#define List1(N) Field1 (N)
#define List2(N) Field2 (N)
#define List3(N) Field3 (N)
#define List4(N) Field4 (N)
#define List5(N) Field5 (N)
#define List10(N) Field10 (N)
#define List14(N) Field14 (N)
#define List25(N) Field25 (N)
#define List38(N) Field38 (N)
#define List39(N) Field39 (N)
switch (Offset%L)
{
case 0: return slot.f0;
case 1: return slot.f1;
case 2: return slot.f2;
case 3: return slot.f3;
case 4: return slot.f4;
case 5: return slot.f5;
case 6: return slot.f6;
case 7: return slot.f7;
case 8: return slot.f8;
case 9: return slot.f9;
case 10: return slot.f10;
case 11: return slot.f11;
case 12: return slot.f12;
case 13: return slot.f13;
case 14: return slot.f14;
case 15: return slot.f15;
case 16: return slot.f16;
case 17: return slot.f17;
case 18: return slot.f18;
case 19: return slot.f19;
case 20: return slot.f20;
case 21: return slot.f21;
case 22: return slot.f22;
case 23: return slot.f23;
case 24: return slot.f24;
case 25: return slot.f25;
case 26: return slot.f26;
case 27: return slot.f27;
case 28: return slot.f28;
case 29: return slot.f29;
case 30: return slot.f30;
case 31: return slot.f31;
default: gcc_assert(false);
}
}
#define Elist1(N) Field1 (N)
#define Elist2(N) Field2 (N)
#define Elist3(N) Field3 (N)
#define Elist4(N) Field4 (N)
#define Elist5(N) Field5 (N)
#define Elist8(N) Field8 (N)
#define Elist9(N) Field9 (N)
#define Elist10(N) Field10 (N)
#define Elist11(N) Field11 (N)
#define Elist13(N) Field13 (N)
#define Elist15(N) Field15 (N)
#define Elist16(N) Field16 (N)
#define Elist18(N) Field18 (N)
#define Elist21(N) Field21 (N)
#define Elist23(N) Field23 (N)
#define Elist24(N) Field24 (N)
#define Elist25(N) Field25 (N)
#define Elist26(N) Field26 (N)
#define Elist29(N) Field29 (N)
#define Elist30(N) Field30 (N)
#define Elist36(N) Field36 (N)
INLINE Union_Id
Get_2_Bit_Field(Node_Id N, Field_Offset Offset)
{
const Field_Offset L = 16;
slot_2_bit slot = (Slots_Ptr + (Node_Offsets_Ptr[N] + Offset/L))->slot_2;
#define Name1(N) Field1 (N)
#define Name2(N) Field2 (N)
switch (Offset%L)
{
case 0: return slot.f0;
case 1: return slot.f1;
case 2: return slot.f2;
case 3: return slot.f3;
case 4: return slot.f4;
case 5: return slot.f5;
case 6: return slot.f6;
case 7: return slot.f7;
case 8: return slot.f8;
case 9: return slot.f9;
case 10: return slot.f10;
case 11: return slot.f11;
case 12: return slot.f12;
case 13: return slot.f13;
case 14: return slot.f14;
case 15: return slot.f15;
default: gcc_assert(false);
}
}
#define Char_Code2(N) (Field2 (N) - Char_Code_Bias)
INLINE Union_Id
Get_4_Bit_Field(Node_Id N, Field_Offset Offset)
{
const Field_Offset L = 8;
slot_4_bit slot = (Slots_Ptr + (Node_Offsets_Ptr[N] + Offset/L))->slot_4;
#define Str3(N) Field3 (N)
switch (Offset%L)
{
case 0: return slot.f0;
case 1: return slot.f1;
case 2: return slot.f2;
case 3: return slot.f3;
case 4: return slot.f4;
case 5: return slot.f5;
case 6: return slot.f6;
case 7: return slot.f7;
default: gcc_assert(false);
}
}
#define Uint2(N) ((Field2 (N) == 0) ? Uint_0 : Field2 (N))
#define Uint3(N) ((Field3 (N) == 0) ? Uint_0 : Field3 (N))
#define Uint4(N) ((Field4 (N) == 0) ? Uint_0 : Field4 (N))
#define Uint5(N) ((Field5 (N) == 0) ? Uint_0 : Field5 (N))
#define Uint8(N) ((Field8 (N) == 0) ? Uint_0 : Field8 (N))
#define Uint9(N) ((Field9 (N) == 0) ? Uint_0 : Field9 (N))
#define Uint10(N) ((Field10 (N) == 0) ? Uint_0 : Field10 (N))
#define Uint11(N) ((Field11 (N) == 0) ? Uint_0 : Field11 (N))
#define Uint12(N) ((Field12 (N) == 0) ? Uint_0 : Field12 (N))
#define Uint13(N) ((Field13 (N) == 0) ? Uint_0 : Field13 (N))
#define Uint14(N) ((Field14 (N) == 0) ? Uint_0 : Field14 (N))
#define Uint15(N) ((Field15 (N) == 0) ? Uint_0 : Field15 (N))
#define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N))
#define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N))
#define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N))
#define Uint24(N) ((Field24 (N) == 0) ? Uint_0 : Field24 (N))
INLINE Union_Id
Get_8_Bit_Field(Node_Id N, Field_Offset Offset)
{
const Field_Offset L = 4;
slot_8_bit slot = (Slots_Ptr + (Node_Offsets_Ptr[N] + Offset/L))->slot_8;
#define Ureal3(N) Field3 (N)
#define Ureal18(N) Field18 (N)
#define Ureal21(N) Field21 (N)
switch (Offset%L)
{
case 0: return slot.f0;
case 1: return slot.f1;
case 2: return slot.f2;
case 3: return slot.f3;
default: gcc_assert(false);
}
}
#define Analyzed(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.analyzed)
#define Comes_From_Source(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.c_f_s)
#define Error_Posted(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.error_posted)
#define Has_Aspects(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.has_aspects)
#define Convention(N) \
(Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention)
INLINE Union_Id
Get_32_Bit_Field(Node_Id N, Field_Offset Offset)
{
const Field_Offset L = 1;
slot_32_bit slot = (Slots_Ptr + (Node_Offsets_Ptr[N] + Offset/L))->slot_32;
return slot;
}
#define Flag0(N) (Flags_Ptr[(N) - First_Node_Id].Flag0)
#define Flag1(N) (Flags_Ptr[(N) - First_Node_Id].Flag1)
#define Flag2(N) (Flags_Ptr[(N) - First_Node_Id].Flag2)
#define Flag3(N) (Flags_Ptr[(N) - First_Node_Id].Flag3)
INLINE Union_Id
Get_32_Bit_Field_With_Default(Node_Id N, Field_Offset Offset, Union_Id Default_Value)
{
const Field_Offset L = 1;
slot_32_bit slot = (Slots_Ptr + (Node_Offsets_Ptr[N] + Offset/L))->slot_32;
#define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4)
#define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5)
#define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6)
#define Flag7(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag7)
#define Flag8(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag8)
#define Flag9(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag9)
#define Flag10(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag10)
#define Flag11(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag11)
#define Flag12(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag12)
#define Flag13(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag13)
#define Flag14(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag14)
#define Flag15(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag15)
#define Flag16(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag16)
#define Flag17(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag17)
#define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18)
if (slot == Empty)
{
return Default_Value;
}
#define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list)
#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.has_aspects)
#define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins)
#define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed)
#define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s)
#define Flag24(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.error_posted)
#define Flag25(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag4)
#define Flag26(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag5)
#define Flag27(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag6)
#define Flag28(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag7)
#define Flag29(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag8)
#define Flag30(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag9)
#define Flag31(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag10)
#define Flag32(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag11)
#define Flag33(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag12)
#define Flag34(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag13)
#define Flag35(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag14)
#define Flag36(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag15)
#define Flag37(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag16)
#define Flag38(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag17)
#define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18)
#define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list)
#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.has_aspects)
#define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins)
#define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed)
#define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s)
#define Flag45(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.error_posted)
#define Flag46(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag4)
#define Flag47(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag5)
#define Flag48(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag6)
#define Flag49(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag7)
#define Flag50(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag8)
#define Flag51(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag9)
#define Flag52(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag10)
#define Flag53(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag11)
#define Flag54(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag12)
#define Flag55(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag13)
#define Flag56(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag14)
#define Flag57(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag15)
#define Flag58(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag16)
#define Flag59(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag17)
#define Flag60(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag18)
#define Flag61(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag1)
#define Flag62(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag2)
#define Flag63(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag1)
#define Flag64(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag2)
#define Flag65(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag65)
#define Flag66(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag66)
#define Flag67(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag67)
#define Flag68(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag68)
#define Flag69(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag69)
#define Flag70(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag70)
#define Flag71(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag71)
#define Flag72(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag72)
#define Flag73(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag73)
#define Flag74(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag74)
#define Flag75(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag75)
#define Flag76(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag76)
#define Flag77(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag77)
#define Flag78(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag78)
#define Flag79(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag79)
#define Flag80(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag80)
#define Flag81(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag81)
#define Flag82(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag82)
#define Flag83(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag83)
#define Flag84(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag84)
#define Flag85(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag85)
#define Flag86(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag86)
#define Flag87(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag87)
#define Flag88(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag88)
#define Flag89(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag89)
#define Flag90(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag90)
#define Flag91(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag91)
#define Flag92(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag92)
#define Flag93(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag93)
#define Flag94(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag94)
#define Flag95(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag95)
#define Flag96(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag96)
#define Flag97(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag97)
#define Flag98(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag98)
#define Flag99(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag99)
#define Flag100(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag100)
#define Flag101(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag101)
#define Flag102(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag102)
#define Flag103(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag103)
#define Flag104(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag104)
#define Flag105(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag105)
#define Flag106(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag106)
#define Flag107(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag107)
#define Flag108(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag108)
#define Flag109(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag109)
#define Flag110(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag110)
#define Flag111(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag111)
#define Flag112(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag112)
#define Flag113(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag113)
#define Flag114(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag114)
#define Flag115(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag115)
#define Flag116(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag116)
#define Flag117(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag117)
#define Flag118(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag118)
#define Flag119(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag119)
#define Flag120(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag120)
#define Flag121(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag121)
#define Flag122(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag122)
#define Flag123(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag123)
#define Flag124(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag124)
#define Flag125(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag125)
#define Flag126(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag126)
#define Flag127(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag127)
#define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128)
#define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list)
#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.has_aspects)
#define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins)
#define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed)
#define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s)
#define Flag134(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.error_posted)
#define Flag135(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag4)
#define Flag136(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag5)
#define Flag137(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag6)
#define Flag138(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag7)
#define Flag139(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag8)
#define Flag140(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag9)
#define Flag141(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag10)
#define Flag142(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag11)
#define Flag143(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag12)
#define Flag144(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag13)
#define Flag145(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag14)
#define Flag146(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag15)
#define Flag147(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag16)
#define Flag148(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag17)
#define Flag149(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag18)
#define Flag150(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag1)
#define Flag151(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag2)
#define Flag152(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag152)
#define Flag153(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag153)
#define Flag154(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag154)
#define Flag155(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag155)
#define Flag156(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag156)
#define Flag157(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag157)
#define Flag158(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag158)
#define Flag159(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag159)
#define Flag160(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag160)
#define Flag161(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag161)
#define Flag162(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag162)
#define Flag163(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag163)
#define Flag164(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag164)
#define Flag165(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag165)
#define Flag166(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag166)
#define Flag167(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag167)
#define Flag168(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag168)
#define Flag169(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag169)
#define Flag170(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag170)
#define Flag171(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag171)
#define Flag172(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag172)
#define Flag173(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag173)
#define Flag174(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag174)
#define Flag175(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag175)
#define Flag176(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag176)
#define Flag177(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag177)
#define Flag178(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag178)
#define Flag179(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag179)
#define Flag180(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag180)
#define Flag181(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag181)
#define Flag182(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag182)
#define Flag183(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag183)
#define Flag184(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag184)
#define Flag185(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag185)
#define Flag186(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag186)
#define Flag187(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag187)
#define Flag188(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag188)
#define Flag189(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag189)
#define Flag190(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag190)
#define Flag191(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag191)
#define Flag192(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag192)
#define Flag193(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag193)
#define Flag194(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag194)
#define Flag195(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag195)
#define Flag196(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag196)
#define Flag197(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag197)
#define Flag198(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag198)
#define Flag199(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag199)
#define Flag200(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag200)
#define Flag201(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag201)
#define Flag202(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag202)
#define Flag203(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag203)
#define Flag204(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag204)
#define Flag205(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag205)
#define Flag206(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag206)
#define Flag207(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag207)
#define Flag208(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag208)
#define Flag209(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag209)
#define Flag210(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag210)
#define Flag211(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag211)
#define Flag212(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag212)
#define Flag213(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag213)
#define Flag214(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag214)
#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215)
#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list)
#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.has_aspects)
#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins)
#define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed)
#define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s)
#define Flag221(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.error_posted)
#define Flag222(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag4)
#define Flag223(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag5)
#define Flag224(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag6)
#define Flag225(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag7)
#define Flag226(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag8)
#define Flag227(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag9)
#define Flag228(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag10)
#define Flag229(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag11)
#define Flag230(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag12)
#define Flag231(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag13)
#define Flag232(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag14)
#define Flag233(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag15)
#define Flag234(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag16)
#define Flag235(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag17)
#define Flag236(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag18)
#define Flag237(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.pflag1)
#define Flag238(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.pflag2)
#define Flag239(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag65)
#define Flag240(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag66)
#define Flag241(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag67)
#define Flag242(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag68)
#define Flag243(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag69)
#define Flag244(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag70)
#define Flag245(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag71)
#define Flag246(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag72)
#define Flag247(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag65)
#define Flag248(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag66)
#define Flag249(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag67)
#define Flag250(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag68)
#define Flag251(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag69)
#define Flag252(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag70)
#define Flag253(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag71)
#define Flag254(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag72)
#define Flag255(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag255)
#define Flag256(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag256)
#define Flag257(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag257)
#define Flag258(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag258)
#define Flag259(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag259)
#define Flag260(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag260)
#define Flag261(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag261)
#define Flag262(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag262)
#define Flag263(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag263)
#define Flag264(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag264)
#define Flag265(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag265)
#define Flag266(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag266)
#define Flag267(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag267)
#define Flag268(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag268)
#define Flag269(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag269)
#define Flag270(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag270)
#define Flag271(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag271)
#define Flag272(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag272)
#define Flag273(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag273)
#define Flag274(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag274)
#define Flag275(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag275)
#define Flag276(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag276)
#define Flag277(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag277)
#define Flag278(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag278)
#define Flag279(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag279)
#define Flag280(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag280)
#define Flag281(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag281)
#define Flag282(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag282)
#define Flag283(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag283)
#define Flag284(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag284)
#define Flag285(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag285)
#define Flag286(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag286)
#define Flag287(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.in_list)
#define Flag288(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.has_aspects)
#define Flag289(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.rewrite_ins)
#define Flag290(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.analyzed)
#define Flag291(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.c_f_s)
#define Flag292(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.error_posted)
#define Flag293(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag4)
#define Flag294(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag5)
#define Flag295(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag6)
#define Flag296(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag7)
#define Flag297(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag8)
#define Flag298(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag9)
#define Flag299(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag10)
#define Flag300(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag11)
#define Flag301(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag12)
#define Flag302(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag13)
#define Flag303(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag14)
#define Flag304(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag15)
#define Flag305(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag16)
#define Flag306(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag17)
#define Flag307(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag18)
#define Flag308(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.pflag1)
#define Flag309(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.pflag2)
return slot;
}
#ifdef __cplusplus
}

8
gcc/ada/back_end.adb
View File

@ -88,8 +88,8 @@ package body Back_End is
(gnat_root : Int;
max_gnat_node : Int;
number_name : Nat;
nodes_ptr : Address;
flags_ptr : Address;
node_offsets_ptr : Address;
slots_ptr : Address;
next_node_ptr : Address;
prev_node_ptr : Address;
@ -156,8 +156,8 @@ package body Back_End is
(gnat_root => Int (Cunit (Main_Unit)),
max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1),
number_name => Name_Entries_Count,
nodes_ptr => Nodes_Address,
flags_ptr => Flags_Address,
node_offsets_ptr => Node_Offsets_Address,
slots_ptr => Slots_Address,
next_node_ptr => Next_Node_Address,
prev_node_ptr => Prev_Node_Address,

226
gcc/ada/ceinfo.adb
View File

@ -1,226 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT SYSTEM UTILITIES --
-- --
-- C E I N F O --
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- 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;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
with GNAT.Spitbol.Table_VString;
procedure CEinfo is
package TV renames GNAT.Spitbol.Table_VString;
use TV;
Infil : File_Type;
Lineno : Natural := 0;
Err : exception;
-- Raised on error
Fieldnm : VString;
Accessfunc : VString;
Line : VString;
Fields : GNAT.Spitbol.Table_VString.Table (500);
-- Maps field names to underlying field access name
UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm;
Field_Def : constant Pattern :=
"-- " & Fnam & " (" & Break (')') * Accessfunc;
Field_Ref : constant Pattern :=
" -- " & Fnam & Break ('(') & Len (1) &
Break (')') * Accessfunc;
Field_Com : constant Pattern := " -- " & Fnam & Span (' ') &
(Break (' ') or Rest) * Accessfunc;
Func_Hedr : constant Pattern := " function " & Fnam;
Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc;
Proc_Hedr : constant Pattern := " procedure " & Fnam;
Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc;
procedure Next_Line;
-- Read next line trimmed from Infil into Line and bump Lineno
procedure Next_Line is
begin
Line := Get_Line (Infil);
Trim (Line);
Lineno := Lineno + 1;
end Next_Line;
-- Start of processing for CEinfo
begin
Anchored_Mode := True;
New_Line;
Open (Infil, In_File, "einfo.ads");
Put_Line ("Acquiring field names from spec");
loop
Next_Line;
-- Old format of einfo.ads
exit when Match (Line, " -- Access Kinds --");
-- New format of einfo.ads
exit when Match (Line, "-- Access Kinds --");
if Match (Line, Field_Def) then
Set (Fields, Fieldnm, Accessfunc);
end if;
end loop;
Put_Line ("Checking consistent references in spec");
loop
Next_Line;
exit when Match (Line, " -- Description of Defined");
end loop;
loop
Next_Line;
exit when Match (Line, " -- Component_Alignment Control");
if Match (Line, Field_Ref) then
if Accessfunc /= "synth"
and then
Accessfunc /= "special"
and then
Accessfunc /= Get (Fields, Fieldnm)
then
if Present (Fields, Fieldnm) then
Put_Line ("*** field name incorrect at line " & Lineno);
Put_Line (" found field " & Accessfunc);
Put_Line (" expecting field " & Get (Fields, Fieldnm));
else
Put_Line
("*** unknown field name " & Fieldnm & " at line " & Lineno);
end if;
raise Err;
end if;
end if;
end loop;
Close (Infil);
Open (Infil, In_File, "einfo.adb");
Lineno := 0;
Put_Line ("Check listing of fields in body");
loop
Next_Line;
exit when Match (Line, " -- Attribute Access Functions --");
if Match (Line, Field_Com)
and then Fieldnm /= "(unused)"
and then Accessfunc /= Get (Fields, Fieldnm)
then
if Present (Fields, Fieldnm) then
Put_Line ("*** field name incorrect at line " & Lineno);
Put_Line (" found field " & Accessfunc);
Put_Line (" expecting field " & Get (Fields, Fieldnm));
else
Put_Line
("*** unknown field name " & Fieldnm & " at line " & Lineno);
end if;
raise Err;
end if;
end loop;
Put_Line ("Check references in access routines in body");
loop
Next_Line;
exit when Match (Line, " -- Classification Functions --");
if Match (Line, Func_Hedr) then
null;
elsif Match (Line, Func_Retn)
and then Accessfunc /= Get (Fields, Fieldnm)
and then Fieldnm /= "Mechanism"
then
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 ("Check references in set routines in body");
loop
Next_Line;
exit when Match (Line, " -- Attribute Set Procedures");
end loop;
loop
Next_Line;
exit when Match (Line, " ------------");
if Match (Line, Proc_Hedr) then
null;
elsif Match (Line, Proc_Setf)
and then Accessfunc /= Get (Fields, Fieldnm)
and then Fieldnm /= "Mechanism"
then
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;

9
gcc/ada/checks.adb
View File

@ -26,7 +26,9 @@
with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Eval_Fat; use Eval_Fat;
with Exp_Ch11; use Exp_Ch11;
@ -53,7 +55,9 @@ with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Sprint; use Sprint;
@ -9295,7 +9299,6 @@ package body Checks is
Append_To (New_Alts,
Make_Case_Expression_Alternative (Sloc (Alt),
Actions => No_List,
Discrete_Choices => Discrete_Choices (Alt),
Expression => New_Exp));

3
gcc/ada/comperr.adb
View File

@ -36,7 +36,8 @@ with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinput; use Sinput;
with Sprint; use Sprint;
with Sdefault; use Sdefault;

8
gcc/ada/contracts.adb
View File

@ -25,7 +25,9 @@
with Aspects; use Aspects;
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Prag; use Exp_Prag;
@ -46,7 +48,9 @@ with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;

639
gcc/ada/csinfo.adb
View File

@ -1,639 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT SYSTEM UTILITIES --
-- --
-- C S I N F O --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- 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;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
with GNAT.Spitbol.Table_Boolean;
with GNAT.Spitbol.Table_VString;
procedure CSinfo is
package TB renames GNAT.Spitbol.Table_Boolean;
package TV renames GNAT.Spitbol.Table_VString;
use TB, TV;
Infil : File_Type;
Lineno : Natural := 0;
Err : exception;
-- Raised on fatal error
Done : exception;
-- Raised after error is found to terminate run
WSP : constant Pattern := Span (' ' & ASCII.HT);
Fields : TV.Table (300);
Fields1 : TV.Table (300);
Refs : TV.Table (300);
Refscopy : TV.Table (300);
Special : TB.Table (50);
Inlines : TV.Table (100);
-- The following define the standard fields used for binary operator,
-- unary operator, and other expression nodes. Numbers in the range 1-5
-- refer to the Fieldn fields. Letters D-R refer to flags:
-- D = Flag4
-- E = Flag5
-- F = Flag6
-- G = Flag7
-- H = Flag8
-- I = Flag9
-- J = Flag10
-- K = Flag11
-- L = Flag12
-- M = Flag13
-- N = Flag14
-- O = Flag15
-- P = Flag16
-- Q = Flag17
-- R = Flag18
Flags : TV.Table (20);
-- Maps flag numbers to letters
N_Fields : constant Pattern := BreakX ("J");
E_Fields : constant Pattern := BreakX ("5EFGHIJOP");
U_Fields : constant Pattern := BreakX ("1345EFGHIJKOPQ");
B_Fields : constant Pattern := BreakX ("12345EFGHIJKOPQ");
Line : VString;
Bad : Boolean;
Field : constant VString := Nul;
Fields_Used : VString := Nul;
Name : constant VString := Nul;
Next : constant VString := Nul;
Node : VString := Nul;
Ref : VString := Nul;
Synonym : constant VString := Nul;
Nxtref : constant VString := Nul;
Which_Field : aliased VString := Nul;
Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node;
Break_Punc : constant Pattern := Break (" .,");
Plus_Binary : constant Pattern := WSP
& "-- plus fields for binary operator";
Plus_Unary : constant Pattern := WSP
& "-- plus fields for unary operator";
Plus_Expr : constant Pattern := WSP
& "-- plus fields for expression";
Break_Syn : constant Pattern := WSP & "-- "
& Break (' ') * Synonym
& " (" & Break (')') * Field;
Break_Field : constant Pattern := BreakX ('-') * Field;
Get_Field : constant Pattern := BreakX (Decimal_Digit_Set)
& Span (Decimal_Digit_Set) * Which_Field;
Break_WFld : constant Pattern := Break (Which_Field'Access);
Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym;
Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field;
Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym;
Get_Inline : constant Pattern := WSP & "pragma Inline ("
& Break (')') * Name;
Set_Name : constant Pattern := "Set_" & Rest * Name;
Func_Rest : constant Pattern := " function " & Rest * Synonym;
Get_Nxtref : constant Pattern := Break (',') * Nxtref & ',';
Test_Syn : constant Pattern := Break ('=') & "= N_"
& (Break (" ,)") or Rest) * Next;
Chop_Comma : constant Pattern := BreakX (',') * Next;
Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field;
Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym;
Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field
& " (N, Val)";
Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent";
type VStringA is array (Natural range <>) of VString;
procedure Next_Line;
-- Read next line trimmed from Infil into Line and bump Lineno
procedure Sort (A : in out VStringA);
-- Sort a (small) array of VString's
procedure Next_Line is
begin
Line := Get_Line (Infil);
Trim (Line);
Lineno := Lineno + 1;
end Next_Line;
procedure Sort (A : in out VStringA) is
Temp : VString;
begin
<<Sort>>
for J in 1 .. A'Length - 1 loop
if A (J) > A (J + 1) then
Temp := A (J);
A (J) := A (J + 1);
A (J + 1) := Temp;
goto Sort;
end if;
end loop;
end Sort;
-- Start of processing for CSinfo
begin
Anchored_Mode := True;
New_Line;
Open (Infil, In_File, "sinfo.ads");
Put_Line ("Check for field name consistency");
-- Setup table for mapping flag numbers to letters
Set (Flags, "4", V ("D"));
Set (Flags, "5", V ("E"));
Set (Flags, "6", V ("F"));
Set (Flags, "7", V ("G"));
Set (Flags, "8", V ("H"));
Set (Flags, "9", V ("I"));
Set (Flags, "10", V ("J"));
Set (Flags, "11", V ("K"));
Set (Flags, "12", V ("L"));
Set (Flags, "13", V ("M"));
Set (Flags, "14", V ("N"));
Set (Flags, "15", V ("O"));
Set (Flags, "16", V ("P"));
Set (Flags, "17", V ("Q"));
Set (Flags, "18", V ("R"));
-- Special fields table. The following names are not recorded or checked
-- by Csinfo, since they are specially handled. This means that any field
-- definition or subprogram with a matching name is ignored.
Set (Special, "Analyzed", True);
Set (Special, "Assignment_OK", True);
Set (Special, "Associated_Node", True);
Set (Special, "Cannot_Be_Constant", True);
Set (Special, "Chars", True);
Set (Special, "Comes_From_Source", True);
Set (Special, "Do_Overflow_Check", True);
Set (Special, "Do_Range_Check", True);
Set (Special, "Entity", True);
Set (Special, "Entity_Or_Associated_Node", True);
Set (Special, "Error_Posted", True);
Set (Special, "Etype", True);
Set (Special, "Evaluate_Once", True);
Set (Special, "First_Itype", True);
Set (Special, "Has_Aspect_Specifications", True);
Set (Special, "Has_Dynamic_Itype", True);
Set (Special, "Has_Dynamic_Length_Check", True);
Set (Special, "Has_Private_View", True);
Set (Special, "Is_Controlling_Actual", True);
Set (Special, "Is_Overloaded", True);
Set (Special, "Is_Static_Expression", True);
Set (Special, "Left_Opnd", True);
Set (Special, "Must_Not_Freeze", True);
Set (Special, "Nkind_In", True);
Set (Special, "Parens", True);
Set (Special, "Pragma_Name", True);
Set (Special, "Raises_Constraint_Error", True);
Set (Special, "Right_Opnd", True);
-- Loop to acquire information from node definitions in sinfo.ads,
-- checking for consistency in Op/Flag assignments to each synonym
loop
Bad := False;
Next_Line;
exit when Match (Line, " -- Node Access Functions");
if Match (Line, Node_Search)
and then not Match (Node, Break_Punc)
then
Fields_Used := Nul;
elsif Node = "" then
null;
elsif Line = "" then
Node := Nul;
elsif Match (Line, Plus_Binary) then
Bad := Match (Fields_Used, B_Fields);
elsif Match (Line, Plus_Unary) then
Bad := Match (Fields_Used, U_Fields);
elsif Match (Line, Plus_Expr) then
Bad := Match (Fields_Used, E_Fields);
elsif not Match (Line, Break_Syn) then
null;
elsif Match (Synonym, "plus") then
null;
else
Match (Field, Break_Field);
if not Present (Special, Synonym) then
if Present (Fields, Synonym) then
if Field /= Get (Fields, Synonym) then
Put_Line
("Inconsistent field reference at line" &
Lineno'Img & " for " & Synonym);
raise Done;
end if;
else
Set (Fields, Synonym, Field);
end if;
Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
Match (Field, Get_Field);
if Match (Field, "Flag") then
Which_Field := Get (Flags, Which_Field);
end if;
if Match (Fields_Used, Break_WFld) then
Put_Line
("Overlapping field at line " & Lineno'Img &
" for " & Synonym);
raise Done;
end if;
Append (Fields_Used, Which_Field);
Bad := Bad or Match (Fields_Used, N_Fields);
end if;
end if;
if Bad then
Put_Line ("fields conflict with standard fields for node " & Node);
raise Done;
end if;
end loop;
Put_Line (" OK");
New_Line;
Put_Line ("Check for function consistency");
-- Loop through field function definitions to make sure they are OK
Fields1 := Fields;
loop
Next_Line;
exit when Match (Line, " -- Node Update");
if Match (Line, Get_Funcsyn)
and then not Present (Special, Synonym)
then
if not Present (Fields1, Synonym) then
Put_Line
("function on line " & Lineno &
" is for unused synonym");
raise Done;
end if;
Next_Line;
if not Match (Line, Extr_Field) then
raise Err;
end if;
if Field /= Get (Fields1, Synonym) then
Put_Line ("Wrong field in function " & Synonym);
raise Done;
else
Delete (Fields1, Synonym);
end if;
end if;
end loop;
Put_Line (" OK");
New_Line;
Put_Line ("Check for missing functions");
declare
List : constant TV.Table_Array := Convert_To_Array (Fields1);
begin
if List'Length > 0 then
Put_Line ("No function for field synonym " & List (1).Name);
raise Done;
end if;
end;
-- Check field set procedures
Put_Line (" OK");
New_Line;
Put_Line ("Check for set procedure consistency");
Fields1 := Fields;
loop
Next_Line;
exit when Match (Line, " -- Inline Pragmas");
exit when Match (Line, " -- Iterator Procedures");
if Match (Line, Get_Procsyn)
and then not Present (Special, Synonym)
then
if not Present (Fields1, Synonym) then
Put_Line
("procedure on line " & Lineno & " is for unused synonym");
raise Done;
end if;
Next_Line;
if not Match (Line, Extr_Field) then
raise Err;
end if;
if Field /= Get (Fields1, Synonym) then
Put_Line ("Wrong field in procedure Set_" & Synonym);
raise Done;
else
Delete (Fields1, Synonym);
end if;
end if;
end loop;
Put_Line (" OK");
New_Line;
Put_Line ("Check for missing set procedures");
declare
List : constant TV.Table_Array := Convert_To_Array (Fields1);
begin
if List'Length > 0 then
Put_Line ("No procedure for field synonym Set_" & List (1).Name);
raise Done;
end if;
end;
Put_Line (" OK");
New_Line;
Put_Line ("Check pragma Inlines are all for existing subprograms");
Clear (Fields1);
while not End_Of_File (Infil) loop
Next_Line;
if Match (Line, Get_Inline)
and then not Present (Special, Name)
then
exit when Match (Name, Set_Name);
if not Present (Fields, Name) then
Put_Line
("Pragma Inline on line " & Lineno &
" does not correspond to synonym");
raise Done;
else
Set (Inlines, Name, Get (Inlines, Name) & 'r');
end if;
end if;
end loop;
Put_Line (" OK");
New_Line;
Put_Line ("Check no pragma Inlines were omitted");
declare
List : constant TV.Table_Array := Convert_To_Array (Fields);
Nxt : VString := Nul;
begin
for M in List'Range loop
Nxt := List (M).Name;
if Get (Inlines, Nxt) /= "r" then
Put_Line ("Incorrect pragma Inlines for " & Nxt);
raise Done;
end if;
end loop;
end;
Put_Line (" OK");
New_Line;
Clear (Inlines);
Close (Infil);
Open (Infil, In_File, "sinfo.adb");
Lineno := 0;
Put_Line ("Check references in functions in body");
Refscopy := Refs;
loop
Next_Line;
exit when Match (Line, " -- Field Access Functions --");
end loop;
loop
Next_Line;
exit when Match (Line, " -- Field Set Procedures --");
if Match (Line, Func_Rest)
and then not Present (Special, Synonym)
then
Ref := Get (Refs, Synonym);
Delete (Refs, Synonym);
if Ref = "" then
Put_Line
("Function on line " & Lineno & " is for unknown synonym");
raise Err;
end if;
-- Alpha sort of references for this entry
declare
Refa : VStringA (1 .. 100);
N : Natural := 0;
begin
loop
exit when not Match (Ref, Get_Nxtref, Nul);
N := N + 1;
Refa (N) := Nxtref;
end loop;
Sort (Refa (1 .. N));
Next_Line;
Next_Line;
Next_Line;
-- Checking references for one entry
for M in 1 .. N loop
Next_Line;
if not Match (Line, Test_Syn) then
Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
raise Done;
end if;
Match (Next, Chop_Comma);
if Next /= Refa (M) then
Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
raise Done;
end if;
end loop;
Next_Line;
Match (Line, Return_Fld);
if Field /= Get (Fields, Synonym) then
Put_Line
("Wrong field for function " & Synonym & " at line " &
Lineno & " should be " & Get (Fields, Synonym));
raise Done;
end if;
end;
end if;
end loop;
Put_Line (" OK");
New_Line;
Put_Line ("Check for missing functions in body");
declare
List : constant TV.Table_Array := Convert_To_Array (Refs);
begin
if List'Length /= 0 then
Put_Line ("Missing function " & List (1).Name & " in body");
raise Done;
end if;
end;
Put_Line (" OK");
New_Line;
Put_Line ("Check Set procedures in body");
Refs := Refscopy;
loop
Next_Line;
exit when Match (Line, "end");
exit when Match (Line, " -- Iterator Procedures");
if Match (Line, Set_Syn)
and then not Present (Special, Synonym)
then
Ref := Get (Refs, Synonym);
Delete (Refs, Synonym);
if Ref = "" then
Put_Line
("Function on line " & Lineno & " is for unknown synonym");
raise Err;
end if;
-- Alpha sort of references for this entry
declare
Refa : VStringA (1 .. 100);
N : Natural;
begin
N := 0;
loop
exit when not Match (Ref, Get_Nxtref, Nul);
N := N + 1;
Refa (N) := Nxtref;
end loop;
Sort (Refa (1 .. N));
Next_Line;
Next_Line;
Next_Line;
-- Checking references for one entry
for M in 1 .. N loop
Next_Line;
if not Match (Line, Test_Syn)
or else Next /= Refa (M)
then
Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
raise Err;
end if;
end loop;
loop
Next_Line;
exit when Match (Line, Set_Fld);
end loop;
Match (Field, Break_With);
if Field /= Get (Fields, Synonym) then
Put_Line
("Wrong field for procedure Set_" & Synonym &
" at line " & Lineno & " should be " &
Get (Fields, Synonym));
raise Done;
end if;
Delete (Fields1, Synonym);
end;
end if;
end loop;
Put_Line (" OK");
New_Line;
Put_Line ("Check for missing set procedures in body");
declare
List : constant TV.Table_Array := Convert_To_Array (Fields1);
begin
if List'Length /= 0 then
Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
raise Done;
end if;
end;
Put_Line (" OK");
New_Line;
Put_Line ("All tests completed successfully, no errors detected");
end CSinfo;

10
gcc/ada/cstand.adb
View File

@ -26,7 +26,9 @@
with Atree; use Atree;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Layout; use Layout;
with Namet; use Namet;
@ -40,7 +42,9 @@ with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Sem_Mech; use Sem_Mech;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Uintp; use Uintp;
@ -1105,7 +1109,7 @@ package body CStand is
-- Create semantic phase entities
Standard_Void_Type := New_Standard_Entity ("_void_type");
Set_Ekind (Standard_Void_Type, E_Void);
pragma Assert (Ekind (Standard_Void_Type) = E_Void); -- it's the default
Set_Etype (Standard_Void_Type, Standard_Void_Type);
Set_Scope (Standard_Void_Type, Standard_Standard);

14
gcc/ada/debug.adb
View File

@ -112,7 +112,7 @@ package body Debug is
-- d.y Disable implicit pragma Elaborate_All on task bodies
-- d.z Restore previous support for frontend handling of Inline_Always
-- d.A Print Atree statistics
-- d.A
-- d.B Generate a bug box on abort_statement
-- d.C Generate concatenation call, do not generate inline code
-- d.D Disable errors on use of overriding keyword in Ada 95 mode
@ -125,7 +125,7 @@ package body Debug is
-- d.K Do not reject components in extensions overlapping with parent
-- d.L Depend on back end for limited types in if and case expressions
-- d.M Relaxed RM semantics
-- d.N Add node to all entities
-- d.N
-- d.O Dump internal SCO tables
-- d.P Previous (non-optimized) handling of length comparisons
-- d.Q Previous (incomplete) style check for binary operators
@ -160,7 +160,7 @@ package body Debug is
-- d_s Stop elaboration checks on synchronous suspension
-- d_t
-- d_u
-- d_v
-- d_v Enable additional checks and debug printouts in Atree
-- d_w
-- d_x Disable inline expansion of Image attribute for enumeration types
-- d_y
@ -830,8 +830,6 @@ package body Debug is
-- handling of Inline_Always by the front end on such targets. For the
-- targets that do not use the GCC back end, this switch is ignored.
-- d.A Print Atree statistics
-- d.B Generate a bug box when we see an abort_statement, even though
-- there is no bug. Useful for testing Comperr.Compiler_Abort: write
-- some code containing an abort_statement, and compile it with
@ -900,10 +898,6 @@ package body Debug is
-- d.M Relaxed RM semantics. This flag sets Opt.Relaxed_RM_Semantics
-- See Opt.Relaxed_RM_Semantics for more details.
-- d.N Enlarge entities by one node (but don't attempt to use this extra
-- node for storage of any flags or fields). This can be used to do
-- experiments on the impact of increasing entity sizes.
-- d.O Dump internal SCO tables. Before outputting the SCO information to
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
-- are dumped for debugging purposes.
@ -990,6 +984,8 @@ package body Debug is
-- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
-- or Ada.Synchronous_Barriers.Wait_For_Release.
-- d_v Enable additional checks and debug printouts in Atree
-- d_x The compiler does not expand in line the Image attribute for user-
-- defined enumeration types and the standard boolean type.

3
gcc/ada/debug_a.adb
View File

@ -25,7 +25,8 @@
with Atree; use Atree;
with Debug; use Debug;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinput; use Sinput;
with Output; use Output;

3339
gcc/ada/einfo-utils.adb Normal file
View File

File diff suppressed because it is too large Load Diff

682
gcc/ada/einfo-utils.ads Normal file
View File

@ -0,0 +1,682 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E I N F O . U T I L S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Einfo.Entities; use Einfo.Entities;
package Einfo.Utils is
-----------------------------------
-- Renamings of Renamed_Or_Alias --
-----------------------------------
-- See the comment in einfo.ads, "Renaming and Aliasing", which is somewhat
-- incorrect. In fact, the compiler uses Alias, Renamed_Entity, and
-- Renamed_Object more-or-less interchangeably, so we rename them here.
-- ????Should add preconditions.
function Alias
(N : Entity_Id) return Node_Id renames Renamed_Or_Alias;
procedure Set_Alias
(N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias;
function Renamed_Entity
(N : Entity_Id) return Node_Id renames Renamed_Or_Alias;
procedure Set_Renamed_Entity
(N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias;
function Renamed_Object
(N : Entity_Id) return Node_Id renames Renamed_Or_Alias;
procedure Set_Renamed_Object
(N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias;
--------------------------
-- Subtype Declarations --
--------------------------
-- ????
-- The above entities are arranged so that they can be conveniently grouped
-- into subtype ranges. Note that for each of the xxx_Kind ranges defined
-- below, there is a corresponding Is_xxx (or for types, Is_xxx_Type)
-- predicate which is to be used in preference to direct range tests using
-- the subtype name. However, the subtype names are available for direct
-- use, e.g. as choices in case statements.
-------------------
-- Type Synonyms --
-------------------
-- The following type synonyms are used to tidy up the function and
-- procedure declarations that follow, and also to make it possible to meet
-- the requirement for the XEINFO utility that all function specs must fit
-- on a single source line.????
subtype B is Boolean;
subtype C is Component_Alignment_Kind;
subtype E is Entity_Id;
subtype F is Float_Rep_Kind;
subtype M is Mechanism_Type;
subtype N is Node_Id;
subtype U is Uint;
subtype R is Ureal;
subtype L is Elist_Id;
subtype S is List_Id;
-------------------------------
-- Classification Attributes --
-------------------------------
-- These functions provide a convenient functional notation for testing
-- whether an Ekind value belongs to a specified kind, for example the
-- function Is_Elementary_Type tests if its argument is in Elementary_Kind.
-- In some cases, the test is of an entity attribute (e.g. in the case of
-- Is_Generic_Type where the Ekind does not provide the needed
-- information).
-- ????Could automatically generate some of these?
function Is_Access_Object_Type (Id : E) return B;
function Is_Access_Type (Id : E) return B;
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Access_Subprogram_Type (Id : E) return B;
function Is_Aggregate_Type (Id : E) return B;
function Is_Anonymous_Access_Type (Id : E) return B;
function Is_Array_Type (Id : E) return B;
function Is_Assignable (Id : E) return B;
function Is_Class_Wide_Type (Id : E) return B;
function Is_Composite_Type (Id : E) return B;
function Is_Concurrent_Body (Id : E) return B;
function Is_Concurrent_Type (Id : E) return B;
function Is_Decimal_Fixed_Point_Type (Id : E) return B;
function Is_Digits_Type (Id : E) return B;
function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B;
function Is_Discrete_Type (Id : E) return B;
function Is_Elementary_Type (Id : E) return B;
function Is_Entry (Id : E) return B;
function Is_Enumeration_Type (Id : E) return B;
function Is_Fixed_Point_Type (Id : E) return B;
function Is_Floating_Point_Type (Id : E) return B;
function Is_Formal (Id : E) return B;
function Is_Formal_Object (Id : E) return B;
function Is_Generic_Subprogram (Id : E) return B;
function Is_Generic_Unit (Id : E) return B;
function Is_Ghost_Entity (Id : E) return B;
function Is_Incomplete_Or_Private_Type (Id : E) return B;
function Is_Incomplete_Type (Id : E) return B;
function Is_Integer_Type (Id : E) return B;
function Is_Modular_Integer_Type (Id : E) return B;
function Is_Named_Access_Type (Id : E) return B;
function Is_Named_Number (Id : E) return B;
function Is_Numeric_Type (Id : E) return B;
function Is_Object (Id : E) return B;
function Is_Ordinary_Fixed_Point_Type (Id : E) return B;
function Is_Overloadable (Id : E) return B;
function Is_Private_Type (Id : E) return B;
function Is_Protected_Type (Id : E) return B;
function Is_Real_Type (Id : E) return B;
function Is_Record_Type (Id : E) return B;
function Is_Scalar_Type (Id : E) return B;
function Is_Signed_Integer_Type (Id : E) return B;
function Is_Subprogram (Id : E) return B;
function Is_Subprogram_Or_Entry (Id : E) return B;
function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B;
function Is_Task_Type (Id : E) return B;
function Is_Type (Id : E) return B;
-------------------------------------
-- Synthesized Attribute Functions --
-------------------------------------
-- The functions in this section synthesize attributes from the tree,
-- so they do not correspond to defined fields in the entity itself.
function Address_Clause (Id : E) return N;
function Aft_Value (Id : E) return U;
function Alignment_Clause (Id : E) return N;
function Base_Type (Id : E) return E;
function Declaration_Node (Id : E) return N;
function Designated_Type (Id : E) return E;
function Entry_Index_Type (Id : E) return E;
function First_Component (Id : E) return E;
function First_Component_Or_Discriminant (Id : E) return E;
function First_Formal (Id : E) return E;
function First_Formal_With_Extras (Id : E) return E;
function Has_Attach_Handler (Id : E) return B;
function Has_DIC (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
function Has_Limited_View (Id : E) return B;
function Has_Non_Limited_View (Id : E) return B;
function Has_Non_Null_Abstract_State (Id : E) return B;
function Has_Non_Null_Visible_Refinement (Id : E) return B;
function Has_Null_Abstract_State (Id : E) return B;
function Has_Null_Visible_Refinement (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_Controlled (Id : E) return B;
function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
function Is_Elaboration_Target (Id : E) return B;
function Is_External_State (Id : E) return B;
function Is_Finalizer (Id : E) return B;
function Is_Full_Access (Id : E) return B;
function Is_Null_State (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Packed_Array (Id : E) return B;
function Is_Prival (Id : E) return B;
function Is_Protected_Component (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
function Is_Relaxed_Initialization_State (Id : E) return B;
function Is_Standard_Character_Type (Id : E) return B;
function Is_Standard_String_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
function Is_Synchronized_Interface (Id : E) return B;
function Is_Synchronized_State (Id : E) return B;
function Is_Task_Interface (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
function Last_Formal (Id : E) return E;
function Machine_Emax_Value (Id : E) return U;
function Machine_Emin_Value (Id : E) return U;
function Machine_Mantissa_Value (Id : E) return U;
function Machine_Radix_Value (Id : E) return U;
function Model_Emin_Value (Id : E) return U;
function Model_Epsilon_Value (Id : E) return R;
function Model_Mantissa_Value (Id : E) return U;
function Model_Small_Value (Id : E) return R;
function Next_Component (Id : E) return E;
function Next_Component_Or_Discriminant (Id : E) return E;
function Next_Discriminant (Id : E) return E;
function Next_Formal (Id : E) return E;
function Next_Formal_With_Extras (Id : E) return E;
function Next_Index (Id : N) return N;
function Next_Literal (Id : E) return E;
function Next_Stored_Discriminant (Id : E) return E;
function Number_Dimensions (Id : E) return Pos;
function Number_Entries (Id : E) return Nat;
function Number_Formals (Id : E) return Pos;
function Object_Size_Clause (Id : E) return N;
function Parameter_Mode (Id : E) return Formal_Kind;
function Partial_Refinement_Constituents (Id : E) return L;
function Primitive_Operations (Id : E) return L;
function Root_Type (Id : E) return E;
function Safe_Emax_Value (Id : E) return U;
function Safe_First_Value (Id : E) return R;
function Safe_Last_Value (Id : E) return R;
function Scope_Depth (Id : E) return U;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
function Type_High_Bound (Id : E) return N;
function Type_Low_Bound (Id : E) return N;
function Underlying_Type (Id : E) return E;
----------------------------------------------
-- Type Representation Attribute Predicates --
----------------------------------------------
-- These predicates test the setting of the indicated attribute. If the
-- value has been set, then Known is True, and Unknown is False. If no
-- value is set, then Known is False and Unknown is True. The Known_Static
-- predicate is true only if the value is set (Known) and is set to a
-- compile time known value. Note that in the case of Alignment and
-- Normalized_First_Bit, dynamic values are not possible, so we do not
-- need a separate Known_Static calls in these cases. The not set (unknown)
-- values are as follows:
-- Alignment Uint_0 or No_Uint
-- Component_Size Uint_0 or No_Uint
-- Component_Bit_Offset No_Uint
-- Digits_Value Uint_0 or No_Uint
-- Esize Uint_0 or No_Uint
-- Normalized_First_Bit No_Uint
-- Normalized_Position No_Uint
-- Normalized_Position_Max No_Uint
-- RM_Size Uint_0 or No_Uint
-- It would be cleaner to use No_Uint in all these cases, but historically
-- we chose to use Uint_0 at first, and the change over will take time ???
-- This is particularly true for the RM_Size field, where a value of zero
-- is legitimate. We deal with this by a considering that the value is
-- always known static for discrete types (and no other types can have
-- an RM_Size value of zero).
-- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one
-- more consideration, which is that we always return False for generic
-- types. Within a template, the size can look known, because of the fake
-- size values we put in template types, but they are not really known and
-- anyone testing if they are known within the template should get False as
-- a result to prevent incorrect assumptions.
function Known_Alignment (E : Entity_Id) return B;
function Known_Component_Bit_Offset (E : Entity_Id) return B;
function Known_Component_Size (E : Entity_Id) return B;
function Known_Esize (E : Entity_Id) return B;
function Known_Normalized_First_Bit (E : Entity_Id) return B;
function Known_Normalized_Position (E : Entity_Id) return B;
function Known_Normalized_Position_Max (E : Entity_Id) return B;
function Known_RM_Size (E : Entity_Id) return B;
function Known_Static_Component_Bit_Offset (E : Entity_Id) return B;
function Known_Static_Component_Size (E : Entity_Id) return B;
function Known_Static_Esize (E : Entity_Id) return B;
function Known_Static_Normalized_First_Bit (E : Entity_Id) return B;
function Known_Static_Normalized_Position (E : Entity_Id) return B;
function Known_Static_Normalized_Position_Max (E : Entity_Id) return B;
function Known_Static_RM_Size (E : Entity_Id) return B;
function Unknown_Alignment (E : Entity_Id) return B;
function Unknown_Component_Bit_Offset (E : Entity_Id) return B;
function Unknown_Component_Size (E : Entity_Id) return B;
function Unknown_Esize (E : Entity_Id) return B;
function Unknown_Normalized_First_Bit (E : Entity_Id) return B;
function Unknown_Normalized_Position (E : Entity_Id) return B;
function Unknown_Normalized_Position_Max (E : Entity_Id) return B;
function Unknown_RM_Size (E : Entity_Id) return B;
---------------------------------------------------
-- Access to Subprograms in Subprograms_For_Type --
---------------------------------------------------
function Is_Partial_DIC_Procedure (Id : E) return B;
function DIC_Procedure (Id : E) return E;
function Partial_DIC_Procedure (Id : E) return E;
function Invariant_Procedure (Id : E) return E;
function Partial_Invariant_Procedure (Id : E) return E;
function Predicate_Function (Id : E) return E;
function Predicate_Function_M (Id : E) return E;
procedure Set_DIC_Procedure (Id : E; V : E);
procedure Set_Partial_DIC_Procedure (Id : E; V : E);
procedure Set_Invariant_Procedure (Id : E; V : E);
procedure Set_Partial_Invariant_Procedure (Id : E; V : E);
procedure Set_Predicate_Function (Id : E; V : E);
procedure Set_Predicate_Function_M (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --
-----------------------------------
-- These routines are overloadings of some of the above Set procedures
-- where the argument is normally a Uint. The overloadings take an Int
-- parameter instead, and appropriately convert it. There are also
-- versions that implicitly initialize to the appropriate "not set"
-- value. The not set (unknown) values are as follows:
-- Alignment Uint_0
-- Component_Size Uint_0
-- Component_Bit_Offset No_Uint
-- Digits_Value Uint_0
-- Esize Uint_0
-- Normalized_First_Bit No_Uint
-- Normalized_Position No_Uint
-- Normalized_Position_Max No_Uint
-- RM_Size Uint_0
-- It would be cleaner to use No_Uint in all these cases, but historically
-- we chose to use Uint_0 at first, and the change over will take time ???
-- This is particularly true for the RM_Size field, where a value of zero
-- is legitimate and causes some special tests around the code.
-- Contrary to the corresponding Set procedures above, these routines
-- do NOT check the entity kind of their argument, instead they set the
-- underlying Uint fields directly (this allows them to be used for
-- entities whose Ekind has not been set yet).
procedure Init_Alignment (Id : E; V : Int);
procedure Init_Component_Bit_Offset (Id : E; V : Int);
procedure Init_Component_Size (Id : E; V : Int);
procedure Init_Digits_Value (Id : E; V : Int);
procedure Init_Esize (Id : E; V : Int);
procedure Init_Normalized_First_Bit (Id : E; V : Int);
procedure Init_Normalized_Position (Id : E; V : Int);
procedure Init_Normalized_Position_Max (Id : E; V : Int);
procedure Init_RM_Size (Id : E; V : Int);
procedure Init_Alignment (Id : E);
procedure Init_Component_Bit_Offset (Id : E);
procedure Init_Component_Size (Id : E);
procedure Init_Digits_Value (Id : E);
procedure Init_Esize (Id : E);
procedure Init_Normalized_First_Bit (Id : E);
procedure Init_Normalized_Position (Id : E);
procedure Init_Normalized_Position_Max (Id : E);
procedure Init_RM_Size (Id : E);
procedure Init_Component_Location (Id : E);
-- Initializes all fields describing the location of a component
-- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit,
-- Normalized_Position_Max, Esize) to all be Unknown.
procedure Init_Size (Id : E; V : Int);
-- Initialize both the Esize and RM_Size fields of E to V
procedure Init_Size_Align (Id : E);
-- This procedure initializes both size fields and the alignment
-- field to all be Unknown.
procedure Init_Object_Size_Align (Id : E);
-- Same as Init_Size_Align except RM_Size field (which is only for types)
-- is unaffected.
---------------
-- Iterators --
---------------
-- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj)
-- We define the set of Proc_Next_xxx routines simply for the purposes
-- of inlining them without necessarily inlining the function.
procedure Proc_Next_Component (N : in out Node_Id);
procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id);
procedure Proc_Next_Discriminant (N : in out Node_Id);
procedure Proc_Next_Formal (N : in out Node_Id);
procedure Proc_Next_Formal_With_Extras (N : in out Node_Id);
procedure Proc_Next_Index (N : in out Node_Id);
procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id);
procedure Proc_Next_Literal (N : in out Node_Id);
procedure Proc_Next_Stored_Discriminant (N : in out Node_Id);
pragma Inline (Proc_Next_Component);
pragma Inline (Proc_Next_Component_Or_Discriminant);
pragma Inline (Proc_Next_Discriminant);
pragma Inline (Proc_Next_Formal);
pragma Inline (Proc_Next_Formal_With_Extras);
pragma Inline (Proc_Next_Index);
pragma Inline (Proc_Next_Inlined_Subprogram);
pragma Inline (Proc_Next_Literal);
pragma Inline (Proc_Next_Stored_Discriminant);
procedure Next_Component (N : in out Node_Id)
renames Proc_Next_Component;
procedure Next_Component_Or_Discriminant (N : in out Node_Id)
renames Proc_Next_Component_Or_Discriminant;
procedure Next_Discriminant (N : in out Node_Id)
renames Proc_Next_Discriminant;
procedure Next_Formal (N : in out Node_Id)
renames Proc_Next_Formal;
procedure Next_Formal_With_Extras (N : in out Node_Id)
renames Proc_Next_Formal_With_Extras;
procedure Next_Index (N : in out Node_Id)
renames Proc_Next_Index;
procedure Next_Inlined_Subprogram (N : in out Node_Id)
renames Proc_Next_Inlined_Subprogram;
procedure Next_Literal (N : in out Node_Id)
renames Proc_Next_Literal;
procedure Next_Stored_Discriminant (N : in out Node_Id)
renames Proc_Next_Stored_Discriminant;
---------------------------
-- Testing Warning Flags --
---------------------------
-- These routines are to be used rather than testing flags Warnings_Off,
-- Has_Pragma_Unmodified, Has_Pragma_Unreferenced. They deal with setting
-- the flags Warnings_Off_Used[_Unmodified|Unreferenced] for later access.
function Has_Warnings_Off (E : Entity_Id) return Boolean;
-- If Warnings_Off is set on E, then returns True and also sets the flag
-- Warnings_Off_Used on E. If Warnings_Off is not set on E, returns False
-- and has no side effect.
function Has_Unmodified (E : Entity_Id) return Boolean;
-- If flag Has_Pragma_Unmodified is set on E, returns True with no side
-- effects. Otherwise if Warnings_Off is set on E, returns True and also
-- sets the flag Warnings_Off_Used_Unmodified on E. If neither of the flags
-- Warnings_Off nor Has_Pragma_Unmodified is set, returns False with no
-- side effects.
function Has_Unreferenced (E : Entity_Id) return Boolean;
-- If flag Has_Pragma_Unreferenced is set on E, returns True with no side
-- effects. Otherwise if Warnings_Off is set on E, returns True and also
-- sets the flag Warnings_Off_Used_Unreferenced on E. If neither of the
-- flags Warnings_Off nor Has_Pragma_Unreferenced is set, returns False
-- with no side effects.
----------------------------------------------
-- Subprograms for Accessing Rep Item Chain --
----------------------------------------------
-- The First_Rep_Item field of every entity points to a linked list (linked
-- through Next_Rep_Item) of representation pragmas, attribute definition
-- clauses, representation clauses, and aspect specifications that apply to
-- the item. Note that in the case of types, it is assumed that any such
-- rep items for a base type also apply to all subtypes. This is achieved
-- by having the chain for subtypes link onto the chain for the base type,
-- so that new entries for the subtype are added at the start of the chain.
--
-- Note: aspect specification nodes are linked only when evaluation of the
-- expression is deferred to the freeze point. For further details see
-- Sem_Ch13.Analyze_Aspect_Specifications.
function Get_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of an
-- attribute definition clause with the given attribute Id. If found, the
-- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned.
-- WARNING: There is a matching C declaration of this subprogram in fe.h
function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id;
-- Searches the Rep_Item chain of entity E, for an instance of a pragma
-- with the given pragma Id. If found, the value returned is the N_Pragma
-- node, otherwise Empty is returned. The following contract pragmas that
-- appear in N_Contract nodes are also handled by this routine:
-- Abstract_State
-- Async_Readers
-- Async_Writers
-- Attach_Handler
-- Constant_After_Elaboration
-- Contract_Cases
-- Depends
-- Effective_Reads
-- Effective_Writes
-- Global
-- Initial_Condition
-- Initializes
-- Interrupt_Handler
-- No_Caching
-- Part_Of
-- Precondition
-- Postcondition
-- Refined_Depends
-- Refined_Global
-- Refined_Post
-- Refined_State
-- Subprogram_Variant
-- Test_Case
-- Volatile_Function
function Get_Class_Wide_Pragma
(E : Entity_Id;
Id : Pragma_Id) return Node_Id;
-- Examine Rep_Item chain to locate a classwide pre- or postcondition of a
-- primitive operation. Returns Empty if not present.
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record
-- representation clause, and if found, returns it. Returns Empty
-- if no such clause is found.
function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
-- Return True if N is present in the Rep_Item chain for a given entity E
procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
-- N is the node for a representation pragma, representation clause, an
-- attribute definition clause, or an aspect specification that applies to
-- entity E. This procedure links the node N onto the Rep_Item chain for
-- entity E. Note that it is an error to call this procedure with E being
-- overloadable, and N being a pragma that applies to multiple overloadable
-- entities (Convention, Interface, Inline, Inline_Always, Import, Export,
-- External). This is not allowed even in the case where the entity is not
-- overloaded, since we can't rely on it being present in the overloaded
-- case, it is not useful to have it present in the non-overloaded case.
-------------------------------
-- Miscellaneous Subprograms --
-------------------------------
procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id);
-- Add an entity to the list of entities declared in the scope Scop
function Get_Full_View (T : Entity_Id) return Entity_Id;
-- If T is an incomplete type and the full declaration has been seen, or
-- is the name of a class_wide type whose root is incomplete, return the
-- corresponding full declaration, else return T itself.
function Is_Entity_Name (N : Node_Id) return Boolean;
-- Test if the node N is the name of an entity (i.e. is an identifier,
-- expanded name, or an attribute reference that returns an entity).
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Link_Entities (First : Entity_Id; Second : Entity_Id);
-- Link entities First and Second in one entity chain.
--
-- NOTE: No updates are done to the First_Entity and Last_Entity fields
-- of the scope.
procedure Remove_Entity (Id : Entity_Id);
-- Remove entity Id from the entity chain of its scope
function Subtype_Kind (K : Entity_Kind) return Entity_Kind;
-- Given an entity_kind K this function returns the entity_kind
-- corresponding to subtype kind of the type represented by K. For
-- example if K is E_Signed_Integer_Type then E_Signed_Integer_Subtype
-- is returned. If K is already a subtype kind it itself is returned. An
-- internal error is generated if no such correspondence exists for K.
procedure Unlink_Next_Entity (Id : Entity_Id);
-- Unchain entity Id's forward link within the entity chain of its scope
function Is_Volatile (Id : E) return B;
procedure Set_Is_Volatile (Id : E; V : B := True);
-- Call [Set_]Is_Volatile_Type/Is_Volatile_Object as appropriate for the
-- Ekind of Id.
function Convention
(N : Entity_Id) return Convention_Id renames Basic_Convention;
procedure Set_Convention (E : Entity_Id; Val : Convention_Id);
-- Same as Set_Basic_Convention, but with an extra check for access types.
-- In particular, if E is an access-to-subprogram type, and Val is a
-- foreign convention, then we set Can_Use_Internal_Rep to False on E.
-- Also, if the Etype of E is set and is an anonymous access type with
-- no convention set, this anonymous type inherits the convention of E.
----------------------------------
-- Debugging Output Subprograms --
----------------------------------
procedure Write_Entity_Info (Id : Entity_Id; Prefix : String);
-- A debugging procedure to write out information about an entity
-- ????Make sure the Inlines from Einfo were fully copied here.
-- ????
-- The following Inline pragmas are *not* read by XEINFO when building the
-- C version of this interface automatically (so the C version will end up
-- making out of line calls). The pragma scan in XEINFO will be terminated
-- on encountering the END XEINFO INLINES line. We inline things here which
-- are small, but not of the canonical attribute access/set format that can
-- be handled by XEINFO.
pragma Inline (Address_Clause);
pragma Inline (Alignment_Clause);
pragma Inline (Base_Type);
pragma Inline (Has_Foreign_Convention);
pragma Inline (Has_Non_Limited_View);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Boolean_Type);
pragma Inline (Is_Constant_Object);
pragma Inline (Is_Controlled);
pragma Inline (Is_Discriminal);
pragma Inline (Is_Entity_Name);
pragma Inline (Is_Finalizer);
pragma Inline (Is_Full_Access);
pragma Inline (Is_Null_State);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
pragma Inline (Is_Prival);
pragma Inline (Is_Protected_Component);
pragma Inline (Is_Protected_Record_Type);
pragma Inline (Is_String_Type);
pragma Inline (Is_Task_Record_Type);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Scope_Depth);
pragma Inline (Scope_Depth_Set);
pragma Inline (Size_Clause);
pragma Inline (Stream_Size_Clause);
pragma Inline (Type_High_Bound);
pragma Inline (Type_Low_Bound);
pragma Inline (Known_Alignment);
pragma Inline (Known_Component_Bit_Offset);
pragma Inline (Known_Component_Size);
pragma Inline (Known_Esize);
pragma Inline (Known_Normalized_First_Bit);
pragma Inline (Known_Normalized_Position);
pragma Inline (Known_Normalized_Position_Max);
pragma Inline (Known_RM_Size);
pragma Inline (Known_Static_Component_Bit_Offset);
pragma Inline (Known_Static_Component_Size);
pragma Inline (Known_Static_Esize);
pragma Inline (Known_Static_Normalized_First_Bit);
pragma Inline (Known_Static_Normalized_Position);
pragma Inline (Known_Static_Normalized_Position_Max);
pragma Inline (Known_Static_RM_Size);
pragma Inline (Unknown_Alignment);
pragma Inline (Unknown_Component_Bit_Offset);
pragma Inline (Unknown_Component_Size);
pragma Inline (Unknown_Esize);
pragma Inline (Unknown_Normalized_First_Bit);
pragma Inline (Unknown_Normalized_Position);
pragma Inline (Unknown_Normalized_Position_Max);
pragma Inline (Unknown_RM_Size);
pragma Inline (Init_Alignment);
pragma Inline (Init_Component_Bit_Offset);
pragma Inline (Init_Component_Size);
pragma Inline (Init_Digits_Value);
pragma Inline (Init_Esize);
pragma Inline (Init_Normalized_First_Bit);
pragma Inline (Init_Normalized_Position);
pragma Inline (Init_Normalized_Position_Max);
pragma Inline (Init_RM_Size);
end Einfo.Utils;

11571
gcc/ada/einfo.adb
View File

File diff suppressed because it is too large Load Diff

3599
gcc/ada/einfo.ads
View File

File diff suppressed because it is too large Load Diff

11
gcc/ada/errout.adb
View File

@ -33,7 +33,9 @@ with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Erroutc; use Erroutc;
with Gnatvsn; use Gnatvsn;
with Lib; use Lib;
@ -43,7 +45,9 @@ with Output; use Output;
with Scans; use Scans;
with Sem_Aux; use Sem_Aux;
with Sinput; use Sinput;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stylesw; use Stylesw;
@ -4010,7 +4014,8 @@ package body Errout is
-- other errors. The reason we eliminate unfrozen types is that
-- messages issued before the freeze type are for sure OK.
elsif Is_Frozen (E)
elsif Nkind (N) in N_Entity
and then Is_Frozen (E)
and then Serious_Errors_Detected > 0
and then Nkind (N) /= N_Component_Clause
and then Nkind (Parent (N)) /= N_Component_Clause

3
gcc/ada/eval_fat.adb
View File

@ -23,7 +23,8 @@
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Opt; use Opt;
with Sem_Util; use Sem_Util;

8
gcc/ada/exp_aggr.adb
View File

@ -27,7 +27,9 @@ with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
@ -59,7 +61,9 @@ with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;

7
gcc/ada/exp_atag.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Disp; use Exp_Disp;
with Namet; use Namet;
@ -32,7 +34,8 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Util; use Sem_Util;

11
gcc/ada/exp_attr.adb
View File

@ -26,7 +26,9 @@
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
@ -59,7 +61,9 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@ -7330,7 +7334,7 @@ package body Exp_Attr is
P : Node_Id := Pref;
begin
-- If the prefix has an entity, use the Esize from this entity
-- If the prefix is an object, use the Esize from this object
-- to handle in a more user friendly way the case of objects
-- or components with a large Size aspect: if a Size aspect is
-- specified, we want to read a scalar value as large as the
@ -7343,6 +7347,7 @@ package body Exp_Attr is
if Nkind (P) in N_Has_Entity
and then Present (Entity (P))
and then Is_Object (Entity (P))
and then Esize (Entity (P)) /= Uint_0
then
if Esize (Entity (P)) <= System_Max_Integer_Size then

27
gcc/ada/exp_cg.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
@ -36,7 +38,9 @@ with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with System; use System;
@ -376,7 +380,14 @@ package body Exp_CG is
and then Nkind (Parent (Par)) /= N_Compilation_Unit
loop
Par := Parent (Par);
pragma Assert (Present (Par));
-- Par can legitimately be empty inside a class-wide
-- precondition; the "real" call will be found inside the
-- generated pragma.
if No (Par) then
return;
end if;
end loop;
Set_Parent (Copy, Par);
@ -429,7 +440,7 @@ package body Exp_CG is
procedure Write_Call_Info (Call : Node_Id) is
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call);
Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
Prim : constant Entity_Id := Entity (Sinfo.Name (Call));
Prim : constant Entity_Id := Entity (Sinfo.Nodes.Name (Call));
P : constant Node_Id := Parent (Call);
begin
@ -559,13 +570,13 @@ package body Exp_CG is
Write_Char ('"');
Write_Name (Chars (Parent_Typ));
-- Note: Einfo prefix not needed if this routine is moved to
-- Note: Einfo.Entities prefix not needed if this routine is moved to
-- exp_disp???
if Present (Einfo.Interfaces (Typ))
and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ))
if Present (Einfo.Entities.Interfaces (Typ))
and then not Is_Empty_Elmt_List (Einfo.Entities.Interfaces (Typ))
then
Elmt := First_Elmt (Einfo.Interfaces (Typ));
Elmt := First_Elmt (Einfo.Entities.Interfaces (Typ));
while Present (Elmt) loop
Write_Str (", ");
Write_Name (Chars (Node (Elmt)));

8
gcc/ada/exp_ch11.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
@ -42,7 +44,9 @@ with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;

7
gcc/ada/exp_ch12.adb
View File

@ -25,10 +25,13 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Exp_Util; use Exp_Util;
with Nmake; use Nmake;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;

8
gcc/ada/exp_ch13.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
@ -45,7 +47,9 @@ with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;

8
gcc/ada/exp_ch2.adb
View File

@ -26,7 +26,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
@ -40,7 +42,9 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Tbuild; use Tbuild;

8
gcc/ada/exp_ch3.adb
View File

@ -26,7 +26,9 @@
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
@ -66,7 +68,9 @@ with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Stand; use Stand;
with Snames; use Snames;
with Tbuild; use Tbuild;

8
gcc/ada/exp_ch4.adb
View File

@ -26,7 +26,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
@ -61,7 +63,9 @@ with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with SCIL_LL; use SCIL_LL;

8
gcc/ada/exp_ch5.adb
View File

@ -27,7 +27,9 @@ with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
@ -45,7 +47,9 @@ with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;

10
gcc/ada/exp_ch6.adb
View File

@ -28,7 +28,9 @@ with Aspects; use Aspects;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Elists; use Elists;
with Expander; use Expander;
@ -68,7 +70,9 @@ with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
@ -2209,7 +2213,7 @@ package body Exp_Ch6 is
-- Check for volatility mismatch
if Is_Volatile_Object (Actual) and then not Is_Volatile (E_Formal)
if Is_Volatile_Object_Ref (Actual) and then not Is_Volatile (E_Formal)
then
if Comes_From_Source (N) then
Error_Msg_N

8
gcc/ada/exp_ch7.adb
View File

@ -30,7 +30,9 @@
with Atree; use Atree;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch6; use Exp_Ch6;
@ -52,7 +54,9 @@ with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;

8
gcc/ada/exp_ch8.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
@ -39,7 +41,9 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;

8
gcc/ada/exp_ch9.adb
View File

@ -26,7 +26,9 @@
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
@ -59,7 +61,9 @@ with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;

8
gcc/ada/exp_code.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Lib; use Lib;
with Namet; use Namet;
@ -36,7 +38,9 @@ with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Stringt; use Stringt;
with Tbuild; use Tbuild;

8
gcc/ada/exp_dbug.adb
View File

@ -26,7 +26,9 @@
with Alloc;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
@ -35,7 +37,9 @@ with Output; use Output;
with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Stand; use Stand;
with Stringt; use Stringt;
with Table;

17
gcc/ada/exp_disp.adb
View File

@ -26,7 +26,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
@ -58,7 +60,9 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
@ -4093,7 +4097,10 @@ package body Exp_Disp is
Count := Count + 1;
end loop;
pragma Assert (Related_Type (Node (Elmt)) = Typ);
-- Related_Type (Node (Elmt)) should be equal to Typ here, but we
-- can't assert that, because it is sometimes false in illegal
-- programs. We can't check Serious_Errors_Detected, because the
-- errors have not yet been detected.
Get_External_Name (Node (Elmt));
Set_Interface_Name (DT,
@ -4694,8 +4701,8 @@ package body Exp_Disp is
Discard_Names : constant Boolean :=
Present (No_Tagged_Streams_Pragma (Typ))
and then (Global_Discard_Names
or else Einfo.Discard_Names (Typ));
and then
(Global_Discard_Names or else Einfo.Entities.Discard_Names (Typ));
-- The following name entries are used by Make_DT to generate a number
-- of entities related to a tagged type. These entities may be generated

8
gcc/ada/exp_dist.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Strm; use Exp_Strm;
@ -44,7 +46,9 @@ with Sem_Ch12; use Sem_Ch12;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;

7
gcc/ada/exp_fixd.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
@ -36,7 +38,8 @@ with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;

8
gcc/ada/exp_imgv.adb
View File

@ -26,8 +26,10 @@
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Debug; use Debug;
with Einfo; use Einfo;
with Exp_Put_Image;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
@ -39,7 +41,9 @@ with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;

8
gcc/ada/exp_intr.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
@ -48,7 +50,9 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;

8
gcc/ada/exp_pakd.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
@ -43,7 +45,9 @@ with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;

8
gcc/ada/exp_prag.adb
View File

@ -27,7 +27,9 @@ with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch11; use Exp_Ch11;
@ -47,7 +49,9 @@ with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;

8
gcc/ada/exp_put_image.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Tss; use Exp_Tss;
with Exp_Util;
with Debug; use Debug;
@ -36,7 +38,9 @@ with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand;
with Tbuild; use Tbuild;

6
gcc/ada/exp_sel.adb
View File

@ -23,12 +23,14 @@
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;

8
gcc/ada/exp_smem.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
@ -37,7 +39,9 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;

8
gcc/ada/exp_spark.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Attr;
with Exp_Ch4;
with Exp_Ch5; use Exp_Ch5;
@ -40,7 +42,9 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;

8
gcc/ada/exp_strm.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
@ -33,7 +35,9 @@ with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;

7
gcc/ada/exp_tss.adb
View File

@ -24,7 +24,9 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
@ -34,7 +36,8 @@ with Rident; use Rident;
with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
package body Exp_Tss is

8
gcc/ada/exp_unst.adb
View File

@ -25,7 +25,9 @@
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
@ -41,7 +43,9 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;

34
gcc/ada/exp_util.adb
View File

@ -28,7 +28,9 @@ with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
@ -57,6 +59,7 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@ -9183,7 +9186,7 @@ package body Exp_Util is
-- True if object reference with volatile type
elsif Is_Volatile_Object (N) then
elsif Is_Volatile_Object_Ref (N) then
return True;
-- True if reference to volatile entity
@ -12203,15 +12206,28 @@ package body Exp_Util is
if Nkind (Context) in N_Subprogram_Call
and then No (Type_Map.Get (Entity (Name (Context))))
then
New_Ref :=
Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
declare
-- We need to use the Original_Node of the callee, in
-- case it was already modified. Note that we are using
-- Traverse_Proc to walk the tree, and it is defined to
-- walk subtrees in an arbitrary order.
-- Do not process the generated type conversion because
-- both the parent type and the derived type are in the
-- Type_Map table. This will clobber the type conversion
-- by resetting its subtype mark.
Callee : constant Entity_Id :=
Entity (Original_Node (Name (Context)));
begin
if No (Type_Map.Get (Callee)) then
New_Ref :=
Convert_To
(Type_Of_Formal (Context, Old_Ref), New_Ref);
Result := Skip;
-- Do not process the generated type conversion
-- because both the parent type and the derived type
-- are in the Type_Map table. This will clobber the
-- type conversion by resetting its subtype mark.
Result := Skip;
end if;
end;
end if;
-- Otherwise there is nothing to replace

3
gcc/ada/exp_util.ads
View File

@ -28,7 +28,8 @@
with Exp_Tss; use Exp_Tss;
with Namet; use Namet;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Types; use Types;
with Uintp; use Uintp;

3
gcc/ada/expander.adb
View File

@ -47,7 +47,8 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Table;
package body Expander is

404
gcc/ada/fe.h
View File

@ -69,14 +69,14 @@ extern Boolean Debug_Flag_NN;
/* einfo: */
#define Set_Alignment einfo__set_alignment
#define Set_Component_Bit_Offset einfo__set_component_bit_offset
#define Set_Component_Size einfo__set_component_size
#define Set_Esize einfo__set_esize
#define Set_Mechanism einfo__set_mechanism
#define Set_Normalized_First_Bit einfo__set_normalized_first_bit
#define Set_Normalized_Position einfo__set_normalized_position
#define Set_RM_Size einfo__set_rm_size
#define Set_Alignment einfo__entities__set_alignment
#define Set_Component_Bit_Offset einfo__entities__set_component_bit_offset
#define Set_Component_Size einfo__entities__set_component_size
#define Set_Esize einfo__entities__set_esize
#define Set_Mechanism einfo__entities__set_mechanism
#define Set_Normalized_First_Bit einfo__entities__set_normalized_first_bit
#define Set_Normalized_Position einfo__entities__set_normalized_position
#define Set_RM_Size einfo__entities__set_rm_size
extern void Set_Alignment (Entity_Id, Uint);
extern void Set_Component_Bit_Offset (Entity_Id, Uint);
@ -87,11 +87,11 @@ extern void Set_Normalized_First_Bit (Entity_Id, Uint);
extern void Set_Normalized_Position (Entity_Id, Uint);
extern void Set_RM_Size (Entity_Id, Uint);
#define Is_Entity_Name einfo__is_entity_name
#define Is_Entity_Name einfo__utils__is_entity_name
extern Boolean Is_Entity_Name (Node_Id);
#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause
#define Get_Attribute_Definition_Clause einfo__utils__get_attribute_definition_clause
extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char);
@ -301,9 +301,9 @@ extern Boolean Requires_Transient_Scope (Entity_Id);
/* sinfo: */
#define End_Location sinfo__end_location
#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code
#define Set_Present_Expr sinfo__set_present_expr
#define End_Location sinfo__utils__end_location
#define Set_Has_No_Elaboration_Code sinfo__nodes__set_has_no_elaboration_code
#define Set_Present_Expr sinfo__nodes__set_present_expr
extern Source_Ptr End_Location (Node_Id);
extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean);
@ -343,6 +343,384 @@ extern Boolean Stack_Check_Probes_On_Target;
extern Boolean Warn_On_Questionable_Layout;
// The following corresponds to Ada code in Einfo.Utils.
typedef Boolean B;
typedef Component_Alignment_Kind C;
typedef Entity_Id E;
typedef Mechanism_Type M;
typedef Node_Id N;
typedef Uint U;
typedef Ureal R;
typedef Elist_Id L;
typedef List_Id S;
#define Is_Access_Object_Type einfo__utils__is_access_object_type
B Is_Access_Object_Type (E Id);
#define Is_Named_Access_Type einfo__utils__is_named_access_type
B Is_Named_Access_Type (E Id);
#define Address_Clause einfo__utils__address_clause
N Address_Clause (E Id);
#define Aft_Value einfo__utils__aft_value
U Aft_Value (E Id);
#define Alignment_Clause einfo__utils__alignment_clause
N Alignment_Clause (E Id);
#define Base_Type einfo__utils__base_type
E Base_Type (E Id);
#define Declaration_Node einfo__utils__declaration_node
N Declaration_Node (E Id);
#define Designated_Type einfo__utils__designated_type
E Designated_Type (E Id);
#define First_Component einfo__utils__first_component
E First_Component (E Id);
#define First_Component_Or_Discriminant einfo__utils__first_component_or_discriminant
E First_Component_Or_Discriminant (E Id);
#define First_Formal einfo__utils__first_formal
E First_Formal (E Id);
#define First_Formal_With_Extras einfo__utils__first_formal_with_extras
E First_Formal_With_Extras (E Id);
#define Has_Attach_Handler einfo__utils__has_attach_handler
B Has_Attach_Handler (E Id);
#define Has_Entries einfo__utils__has_entries
B Has_Entries (E Id);
#define Has_Foreign_Convention einfo__utils__has_foreign_convention
B Has_Foreign_Convention (E Id);
#define Has_Interrupt_Handler einfo__utils__has_interrupt_handler
B Has_Interrupt_Handler (E Id);
#define Has_Non_Limited_View einfo__utils__has_non_limited_view
B Has_Non_Limited_View (E Id);
#define Has_Non_Null_Abstract_State einfo__utils__has_non_null_abstract_state
B Has_Non_Null_Abstract_State (E Id);
#define Has_Non_Null_Visible_Refinement einfo__utils__has_non_null_visible_refinement
B Has_Non_Null_Visible_Refinement (E Id);
#define Has_Null_Abstract_State einfo__utils__has_null_abstract_state
B Has_Null_Abstract_State (E Id);
#define Has_Null_Visible_Refinement einfo__utils__has_null_visible_refinement
B Has_Null_Visible_Refinement (E Id);
#define Implementation_Base_Type einfo__utils__implementation_base_type
E Implementation_Base_Type (E Id);
#define Is_Base_Type einfo__utils__is_base_type
B Is_Base_Type (E Id);
#define Is_Boolean_Type einfo__utils__is_boolean_type
B Is_Boolean_Type (E Id);
#define Is_Constant_Object einfo__utils__is_constant_object
B Is_Constant_Object (E Id);
#define Is_Controlled einfo__utils__is_controlled
B Is_Controlled (E Id);
#define Is_Discriminal einfo__utils__is_discriminal
B Is_Discriminal (E Id);
#define Is_Dynamic_Scope einfo__utils__is_dynamic_scope
B Is_Dynamic_Scope (E Id);
#define Is_Elaboration_Target einfo__utils__is_elaboration_target
B Is_Elaboration_Target (E Id);
#define Is_External_State einfo__utils__is_external_state
B Is_External_State (E Id);
#define Is_Finalizer einfo__utils__is_finalizer
B Is_Finalizer (E Id);
#define Is_Null_State einfo__utils__is_null_state
B Is_Null_State (E Id);
#define Is_Package_Or_Generic_Package einfo__utils__is_package_or_generic_package
B Is_Package_Or_Generic_Package (E Id);
#define Is_Packed_Array einfo__utils__is_packed_array
B Is_Packed_Array (E Id);
#define Is_Prival einfo__utils__is_prival
B Is_Prival (E Id);
#define Is_Protected_Component einfo__utils__is_protected_component
B Is_Protected_Component (E Id);
#define Is_Protected_Interface einfo__utils__is_protected_interface
B Is_Protected_Interface (E Id);
#define Is_Protected_Record_Type einfo__utils__is_protected_record_type
B Is_Protected_Record_Type (E Id);
#define Is_Relaxed_Initialization_State einfo__utils__is_relaxed_initialization_state
B Is_Relaxed_Initialization_State (E Id);
#define Is_Standard_Character_Type einfo__utils__is_standard_character_type
B Is_Standard_Character_Type (E Id);
#define Is_Standard_String_Type einfo__utils__is_standard_string_type
B Is_Standard_String_Type (E Id);
#define Is_String_Type einfo__utils__is_string_type
B Is_String_Type (E Id);
#define Is_Synchronized_Interface einfo__utils__is_synchronized_interface
B Is_Synchronized_Interface (E Id);
#define Is_Synchronized_State einfo__utils__is_synchronized_state
B Is_Synchronized_State (E Id);
#define Is_Task_Interface einfo__utils__is_task_interface
B Is_Task_Interface (E Id);
#define Is_Task_Record_Type einfo__utils__is_task_record_type
B Is_Task_Record_Type (E Id);
#define Is_Wrapper_Package einfo__utils__is_wrapper_package
B Is_Wrapper_Package (E Id);
#define Last_Formal einfo__utils__last_formal
E Last_Formal (E Id);
#define Machine_Emax_Value einfo__utils__machine_emax_value
U Machine_Emax_Value (E Id);
#define Machine_Emin_Value einfo__utils__machine_emin_value
U Machine_Emin_Value (E Id);
#define Machine_Mantissa_Value einfo__utils__machine_mantissa_value
U Machine_Mantissa_Value (E Id);
#define Machine_Radix_Value einfo__utils__machine_radix_value
U Machine_Radix_Value (E Id);
#define Model_Emin_Value einfo__utils__model_emin_value
U Model_Emin_Value (E Id);
#define Model_Epsilon_Value einfo__utils__model_epsilon_value
R Model_Epsilon_Value (E Id);
#define Model_Mantissa_Value einfo__utils__model_mantissa_value
U Model_Mantissa_Value (E Id);
#define Model_Small_Value einfo__utils__model_small_value
R Model_Small_Value (E Id);
#define Next_Component einfo__utils__next_component
E Next_Component (E Id);
#define Next_Component_Or_Discriminant einfo__utils__next_component_or_discriminant
E Next_Component_Or_Discriminant (E Id);
#define Next_Discriminant einfo__utils__next_discriminant
E Next_Discriminant (E Id);
#define Next_Formal einfo__utils__next_formal
E Next_Formal (E Id);
#define Next_Formal_With_Extras einfo__utils__next_formal_with_extras
E Next_Formal_With_Extras (E Id);
#define Number_Dimensions einfo__utils__number_dimensions
Pos Number_Dimensions (E Id);
#define Number_Entries einfo__utils__number_entries
Nat Number_Entries (E Id);
#define Number_Formals einfo__utils__number_formals
Pos Number_Formals (E Id);
#define Object_Size_Clause einfo__utils__object_size_clause
N Object_Size_Clause (E Id);
#define Partial_Refinement_Constituents einfo__utils__partial_refinement_constituents
L Partial_Refinement_Constituents (E Id);
#define Primitive_Operations einfo__utils__primitive_operations
L Primitive_Operations (E Id);
#define Root_Type einfo__utils__root_type
E Root_Type (E Id);
#define Safe_Emax_Value einfo__utils__safe_emax_value
U Safe_Emax_Value (E Id);
#define Safe_First_Value einfo__utils__safe_first_value
R Safe_First_Value (E Id);
#define Safe_Last_Value einfo__utils__safe_last_value
R Safe_Last_Value (E Id);
#define Scope_Depth einfo__utils__scope_depth
U Scope_Depth (E Id);
#define Scope_Depth_Set einfo__utils__scope_depth_set
B Scope_Depth_Set (E Id);
#define Size_Clause einfo__utils__size_clause
N Size_Clause (E Id);
#define Stream_Size_Clause einfo__utils__stream_size_clause
N Stream_Size_Clause (E Id);
#define Type_High_Bound einfo__utils__type_high_bound
N Type_High_Bound (E Id);
#define Type_Low_Bound einfo__utils__type_low_bound
N Type_Low_Bound (E Id);
#define Underlying_Type einfo__utils__underlying_type
E Underlying_Type (E Id);
#define Known_Alignment einfo__utils__known_alignment
B Known_Alignment (Entity_Id E);
#define Known_Component_Bit_Offset einfo__utils__known_component_bit_offset
B Known_Component_Bit_Offset (Entity_Id E);
#define Known_Component_Size einfo__utils__known_component_size
B Known_Component_Size (Entity_Id E);
#define Known_Esize einfo__utils__known_esize
B Known_Esize (Entity_Id E);
#define Known_Normalized_First_Bit einfo__utils__known_normalized_first_bit
B Known_Normalized_First_Bit (Entity_Id E);
#define Known_Normalized_Position einfo__utils__known_normalized_position
B Known_Normalized_Position (Entity_Id E);
#define Known_Normalized_Position_Max einfo__utils__known_normalized_position_max
B Known_Normalized_Position_Max (Entity_Id E);
#define Known_RM_Size einfo__utils__known_rm_size
B Known_RM_Size (Entity_Id E);
#define Known_Static_Component_Bit_Offset einfo__utils__known_static_component_bit_offset
B Known_Static_Component_Bit_Offset (Entity_Id E);
#define Known_Static_Component_Size einfo__utils__known_static_component_size
B Known_Static_Component_Size (Entity_Id E);
#define Known_Static_Esize einfo__utils__known_static_esize
B Known_Static_Esize (Entity_Id E);
#define Known_Static_Normalized_First_Bit einfo__utils__known_static_normalized_first_bit
B Known_Static_Normalized_First_Bit (Entity_Id E);
#define Known_Static_Normalized_Position einfo__utils__known_static_normalized_position
B Known_Static_Normalized_Position (Entity_Id E);
#define Known_Static_Normalized_Position_Max einfo__utils__known_static_normalized_position_max
B Known_Static_Normalized_Position_Max (Entity_Id E);
#define Known_Static_RM_Size einfo__utils__known_static_rm_size
B Known_Static_RM_Size (Entity_Id E);
#define Unknown_Alignment einfo__utils__unknown_alignment
B Unknown_Alignment (Entity_Id E);
#define Unknown_Component_Bit_Offset einfo__utils__unknown_component_bit_offset
B Unknown_Component_Bit_Offset (Entity_Id E);
#define Unknown_Component_Size einfo__utils__unknown_component_size
B Unknown_Component_Size (Entity_Id E);
#define Unknown_Esize einfo__utils__unknown_esize
B Unknown_Esize (Entity_Id E);
#define Unknown_Normalized_First_Bit einfo__utils__unknown_normalized_first_bit
B Unknown_Normalized_First_Bit (Entity_Id E);
#define Unknown_Normalized_Position einfo__utils__unknown_normalized_position
B Unknown_Normalized_Position (Entity_Id E);
#define Unknown_Normalized_Position_Max einfo__utils__unknown_normalized_position_max
B Unknown_Normalized_Position_Max (Entity_Id E);
#define Unknown_RM_Size einfo__utils__unknown_rm_size
B Unknown_RM_Size (Entity_Id E);
// The following were automatically generated as INLINE functions in the old
// einfo.h by the spitbol program.
// Is it important that they be inlined????
#define Is_Discrete_Or_Fixed_Point_Type einfo__utils__is_discrete_or_fixed_point_type
B Is_Discrete_Or_Fixed_Point_Type (E Id);
#define Is_Floating_Point_Type einfo__utils__is_floating_point_type
B Is_Floating_Point_Type (E Id);
#define Is_Record_Type einfo__utils__is_record_type
B Is_Record_Type (E Id);
#define Has_DIC einfo__utils__has_dic
B Has_DIC (E Id);
#define Has_Invariants einfo__utils__has_invariants
B Has_Invariants (E Id);
#define Is_Full_Access einfo__utils__is_full_access
B Is_Full_Access (E Id);
#define Next_Index einfo__utils__next_index
Node_Id Next_Index (Node_Id Id);
#define Next_Literal einfo__utils__next_literal
E Next_Literal (E Id);
#define Next_Stored_Discriminant einfo__utils__next_stored_discriminant
E Next_Stored_Discriminant (E Id);
#define Parameter_Mode einfo__utils__parameter_mode
// Parameter_Mode really returns Formal_Kind, but that is not visible, because
// fe.h is included before einfo.h.
Entity_Kind Parameter_Mode (E Id);
#define Is_List_Member einfo__utils__is_list_member
B Is_List_Member (N Node);
#define List_Containing einfo__utils__list_containing
S List_Containing (N Node);
// The following is needed because Convention in Sem_Util is a renaming
// of Basic_Convention.
#define Convention einfo__entities__basic_convention
Convention_Id Convention (N Node);
// See comments regarding Entity_Or_Associated_Node in Sinfo.Utils.
#define Entity sinfo__nodes__entity_or_associated_node
Entity_Id Entity (N Node);
// See comments regarding Renamed_Or_Alias in Einfo.Utils
#define Alias einfo__entities__renamed_or_alias
#define Renamed_Entity einfo__entities__renamed_or_alias
Node_Id Renamed_Entity (N Node);
#define Renamed_Object einfo__entities__renamed_or_alias
Node_Id Renamed_Object (N Node);
#ifdef __cplusplus
}
#endif

11
gcc/ada/freeze.adb
View File

@ -28,7 +28,9 @@ with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
@ -59,7 +61,9 @@ with Sem_Mech; use Sem_Mech;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@ -7545,7 +7549,7 @@ package body Freeze is
Typ := Empty;
if Nkind (N) in N_Has_Etype then
if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
if not Is_Frozen (Etype (N)) then
Typ := Etype (N);
@ -7566,6 +7570,7 @@ package body Freeze is
-- an initialization procedure from freezing the variable.
if Is_Entity_Name (N)
and then Present (Entity (N))
and then not Is_Frozen (Entity (N))
and then (Nkind (N) /= N_Identifier
or else Comes_From_Source (N)

4
gcc/ada/frontend.adb
View File

@ -60,7 +60,9 @@ with Sem_SCIL;
with Sem_Elab; use Sem_Elab;
with Sem_Prag; use Sem_Prag;
with Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with SCIL_LL;

37
gcc/ada/gcc-interface/Make-lang.in
View File

@ -272,6 +272,8 @@ GNAT_ADA_OBJS = \
ada/cstand.o \
ada/debug.o \
ada/debug_a.o \
ada/einfo-entities.o \
ada/einfo-utils.o \
ada/einfo.o \
ada/elists.o \
ada/err_vars.o \
@ -424,6 +426,7 @@ GNAT_ADA_OBJS = \
ada/scng.o \
ada/scos.o \
ada/sdefault.o \
ada/seinfo.o \
ada/sem.o \
ada/sem_aggr.o \
ada/sem_attr.o \
@ -459,6 +462,8 @@ GNAT_ADA_OBJS = \
ada/sem_warn.o \
ada/set_targ.o \
ada/sinfo-cn.o \
ada/sinfo-nodes.o \
ada/sinfo-utils.o \
ada/sinfo.o \
ada/sinput-d.o \
ada/sinput-l.o \
@ -478,7 +483,6 @@ GNAT_ADA_OBJS = \
ada/targparm.o \
ada/tbuild.o \
ada/treepr.o \
ada/treeprs.o \
ada/ttypes.o \
ada/types.o \
ada/uintp.o \
@ -526,6 +530,8 @@ GNATBIND_OBJS = \
ada/csets.o \
ada/cstreams.o \
ada/debug.o \
ada/einfo-entities.o \
ada/einfo-utils.o \
ada/einfo.o \
ada/elists.o \
ada/env.o \
@ -618,7 +624,10 @@ GNATBIND_OBJS = \
ada/scng.o \
ada/sdefault.o \
ada/seh_init.o \
ada/seinfo.o \
ada/sem_aux.o \
ada/sinfo-nodes.o \
ada/sinfo-utils.o \
ada/sinfo.o \
ada/sinput-c.o \
ada/sinput.o \
@ -879,7 +888,7 @@ ada.mostlyclean:
-$(RM) ada/*$(objext) ada/*.ali ada/b_gnat*.ads ada/b_gnat*.adb
-$(RM) ada/*$(objext).gnatd.n
-$(RM) ada/*$(coverageexts)
-$(RM) ada/sdefault.adb ada/stamp-sdefault ada/stamp-snames
-$(RM) ada/stamp-sdefault ada/stamp-snames ada/stamp-gen_il
-$(RMDIR) ada/tools
-$(RMDIR) ada/libgnat
-$(RM) gnatbind$(exeext) gnat1$(exeext)
@ -907,7 +916,6 @@ ada.maintainer-clean:
-$(RM) ada/einfo.h
-$(RM) ada/nmake.adb
-$(RM) ada/nmake.ads
-$(RM) ada/treeprs.ads
-$(RM) ada/snames.ads ada/snames.adb ada/snames.h
# Stage hooks:
@ -1033,11 +1041,6 @@ ada/b_gnatb.o : ada/b_gnatb.adb
include $(srcdir)/ada/Make-generated.in
update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \
ada/nmake.ads
$(RM) $(addprefix $(srcdir)/ada/,$(notdir $^))
$(CP) $^ $(srcdir)/ada
ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-unccon.ads \
ada/libgnat/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \
ada/opt.ads ada/osint.ads ada/output.ads ada/sdefault.ads ada/sdefault.adb \
@ -1099,13 +1102,23 @@ ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads
ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads
$(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION)
ada_generated_files = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \
ada/treeprs.ads ada/snames.ads ada/snames.adb ada/snames.h \
ada/generated/gnatvsn.ads
# All generated files. Perhaps we should build all of these in the same
# subdirectory, and get rid of ada/bldtools.
ADA_GENERATED_FILES = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \
ada/snames.ads ada/snames.adb ada/snames.h \
ada/generated/gnatvsn.ads \
ada/seinfo.ads \
ada/seinfo_tables.ads ada/seinfo_tables.adb \
ada/sinfo-nodes.ads ada/sinfo-nodes.adb \
ada/einfo-entities.ads ada/einfo-entities.adb
# Only used to manually trigger the creation of the generated files.
.PHONY:
ada_generated_files: $(ADA_GENERATED_FILES)
# When building from scratch we don't have dependency files, the only thing
# we need to ensure is that the generated files are created first.
$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ada_generated_files)
$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ADA_GENERATED_FILES)
# Manually include the auto-generated dependencies for the Ada host objects.
ADA_DEPFILES = $(foreach obj,$(GNAT1_ADA_OBJS) $(GNATBIND_OBJS),\

16
gcc/ada/gcc-interface/Makefile.in
View File

@ -104,7 +104,7 @@ TEXI2DVI = texi2dvi
TEXI2PDF = texi2pdf
GNATBIND_FLAGS = -static -x
ADA_CFLAGS =
ADAFLAGS = -W -Wall -gnatpg -gnata
ADAFLAGS = -W -Wall -gnatpg -gnata -gnatU
FORCE_DEBUG_ADAFLAGS = -g
NO_INLINE_ADAFLAGS = -fno-inline
NO_OMIT_ADAFLAGS = -fno-omit-frame-pointer
@ -332,6 +332,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o \
switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \
uname.o urealp.o usage.o widechar.o \
seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \
$(EXTRA_GNATMAKE_OBJS)
# Make arch match the current multilib so that the RTS selection code
@ -383,15 +384,20 @@ TOOLS_FLAGS_TO_PASS= \
GCC_LINK=$(CXX) $(GCC_LINK_FLAGS) $(LDFLAGS)
# Build directory for the tools. Let's copy the target-dependent
# sources using the same mechanism as for gnatlib. The other sources are
# accessed using the vpath directive below
# Build directory for the tools. We first need to copy the generated files,
# then the target-dependent sources using the same mechanism as for gnatlib.
# The other sources are accessed using the vpath directive below
GENERATED_FILES_FOR_TOOLS = \
einfo-entities.ads einfo-entities.adb sdefault.adb seinfo.ads \
sinfo-nodes.ads sinfo-nodes.adb snames.ads snames.adb
../stamp-tools:
-$(RM) tools/*
-$(RMDIR) tools
-$(MKDIR) tools
-(cd tools; $(LN_S) ../sdefault.adb ../snames.ads ../snames.adb .)
-(cd tools; $(foreach FILE,$(GENERATED_FILES_FOR_TOOLS), \
$(LN_S) ../$(FILE) $(FILE);))
-$(foreach PAIR,$(TOOLS_TARGET_PAIRS), \
$(RM) tools/$(word 1,$(subst <, ,$(PAIR)));\
$(LN_S) $(fsrcpfx)ada/$(word 2,$(subst <, ,$(PAIR))) \

16
gcc/ada/gcc-interface/decl.c
View File

@ -434,7 +434,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gcc_assert (!is_type
|| Known_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
|| (!IN (kind, Numeric_Kind)
|| (!Is_In_Numeric_Kind (kind)
&& !IN (kind, Enumeration_Kind)
&& (!IN (kind, Access_Kind)
|| kind == E_Access_Protected_Subprogram_Type
@ -443,7 +443,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
|| type_annotate_only)));
/* The RM size must be specified for all discrete and fixed-point types. */
gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
gcc_assert (!(Is_In_Discrete_Or_Fixed_Point_Kind (kind)
&& Unknown_RM_Size (gnat_entity)));
/* If we get here, it means we have not yet done anything with this entity.
@ -4568,7 +4568,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Similarly, if this is a record type or subtype at global level, call
elaborate_expression_2 on any field position. Skip any fields that
we haven't made trees for to avoid problems with class-wide types. */
if (IN (kind, Record_Kind) && global_bindings_p ())
if (Is_In_Record_Kind (kind) && global_bindings_p ())
for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
@ -7675,7 +7675,7 @@ typedef struct vinfo
will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
discriminants will be on GNU_FIELD_LIST. The other call to this function
is a recursive call for the component list of a variant and, in this case,
GNU_FIELD_LIST is empty.
GNU_FIELD_LIST is empty. Note that GNAT_COMPONENT_LIST may be Empty.
PACKED is 1 if this is for a packed record or -1 if this is for a record
with Component_Alignment of Storage_Unit.
@ -7731,7 +7731,8 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
/* For each component referenced in a component declaration create a GCC
field and add it to the list, skipping pragmas in the GNAT list. */
gnu_last = tree_last (gnu_field_list);
if (Present (Component_Items (gnat_component_list)))
if (Present (gnat_component_list)
&& (Present (Component_Items (gnat_component_list))))
for (gnat_component_decl
= First_Non_Pragma (Component_Items (gnat_component_list));
Present (gnat_component_decl);
@ -7788,7 +7789,10 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
}
/* At the end of the component list there may be a variant part. */
gnat_variant_part = Variant_Part (gnat_component_list);
if (Present (gnat_component_list))
gnat_variant_part = Variant_Part (gnat_component_list);
else
gnat_variant_part = Empty;
/* We create a QUAL_UNION_TYPE for the variant part since the variants are
mutually exclusive and should go in the same memory. To do this we need

30
gcc/ada/gcc-interface/gigi.h
View File

@ -233,24 +233,24 @@ extern "C" {
structures and then generates code. */
extern void gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name,
struct Node *nodes_ptr,
struct Flags *Flags_Ptr,
int number_name,
Field_Offset *node_offsets_ptr,
slot *Slots,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
struct Elist_Header *elists_ptr,
struct Elmt_Item *elmts_ptr,
struct String_Entry *strings_ptr,
Char_Code *strings_chars_ptr,
struct List_Header *list_headers_ptr,
Nat number_file,
struct File_Info_Type *file_info_ptr,
Entity_Id standard_boolean,
Entity_Id standard_integer,
Entity_Id standard_character,
Entity_Id standard_long_long_float,
Entity_Id standard_exception_type,
Int gigi_operating_mode);
struct Elmt_Item *elmts_ptr,
struct String_Entry *strings_ptr,
Char_Code *strings_chars_ptr,
struct List_Header *list_headers_ptr,
Nat number_file,
struct File_Info_Type *file_info_ptr,
Entity_Id standard_boolean,
Entity_Id standard_integer,
Entity_Id standard_character,
Entity_Id standard_long_long_float,
Entity_Id standard_exception_type,
Int gigi_operating_mode);
#ifdef __cplusplus
}

12
gcc/ada/gcc-interface/trans.c
View File

@ -75,8 +75,8 @@
#define ALLOCA_THRESHOLD 1000
/* Pointers to front-end tables accessed through macros. */
struct Node *Nodes_Ptr;
struct Flags *Flags_Ptr;
Field_Offset *Node_Offsets_Ptr;
slot *Slots_Ptr;
Node_Id *Next_Node_Ptr;
Node_Id *Prev_Node_Ptr;
struct Elist_Header *Elists_Ptr;
@ -279,8 +279,8 @@ void
gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name ATTRIBUTE_UNUSED,
struct Node *nodes_ptr,
struct Flags *flags_ptr,
Field_Offset *node_offsets_ptr,
slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
struct Elist_Header *elists_ptr,
@ -305,8 +305,8 @@ gigi (Node_Id gnat_root,
max_gnat_nodes = max_gnat_node;
Nodes_Ptr = nodes_ptr;
Flags_Ptr = flags_ptr;
Node_Offsets_Ptr = node_offsets_ptr;
Slots_Ptr = slots_ptr;
Next_Node_Ptr = next_node_ptr;
Prev_Node_Ptr = prev_node_ptr;
Elists_Ptr = elists_ptr;

923
gcc/ada/gen_il-fields.ads Normal file
View File

@ -0,0 +1,923 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L . F I E L D S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package Gen_IL.Fields is
-- The following is "optional field enumeration" -- i.e. it is Field_Enum
-- (declared in Gen_IL.Utils) plus the special null value No_Field.
-- See the spec of Gen_IL.Gen for how to modify this.
type Opt_Field_Enum is
(No_Field,
-- Start of node fields:
Nkind,
Sloc,
In_List,
Rewrite_Ins,
Comes_From_Source,
Analyzed,
Error_Posted,
Small_Paren_Count,
Check_Actuals,
Has_Aspects,
Is_Ignored_Ghost_Node,
Link,
Abort_Present,
Abortable_Part,
Abstract_Present,
Accept_Handler_Records,
Accept_Statement,
Access_Definition,
Access_To_Subprogram_Definition,
Access_Types_To_Process,
Actions,
Activation_Chain_Entity,
Acts_As_Spec,
Actual_Designated_Subtype,
Address_Warning_Posted,
Aggregate_Bounds,
Aliased_Present,
Alloc_For_BIP_Return,
All_Others,
All_Present,
Alternatives,
Ancestor_Part,
Atomic_Sync_Required,
Array_Aggregate,
Aspect_On_Partial_View,
Aspect_Rep_Item,
Assignment_OK,
Attribute_Name,
At_End_Proc,
Aux_Decls_Node,
Backwards_OK,
Bad_Is_Detected,
Body_Required,
Body_To_Inline,
Box_Present,
By_Ref,
Char_Literal_Value,
Chars,
Check_Address_Alignment,
Choice_Parameter,
Choices,
Class_Present,
Classifications,
Cleanup_Actions,
Comes_From_Extended_Return_Statement,
Compile_Time_Known_Aggregate,
Component_Associations,
Component_Clauses,
Component_Definition,
Component_Items,
Component_List,
Component_Name,
Componentwise_Assignment,
Condition,
Condition_Actions,
Config_Pragmas,
Constant_Present,
Constraint,
Constraints,
Context_Installed,
Context_Items,
Context_Pending,
Contract_Test_Cases,
Controlling_Argument,
Conversion_OK,
Convert_To_Return_False,
Corresponding_Aspect,
Corresponding_Body,
Corresponding_Formal_Spec,
Corresponding_Generic_Association,
Corresponding_Integer_Value,
Corresponding_Spec,
Corresponding_Spec_Of_Stub,
Corresponding_Stub,
Dcheck_Function,
Declarations,
Default_Expression,
Default_Storage_Pool,
Default_Name,
Defining_Identifier,
Defining_Unit_Name,
Delay_Alternative,
Delay_Statement,
Delta_Expression,
Digits_Expression,
Discr_Check_Funcs_Built,
Discrete_Choices,
Discrete_Range,
Discrete_Subtype_Definition,
Discrete_Subtype_Definitions,
Discriminant_Specifications,
Discriminant_Type,
Do_Accessibility_Check,
Do_Discriminant_Check,
Do_Division_Check,
Do_Length_Check,
Do_Overflow_Check,
Do_Range_Check,
Do_Storage_Check,
Do_Tag_Check,
Elaborate_All_Desirable,
Elaborate_All_Present,
Elaborate_Desirable,
Elaborate_Present,
Else_Actions,
Else_Statements,
Elsif_Parts,
Enclosing_Variant,
End_Label,
End_Span,
Entity_Or_Associated_Node,
Entry_Body_Formal_Part,
Entry_Call_Alternative,
Entry_Call_Statement,
Entry_Direct_Name,
Entry_Index,
Entry_Index_Specification,
Etype,
Exception_Choices,
Exception_Handlers,
Exception_Junk,
Exception_Label,
Expansion_Delayed,
Explicit_Actual_Parameter,
Explicit_Generic_Actual_Parameter,
Expression,
Expression_Copy,
Expressions,
First_Bit,
First_Inlined_Subprogram,
First_Name,
First_Named_Actual,
First_Real_Statement,
First_Subtype_Link,
Float_Truncate,
Formal_Type_Definition,
Forwards_OK,
From_Aspect_Specification,
From_At_End,
From_At_Mod,
From_Conditional_Expression,
From_Default,
Generalized_Indexing,
Generic_Associations,
Generic_Formal_Declarations,
Generic_Parent,
Generic_Parent_Type,
Handled_Statement_Sequence,
Handler_List_Entry,
Has_Created_Identifier,
Has_Dereference_Action,
Has_Dynamic_Length_Check,
Has_Init_Expression,
Has_Local_Raise,
Has_No_Elaboration_Code,
Has_Pragma_Suppress_All,
Has_Private_View,
Has_Relative_Deadline_Pragma,
Has_Self_Reference,
Has_SP_Choice,
Has_Storage_Size_Pragma,
Has_Target_Names,
Has_Wide_Character,
Has_Wide_Wide_Character,
Header_Size_Added,
Hidden_By_Use_Clause,
High_Bound,
Identifier,
Interface_List,
Interface_Present,
Implicit_With,
Import_Interface_Present,
In_Present,
Includes_Infinities,
Incomplete_View,
Inherited_Discriminant,
Instance_Spec,
Intval,
Is_Abort_Block,
Is_Accessibility_Actual,
Is_Analyzed_Pragma,
Is_Asynchronous_Call_Block,
Is_Boolean_Aspect,
Is_Checked,
Is_Checked_Ghost_Pragma,
Is_Component_Left_Opnd,
Is_Component_Right_Opnd,
Is_Controlling_Actual,
Is_Declaration_Level_Node,
Is_Delayed_Aspect,
Is_Disabled,
Is_Dispatching_Call,
Is_Dynamic_Coextension,
Is_Effective_Use_Clause,
Is_Elaboration_Checks_OK_Node,
Is_Elaboration_Code,
Is_Elaboration_Warnings_OK_Node,
Is_Elsif,
Is_Entry_Barrier_Function,
Is_Expanded_Build_In_Place_Call,
Is_Expanded_Contract,
Is_Finalization_Wrapper,
Is_Folded_In_Parser,
Is_Generic_Contract_Pragma,
Is_Homogeneous_Aggregate,
Is_Ignored,
Is_Ignored_Ghost_Pragma,
Is_In_Discriminant_Check,
Is_Inherited_Pragma,
Is_Initialization_Block,
Is_Known_Guaranteed_ABE,
Is_Machine_Number,
Is_Null_Loop,
Is_Overloaded,
Is_Power_Of_2_For_Shift,
Is_Preelaborable_Call,
Is_Prefixed_Call,
Is_Protected_Subprogram_Body,
Is_Qualified_Universal_Literal,
Is_Read,
Is_Source_Call,
Is_SPARK_Mode_On_Node,
Is_Static_Coextension,
Is_Static_Expression,
Is_Subprogram_Descriptor,
Is_Task_Allocation_Block,
Is_Task_Body_Procedure,
Is_Task_Master,
Is_Write,
Iterator_Filter,
Iteration_Scheme,
Iterator_Specification,
Itype,
Key_Expression,
Kill_Range_Check,
Last_Bit,
Last_Name,
Library_Unit,
Label_Construct,
Left_Opnd,
Limited_View_Installed,
Limited_Present,
Literals,
Local_Raise_Not_OK,
Local_Raise_Statements,
Loop_Actions,
Loop_Parameter_Specification,
Low_Bound,
Mod_Clause,
More_Ids,
Must_Be_Byte_Aligned,
Must_Not_Freeze,
Must_Not_Override,
Must_Override,
Name,
Names,
Next_Entity,
Next_Exit_Statement,
Next_Implicit_With,
Next_Named_Actual,
Next_Pragma,
Next_Rep_Item,
Next_Use_Clause,
No_Ctrl_Actions,
No_Elaboration_Check,
No_Entities_Ref_In_Spec,
No_Initialization,
No_Minimize_Eliminate,
No_Side_Effect_Removal,
No_Truncation,
Null_Excluding_Subtype,
Null_Exclusion_Present,
Null_Exclusion_In_Return_Present,
Null_Present,
Null_Record_Present,
Null_Statement,
Object_Definition,
Of_Present,
Original_Discriminant,
Original_Entity,
Others_Discrete_Choices,
Out_Present,
Parameter_Associations,
Parameter_Specifications,
Parameter_Type,
Parent_Spec,
Parent_With,
Position,
Pragma_Argument_Associations,
Pragma_Identifier,
Pragmas_After,
Pragmas_Before,
Pre_Post_Conditions,
Prefix,
Premature_Use,
Present_Expr,
Prev_Ids,
Prev_Use_Clause,
Print_In_Hex,
Private_Declarations,
Private_Present,
Procedure_To_Call,
Proper_Body,
Protected_Definition,
Protected_Present,
Raises_Constraint_Error,
Range_Constraint,
Range_Expression,
Real_Range_Specification,
Realval,
Reason,
Record_Extension_Part,
Redundant_Use,
Renaming_Exception,
Result_Definition,
Return_Object_Declarations,
Return_Statement_Entity,
Reverse_Present,
Right_Opnd,
Rounded_Result,
Save_Invocation_Graph_Of_Body,
SCIL_Controlling_Tag,
SCIL_Entity,
SCIL_Tag_Value,
SCIL_Target_Prim,
Scope,
Select_Alternatives,
Selector_Name,
Selector_Names,
Shift_Count_OK,
Source_Type,
Specification,
Split_PPC,
Statements,
Storage_Pool,
Subpool_Handle_Name,
Strval,
Subtype_Indication,
Subtype_Mark,
Subtype_Marks,
Suppress_Assignment_Checks,
Suppress_Loop_Warnings,
Synchronized_Present,
Tagged_Present,
Target,
Target_Type,
Task_Definition,
Task_Present,
Then_Actions,
Then_Statements,
Triggering_Alternative,
Triggering_Statement,
TSS_Elist,
Type_Definition,
Uneval_Old_Accept,
Uneval_Old_Warn,
Unit,
Unknown_Discriminants_Present,
Unreferenced_In_Spec,
Variant_Part,
Variants,
Visible_Declarations,
Uninitialized_Variable,
Used_Operations,
Was_Attribute_Reference,
Was_Expression_Function,
Was_Originally_Stub,
-- End of node fields.
Between_Node_And_Entity_Fields,
-- Start of entity fields:
Ekind,
Basic_Convention,
Abstract_States,
Accept_Address,
Access_Disp_Table,
Access_Disp_Table_Elab_Flag,
Access_Subprogram_Wrapper,
Activation_Record_Component,
Actual_Subtype,
Address_Taken,
-- ?? Alias,
Alignment,
Anonymous_Designated_Type,
Anonymous_Masters,
Anonymous_Object,
Associated_Entity,
Associated_Formal_Package,
Associated_Node_For_Itype,
Associated_Storage_Pool,
Barrier_Function,
BIP_Initialization_Call,
Block_Node,
Body_Entity,
Body_Needed_For_Inlining,
Body_Needed_For_SAL,
Body_References,
C_Pass_By_Copy,
Can_Never_Be_Null,
Can_Use_Internal_Rep,
Checks_May_Be_Suppressed,
Class_Wide_Clone,
Class_Wide_Type,
Cloned_Subtype,
Component_Alignment,
Component_Bit_Offset,
Component_Clause,
Component_Size,
Component_Type,
Contract,
Contract_Wrapper,
Corresponding_Concurrent_Type,
Corresponding_Discriminant,
Corresponding_Equality,
Corresponding_Function,
Corresponding_Procedure,
Corresponding_Protected_Entry,
Corresponding_Record_Component,
Corresponding_Record_Type,
Corresponding_Remote_Type,
CR_Discriminant,
Current_Use_Clause,
Current_Value,
Debug_Info_Off,
Debug_Renaming_Link,
Default_Aspect_Component_Value,
Default_Aspect_Value,
Default_Expr_Function,
Default_Expressions_Processed,
Default_Value,
Delay_Cleanups,
Delay_Subprogram_Descriptors,
Delta_Value,
Dependent_Instances,
Depends_On_Private,
Derived_Type_Link,
Digits_Value,
Predicated_Parent,
Predicates_Ignored,
Direct_Primitive_Operations,
Directly_Designated_Type,
Disable_Controlled,
Discard_Names,
Discriminal,
Discriminal_Link,
Discriminant_Checking_Func,
Discriminant_Constraint,
Discriminant_Default_Value,
Discriminant_Number,
Dispatch_Table_Wrappers,
DT_Entry_Count,
DT_Offset_To_Top_Func,
DT_Position,
DTC_Entity,
Elaborate_Body_Desirable,
Elaboration_Entity,
Elaboration_Entity_Required,
Encapsulating_State,
Enclosing_Scope,
Entry_Accepted,
Entry_Bodies_Array,
Entry_Cancel_Parameter,
Entry_Component,
Entry_Formal,
Entry_Index_Constant,
Entry_Max_Queue_Lengths_Array,
Entry_Parameters_Type,
Enum_Pos_To_Rep,
Enumeration_Pos,
Enumeration_Rep,
Enumeration_Rep_Expr,
Equivalent_Type,
Esize,
Extra_Accessibility,
Extra_Accessibility_Of_Result,
Extra_Constrained,
Extra_Formal,
Extra_Formals,
Finalization_Master,
Finalize_Storage_Only,
Finalizer,
First_Entity,
First_Exit_Statement,
First_Index,
First_Literal,
First_Private_Entity,
First_Rep_Item,
Float_Rep,
Freeze_Node,
From_Limited_With,
Full_View,
Generic_Homonym,
Generic_Renamings,
Handler_Records,
Has_Aliased_Components,
Has_Alignment_Clause,
Has_All_Calls_Remote,
Has_Atomic_Components,
Has_Biased_Representation,
Has_Completion,
Has_Completion_In_Body,
Has_Complex_Representation,
Has_Component_Size_Clause,
Has_Constrained_Partial_View,
Has_Contiguous_Rep,
Has_Controlled_Component,
Has_Controlling_Result,
Has_Convention_Pragma,
Has_Default_Aspect,
Has_Delayed_Aspects,
Has_Delayed_Freeze,
Has_Delayed_Rep_Aspects,
Has_Discriminants,
Has_Dispatch_Table,
Has_Dynamic_Predicate_Aspect,
Has_Enumeration_Rep_Clause,
Has_Exit,
Has_Expanded_Contract,
Has_Forward_Instantiation,
Has_Fully_Qualified_Name,
Has_Gigi_Rep_Item,
Has_Homonym,
Has_Implicit_Dereference,
Has_Independent_Components,
Has_Inheritable_Invariants,
Has_Inherited_DIC,
Has_Inherited_Invariants,
Has_Initial_Value,
Has_Loop_Entry_Attributes,
Has_Machine_Radix_Clause,
Has_Master_Entity,
Has_Missing_Return,
Has_Nested_Block_With_Handler,
Has_Nested_Subprogram,
Has_Non_Standard_Rep,
Has_Object_Size_Clause,
Has_Out_Or_In_Out_Parameter,
Has_Own_DIC,
Has_Own_Invariants,
Has_Partial_Visible_Refinement,
Has_Per_Object_Constraint,
Has_Pragma_Controlled,
Has_Pragma_Elaborate_Body,
Has_Pragma_Inline,
Has_Pragma_Inline_Always,
Has_Pragma_No_Inline,
Has_Pragma_Ordered,
Has_Pragma_Pack,
Has_Pragma_Preelab_Init,
Has_Pragma_Pure,
Has_Pragma_Pure_Function,
Has_Pragma_Thread_Local_Storage,
Has_Pragma_Unmodified,
Has_Pragma_Unreferenced,
Has_Pragma_Unreferenced_Objects,
Has_Pragma_Unused,
Has_Predicates,
Has_Primitive_Operations,
Has_Private_Ancestor,
Has_Private_Declaration,
Has_Private_Extension,
Has_Protected,
Has_Qualified_Name,
Has_RACW,
Has_Record_Rep_Clause,
Has_Recursive_Call,
Has_Shift_Operator,
Has_Size_Clause,
Has_Small_Clause,
Has_Specified_Layout,
Has_Specified_Stream_Input,
Has_Specified_Stream_Output,
Has_Specified_Stream_Read,
Has_Specified_Stream_Write,
Has_Static_Discriminants,
Has_Static_Predicate,
Has_Static_Predicate_Aspect,
Has_Storage_Size_Clause,
Has_Stream_Size_Clause,
Has_Task,
Has_Timing_Event,
Has_Thunks,
Has_Unchecked_Union,
Has_Unknown_Discriminants,
Has_Visible_Refinement,
Has_Volatile_Components,
Has_Xref_Entry,
Has_Yield_Aspect,
Hiding_Loop_Variable,
Hidden_In_Formal_Instance,
Homonym,
Ignore_SPARK_Mode_Pragmas,
Import_Pragma,
Incomplete_Actuals,
In_Package_Body,
In_Private_Part,
In_Use,
Initialization_Statements,
Inner_Instances,
Interface_Alias,
Interface_Name,
Interfaces,
Is_Abstract_Subprogram,
Is_Abstract_Type,
Is_Access_Constant,
Is_Activation_Record,
Is_Actual_Subtype,
Is_Ada_2005_Only,
Is_Ada_2012_Only,
Is_Aliased,
Is_Asynchronous,
Is_Atomic,
Is_Bit_Packed_Array,
Is_Called,
Is_Character_Type,
Is_Checked_Ghost_Entity,
Is_Child_Unit,
Is_Class_Wide_Clone,
Is_Class_Wide_Equivalent_Type,
Is_Compilation_Unit,
Is_Completely_Hidden,
Is_Concurrent_Record_Type,
Is_Constr_Subt_For_U_Nominal,
Is_Constr_Subt_For_UN_Aliased,
Is_Constrained,
Is_Constructor,
Is_Controlled_Active,
Is_Controlling_Formal,
Is_CPP_Class,
Is_CUDA_Kernel,
Is_Descendant_Of_Address,
Is_DIC_Procedure,
Is_Discrim_SO_Function,
Is_Discriminant_Check_Function,
Is_Dispatch_Table_Entity,
Is_Dispatching_Operation,
Is_Elaboration_Checks_OK_Id,
Is_Elaboration_Warnings_OK_Id,
Is_Eliminated,
Is_Entry_Formal,
Is_Entry_Wrapper,
Is_Exception_Handler,
Is_Exported,
Is_Finalized_Transient,
Is_First_Subtype,
Is_Formal_Subprogram,
Is_Frozen,
Is_Generic_Actual_Subprogram,
Is_Generic_Actual_Type,
Is_Generic_Instance,
Is_Generic_Type,
Is_Hidden,
Is_Hidden_Non_Overridden_Subpgm,
Is_Hidden_Open_Scope,
Is_Ignored_Ghost_Entity,
Is_Ignored_Transient,
Is_Immediately_Visible,
Is_Implementation_Defined,
Is_Imported,
Is_Independent,
Is_Initial_Condition_Procedure,
Is_Inlined,
Is_Inlined_Always,
Is_Instantiated,
Is_Interface,
Is_Internal,
Is_Interrupt_Handler,
Is_Intrinsic_Subprogram,
Is_Invariant_Procedure,
Is_Itype,
Is_Known_Non_Null,
Is_Known_Null,
Is_Known_Valid,
Is_Limited_Composite,
Is_Limited_Interface,
Is_Limited_Record,
Is_Local_Anonymous_Access,
Is_Loop_Parameter,
Is_Machine_Code_Subprogram,
Is_Non_Static_Subtype,
Is_Null_Init_Proc,
Is_Obsolescent,
Is_Only_Out_Parameter,
Is_Package_Body_Entity,
Is_Packed,
Is_Packed_Array_Impl_Type,
Is_Param_Block_Component_Type,
Is_Partial_Invariant_Procedure,
Is_Potentially_Use_Visible,
Is_Predicate_Function,
Is_Predicate_Function_M,
Is_Preelaborated,
Is_Primitive,
Is_Primitive_Wrapper,
Is_Private_Composite,
Is_Private_Descendant,
Is_Private_Primitive,
Is_Public,
Is_Pure,
Is_Pure_Unit_Access_Type,
Is_RACW_Stub_Type,
Is_Raised,
Is_Remote_Call_Interface,
Is_Remote_Types,
Is_Renaming_Of_Object,
Is_Return_Object,
Is_Safe_To_Reevaluate,
Is_Shared_Passive,
Is_Static_Type,
Is_Statically_Allocated,
Is_Tag,
Is_Tagged_Type,
Is_Thunk,
Is_Trivial_Subprogram,
Is_True_Constant,
Is_Unchecked_Union,
Is_Underlying_Full_View,
Is_Underlying_Record_View,
Is_Unimplemented,
Is_Unsigned_Type,
Is_Uplevel_Referenced_Entity,
Is_Valued_Procedure,
Is_Visible_Formal,
Is_Visible_Lib_Unit,
Is_Volatile_Type,
Is_Volatile_Object,
Is_Volatile_Full_Access,
Itype_Printed,
Kill_Elaboration_Checks,
Kill_Range_Checks,
Known_To_Have_Preelab_Init,
Last_Aggregate_Assignment,
Last_Assignment,
Last_Entity,
Limited_View,
Linker_Section_Pragma,
Lit_Hash,
Lit_Indexes,
Lit_Strings,
Low_Bound_Tested,
Machine_Radix_10,
Master_Id,
Materialize_Entity,
May_Inherit_Delayed_Rep_Aspects,
Mechanism,
Minimum_Accessibility,
Modulus,
Must_Be_On_Byte_Boundary,
Must_Have_Preelab_Init,
Needs_Activation_Record,
Needs_Debug_Info,
Needs_No_Actuals,
Never_Set_In_Source,
Next_Inlined_Subprogram,
No_Dynamic_Predicate_On_Actual,
No_Pool_Assigned,
No_Predicate_On_Actual,
No_Reordering,
No_Return,
No_Strict_Aliasing,
No_Tagged_Streams_Pragma,
Non_Binary_Modulus,
Non_Limited_View,
Nonzero_Is_True,
Normalized_First_Bit,
Normalized_Position,
Normalized_Position_Max,
OK_To_Rename,
Optimize_Alignment_Space,
Optimize_Alignment_Time,
Original_Access_Type,
Original_Array_Type,
Original_Protected_Subprogram,
Original_Record_Component,
Overlays_Constant,
Overridden_Operation,
Package_Instantiation,
Packed_Array_Impl_Type,
Parent_Subtype,
Part_Of_Constituents,
Part_Of_References,
Partial_View_Has_Unknown_Discr,
Pending_Access_Types,
Postconditions_Proc,
Prev_Entity,
Prival,
Prival_Link,
Private_Dependents,
Protected_Body_Subprogram,
Protected_Formal,
Protected_Subprogram,
Protection_Object,
Reachable,
Receiving_Entry,
Referenced,
Referenced_As_LHS,
Referenced_As_Out_Parameter,
Refinement_Constituents,
Register_Exception_Call,
Related_Array_Object,
Related_Expression,
Related_Instance,
Related_Type,
Relative_Deadline_Variable,
-- ??? Renamed_Entity,
Renamed_In_Spec,
-- ??? Renamed_Object,
Renamed_Or_Alias, -- ???Replaces Alias, Renamed_Entity, Renamed_Object
Renaming_Map,
Requires_Overriding,
Return_Applies_To,
Return_Present,
Returns_By_Ref,
Reverse_Bit_Order,
Reverse_Storage_Order,
Rewritten_For_C,
RM_Size,
Scalar_Range,
Scale_Value,
Scope_Depth_Value,
Sec_Stack_Needed_For_Return,
Shared_Var_Procs_Instance,
Size_Check_Code,
Size_Depends_On_Discriminant,
Size_Known_At_Compile_Time,
Small_Value,
SPARK_Aux_Pragma,
SPARK_Aux_Pragma_Inherited,
SPARK_Pragma,
SPARK_Pragma_Inherited,
Spec_Entity,
SSO_Set_High_By_Default,
SSO_Set_Low_By_Default,
Static_Discrete_Predicate,
Static_Elaboration_Desired,
Static_Initialization,
Static_Real_Or_String_Predicate,
Status_Flag_Or_Transient_Decl,
Storage_Size_Variable,
Stored_Constraint,
Stores_Attribute_Old_Prefix,
Strict_Alignment,
String_Literal_Length,
String_Literal_Low_Bound,
Subprograms_For_Type,
Subps_Index,
Suppress_Elaboration_Warnings,
Suppress_Initialization,
Suppress_Style_Checks,
Suppress_Value_Tracking_On_Call,
Task_Body_Procedure,
Thunk_Entity,
Treat_As_Volatile,
Underlying_Full_View,
Underlying_Record_View,
Universal_Aliasing,
Unset_Reference,
Used_As_Generic_Actual,
Uses_Lock_Free,
Uses_Sec_Stack,
Validated_Object,
Warnings_Off,
Warnings_Off_Used,
Warnings_Off_Used_Unmodified,
Warnings_Off_Used_Unreferenced,
Was_Default_Init_Box_Association,
Was_Hidden,
Wrapped_Entity
-- End of entity fields.
); -- Opt_Field_Enum
end Gen_IL.Fields;

1304
gcc/ada/gen_il-gen-gen_entities.adb Normal file
View File

File diff suppressed because it is too large Load Diff

1616
gcc/ada/gen_il-gen-gen_nodes.adb Normal file
View File

File diff suppressed because it is too large Load Diff

2974
gcc/ada/gen_il-gen.adb Normal file
View File

File diff suppressed because it is too large Load Diff

220
gcc/ada/gen_il-gen.ads Normal file
View File

@ -0,0 +1,220 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L . G E N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Gen_IL.Types; use Gen_IL.Types;
pragma Warnings (Off);
with Gen_IL.Fields; use Gen_IL.Fields; -- for children
pragma Warnings (On);
with Gen_IL.Utils; use Gen_IL.Utils;
use Gen_IL.Utils.Type_Vectors;
use Gen_IL.Utils.Field_Vectors;
package Gen_IL.Gen is
-- "Language design is library design and library design is language
-- design".
-- -- Bjarne Stroustrup
-- This package provides a "little language" for defining type hierarchies,
-- which we call "Gen_IL.Gen". In particular, it is used to describe the
-- type hierarchies rooted at Node_Id and Entity_Id in the intermediate
-- language used by GNAT.
-- The type hierarchy is a strict hierarchy (treeish, no multiple
-- inheritance). We have "abstract" and "concrete" types. Each type has a
-- "parent", except for the root type (Node_Id or Entity_Id). All leaf
-- types in the hierarchy are concrete; all nonleaf types (including the
-- two root types) are abstract. One can create instances of concrete, but
-- not abstract, types.
--
-- Descendants of Node_Id/Node_Kind are node types, and descendants of
-- Entity_Id/Entity_Kind are entity types.
--
-- Types have "fields". Each type inherits all the fields from its parent,
-- and may add new ones. A node field can be marked "syntactic"; entity
-- fields are never syntactic. A nonsyntactic field is "semantic".
--
-- If a field is syntactic, then the constructors in Nmake take a parameter
-- to initialize that field. In addition, the tree-traversal routines in
-- Atree (Traverse_Func and Traverse_Proc) traverse syntactic fields that
-- are of type Node_Id (or subtypes of Node_Id) or List_Id. Finally, (with
-- some exceptions documented in the body) the setter for a syntactic node
-- or list field "Set_F (N, Val)" will set the Parent of Val to N, unless
-- Val is Empty or Error[_List].
--
-- Note that the same field can be syntactic in some node types but
-- semantic in other node types. This is an added complexity that we might
-- want to eliminate someday. We shouldn't add any new such cases.
--
-- A "program" written in the Gen_IL.Gen language consists of calls to the
-- "Create_..." routines below, followed by a call to Compile, also below.
-- In order to understand what's going on, you need to look not only at the
-- Gen_IL.Gen "code", but at the output of the compiler -- at least, look
-- at the specs of Sinfo.Nodes and Einfo.Entities, because GNAT invokes
-- those directly. It's not like a normal language where you don't usually
-- have to look at the generated machine code.
--
-- Thus, the Gen_IL.Gen code is really Ada code, and when you run it as an
-- Ada program, it generates the above-mentioned files. The program is
-- somewhat unusual in that it has no input. Everything it needs to
-- generate code is embodied in it.
-- Why don't we just use a variant record, instead of inventing a wheel?
-- Or a hierarchy of tagged types?
--
-- The key feature that Ada's variant records and tagged types lack, and
-- that this little language has, is that if two types have a field with
-- the same name, then those are the same field, even though they weren't
-- inherited from a common ancestor. Such fields are required to have the
-- same type, the same default value, and the same extra precondition.
procedure Create_Root_Node_Type
(T : Abstract_Node;
Fields : Field_Sequence := No_Fields)
with Pre => T = Node_Kind;
procedure Create_Abstract_Node_Type
(T : Abstract_Node; Parent : Abstract_Type;
Fields : Field_Sequence := No_Fields);
procedure Create_Concrete_Node_Type
(T : Concrete_Node; Parent : Abstract_Type;
Fields : Field_Sequence := No_Fields);
procedure Create_Root_Entity_Type
(T : Abstract_Entity;
Fields : Field_Sequence := No_Fields)
with Pre => T = Entity_Kind;
procedure Create_Abstract_Entity_Type
(T : Abstract_Entity; Parent : Abstract_Type;
Fields : Field_Sequence := No_Fields);
procedure Create_Concrete_Entity_Type
(T : Concrete_Entity; Parent : Abstract_Type;
Fields : Field_Sequence := No_Fields);
function Create_Syntactic_Field
(Field : Node_Field;
Field_Type : Type_Enum;
Default_Value : Field_Default_Value := No_Default;
Pre : String := "") return Field_Desc;
function Create_Semantic_Field
(Field : Field_Enum;
Field_Type : Type_Enum;
Type_Only : Type_Only_Enum := No_Type_Only;
Pre : String := "") return Field_Desc;
-- Create_Syntactic_Field is used for syntactic fields of nodes. The order
-- of calls to Create_Syntactic_Field determines the order of the formal
-- parameters of the Make_... functions in Nmake.
--
-- Create_Semantic_Field is used for semantic fields of nodes, and all
-- fields of entities are considered semantic. The order of calls doesn't
-- make any difference.
--
-- Field_Type is the type of the field. Default_Value is the default value
-- for the parameter of the Make_... function in Nmake; this is effective
-- only for syntactic fields. Flag fields of syntactic nodes always have a
-- default value, which is False unless specified as Default_True. Pre is
-- an additional precondition for the field getter and setter, in addition
-- to the precondition that asserts that the type has that field.
--
-- If multiple calls to these occur for the same Field but different types,
-- the Field_Type and Pre must match. Default_Value should match for
-- syntactic fields. See the declaration of Type_Only_Enum for Type_Only.
--
-- (The matching Default_Value requirement is a simplification from the
-- earlier hand-written version.)
-- To add a new node or entity type, add it to the enumeration type in
-- Gen_IL.Types, taking care that it is in the approprate range
-- (Abstract_Node, Abstract_Entity, Concrete_Node, or Concrete_Entity).
-- Then add a call to one of the above type-creation procedures to
-- Sinfo.Nodes or Einfo.Entities.
--
-- To add a new field to a type, add a call to one of the above field
-- creation procedures to Sinfo.Nodes or Einfo.Entities.
-- Forward references are not allowed. So if you say:
--
-- Create..._Type (..., Parent => P);
--
-- then Create..._Type must have already been called to create P.
--
-- Likewise, if you say:
--
-- Create..._Field (T, F, Field_Type, ...);
--
-- then Create..._Type must have already been called to create T and
-- (if it's a node or entity type) to create Field_Type.
--
-- To delete a node or entity type, delete it from Gen_IL.Types, update the
-- subranges in Gen_IL.Utils if necessary, and delete all occurrences from
-- Gen_IL.Gen.Gen_Entities. To delete a field, delete it from
-- Gen_IL.Fields, and delete all occurrences from Gen_IL.Gen.Gen_Entities.
-- If a field is not set, it is initialized by default to whatever value is
-- represented by all-zero bits, with two exceptions: Elist fields default
-- to No_Elist, and Uint fields default to Uint_0. In retrospect, it would
-- have been better to use No_Uint instead of Uint_0.
procedure Create_Node_Union (T : Abstract_Node; Children : Type_Array);
procedure Create_Entity_Union (T : Abstract_Entity; Children : Type_Array);
-- Create a "union" type that is the union of the Children. This is used
-- for nonhierachical types. This is the opposite of the normal "object
-- oriented" routines above, which create child types based on existing
-- parents. Here we are creating parent types based on existing child
-- types. A union type is considered to be an abstract type because it has
-- multiple children. We do not allow union types to have their own fields,
-- because that would introduce the well-known complexity of multiple
-- inheritance. That restriction could be relaxed, but for now, union types
-- are mainly for allowing things like "Pre => X in Some_Union_Type".
Illegal : exception;
-- Exception raised when Gen_IL code (in particular in Gen_Nodes and
-- Gen_Entities) is illegal. We don't try elaborate error recovery, but
-- hopefully the exception message will indicate what's wrong. You might
-- have to go in the debugger to see which line it's complaining about.
procedure Compile;
private
function Sy
(Field : Node_Field;
Field_Type : Type_Enum;
Default_Value : Field_Default_Value := No_Default;
Pre : String := "") return Field_Sequence;
function Sm
(Field : Field_Enum;
Field_Type : Type_Enum;
Type_Only : Type_Only_Enum := No_Type_Only;
Pre : String := "") return Field_Sequence;
-- The above functions return Field_Sequence. This is a trick to get around
-- the fact that Ada doesn't allow singleton positional aggregates. It
-- allows us to write things like:
--
-- Cc (N_Empty, Node_Kind,
-- (Sy (Chars, Name_Id, Default_No_Name)));
--
-- where that thing pretending to be an aggregate is really a parenthesized
-- expression.
end Gen_IL.Gen;

34
gcc/ada/gen_il-main.adb Normal file
View File

@ -0,0 +1,34 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Gen_IL.Gen.Gen_Nodes;
with Gen_IL.Gen.Gen_Entities;
procedure Gen_IL.Main is
begin
Gen_IL.Gen.Gen_Nodes;
Gen_IL.Gen.Gen_Entities;
Gen_IL.Gen.Compile;
end Gen_IL.Main;

496
gcc/ada/gen_il-types.ads Normal file
View File

@ -0,0 +1,496 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L . T Y P E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package Gen_IL.Types is
-- Enumeration of all the types that are "of interest". We have an
-- enumeration literal here for every node kind, every entity kind,
-- andevery type that can be the type of a field.
-- The "Between_..." literals below are simply for making subranges.
-- When adding literals to this enumeration type, be sure to put them
-- in the right place so they end up in the appropriate subranges in
-- Gen_IL.Utils (Abstract_Node, Abstract_Entity, Concrete_Node,
-- Concrete_Entity).
-- The following is "optional type enumeration" -- i.e. it is Type_Enum
-- (declared in Gen_IL.Utils) plus the special null value No_Type.
-- See the spec of Gen_IL.Gen for how to modify this.
type Opt_Type_Enum is
(No_Type,
Flag,
-- We use Flag for Boolean, so we don't conflict with
-- Standard.Boolean.
Node_Id,
List_Id,
Elist_Id,
Name_Id,
String_Id,
Uint,
Ureal,
Nkind_Type, -- Type of result of Nkind function, i.e. Node_Kind
Ekind_Type, -- Type of result of Ekind function, i.e. Entity_Kind
Source_Ptr,
Small_Paren_Count_Type,
Union_Id,
Convention_Id,
Component_Alignment_Kind,
Float_Rep_Kind,
Mechanism_Type,
Between_Special_And_Abstract_Node_Types,
-- Abstract node types:
Node_Kind, -- root of node type hierarchy
N_Access_To_Subprogram_Definition,
N_Array_Type_Definition,
N_Binary_Op,
N_Body_Stub,
N_Declaration,
N_Delay_Statement,
N_Direct_Name,
N_Entity,
N_Formal_Subprogram_Declaration,
N_Generic_Declaration,
N_Generic_Instantiation,
N_Generic_Renaming_Declaration,
N_Has_Chars,
N_Has_Entity,
N_Has_Etype,
N_Multiplying_Operator,
N_Later_Decl_Item,
N_Membership_Test,
N_Numeric_Or_String_Literal,
N_Op,
N_Op_Boolean,
N_Op_Compare,
N_Op_Shift,
N_Proper_Body,
N_Push_xxx_Label,
N_Pop_xxx_Label,
N_Push_Pop_xxx_Label,
N_Raise_xxx_Error,
N_Renaming_Declaration,
N_Representation_Clause,
N_Short_Circuit,
N_SCIL_Node,
N_Statement_Other_Than_Procedure_Call,
N_Subprogram_Call,
N_Subprogram_Instantiation,
N_Has_Condition,
N_Subexpr,
N_Subprogram_Specification,
N_Unary_Op,
N_Unit_Body,
-- End of abstract node types.
Between_Abstract_Node_And_Abstract_Entity_Types,
-- Abstract entity types:
Entity_Kind, -- root of entity type hierarchy
Access_Kind,
Access_Subprogram_Kind,
Access_Protected_Kind,
Aggregate_Kind,
Anonymous_Access_Kind,
Array_Kind,
Assignable_Kind,
Class_Wide_Kind,
Composite_Kind,
Concurrent_Kind,
Concurrent_Body_Kind,
Decimal_Fixed_Point_Kind,
Digits_Kind,
Discrete_Kind,
Discrete_Or_Fixed_Point_Kind,
Elementary_Kind,
Enumeration_Kind,
Entry_Kind,
Fixed_Point_Kind,
Float_Kind,
Formal_Kind,
Formal_Object_Kind,
Generic_Subprogram_Kind,
Generic_Unit_Kind,
Incomplete_Kind,
Incomplete_Or_Private_Kind,
Integer_Kind,
Modular_Integer_Kind,
Named_Kind,
Numeric_Kind,
Object_Kind,
Ordinary_Fixed_Point_Kind,
Overloadable_Kind,
Private_Kind,
Protected_Kind,
Real_Kind,
Record_Kind,
Scalar_Kind,
Subprogram_Kind,
Signed_Integer_Kind,
Task_Kind,
Type_Kind,
-- End of abstract entity types.
Between_Abstract_Entity_And_Concrete_Node_Types,
-- Concrete node types:
N_Unused_At_Start,
N_At_Clause,
N_Component_Clause,
N_Enumeration_Representation_Clause,
N_Mod_Clause,
N_Record_Representation_Clause,
N_Attribute_Definition_Clause,
N_Empty,
N_Pragma_Argument_Association,
N_Error,
N_Defining_Character_Literal,
N_Defining_Identifier,
N_Defining_Operator_Symbol,
N_Expanded_Name,
N_Identifier,
N_Operator_Symbol,
N_Character_Literal,
N_Op_Add,
N_Op_Concat,
N_Op_Expon,
N_Op_Subtract,
N_Op_Divide,
N_Op_Mod,
N_Op_Multiply,
N_Op_Rem,
N_Op_And,
N_Op_Eq,
N_Op_Ge,
N_Op_Gt,
N_Op_Le,
N_Op_Lt,
N_Op_Ne,
N_Op_Or,
N_Op_Xor,
N_Op_Rotate_Left,
N_Op_Rotate_Right,
N_Op_Shift_Left,
N_Op_Shift_Right,
N_Op_Shift_Right_Arithmetic,
N_Op_Abs,
N_Op_Minus,
N_Op_Not,
N_Op_Plus,
N_Attribute_Reference,
N_In,
N_Not_In,
N_And_Then,
N_Or_Else,
N_Function_Call,
N_Procedure_Call_Statement,
N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Storage_Error,
N_Integer_Literal,
N_Real_Literal,
N_String_Literal,
N_Explicit_Dereference,
N_Expression_With_Actions,
N_If_Expression,
N_Indexed_Component,
N_Null,
N_Qualified_Expression,
N_Quantified_Expression,
N_Aggregate,
N_Allocator,
N_Case_Expression,
N_Delta_Aggregate,
N_Extension_Aggregate,
N_Raise_Expression,
N_Range,
N_Reference,
N_Selected_Component,
N_Slice,
N_Target_Name,
N_Type_Conversion,
N_Unchecked_Expression,
N_Unchecked_Type_Conversion,
N_Subtype_Indication,
N_Component_Declaration,
N_Entry_Declaration,
N_Expression_Function,
N_Formal_Object_Declaration,
N_Formal_Type_Declaration,
N_Full_Type_Declaration,
N_Incomplete_Type_Declaration,
N_Iterator_Specification,
N_Loop_Parameter_Specification,
N_Object_Declaration,
N_Protected_Type_Declaration,
N_Private_Extension_Declaration,
N_Private_Type_Declaration,
N_Subtype_Declaration,
N_Function_Specification,
N_Procedure_Specification,
N_Access_Function_Definition,
N_Access_Procedure_Definition,
N_Task_Type_Declaration,
N_Package_Body_Stub,
N_Protected_Body_Stub,
N_Subprogram_Body_Stub,
N_Task_Body_Stub,
N_Function_Instantiation,
N_Procedure_Instantiation,
N_Package_Instantiation,
N_Package_Body,
N_Subprogram_Body,
N_Protected_Body,
N_Task_Body,
N_Implicit_Label_Declaration,
N_Package_Declaration,
N_Single_Task_Declaration,
N_Subprogram_Declaration,
N_Use_Package_Clause,
N_Generic_Package_Declaration,
N_Generic_Subprogram_Declaration,
N_Constrained_Array_Definition,
N_Unconstrained_Array_Definition,
N_Exception_Renaming_Declaration,
N_Object_Renaming_Declaration,
N_Package_Renaming_Declaration,
N_Subprogram_Renaming_Declaration,
N_Generic_Function_Renaming_Declaration,
N_Generic_Package_Renaming_Declaration,
N_Generic_Procedure_Renaming_Declaration,
N_Abort_Statement,
N_Accept_Statement,
N_Assignment_Statement,
N_Asynchronous_Select,
N_Block_Statement,
N_Case_Statement,
N_Code_Statement,
N_Compound_Statement,
N_Conditional_Entry_Call,
N_Delay_Relative_Statement,
N_Delay_Until_Statement,
N_Entry_Call_Statement,
N_Free_Statement,
N_Goto_Statement,
N_Loop_Statement,
N_Null_Statement,
N_Raise_Statement,
N_Requeue_Statement,
N_Simple_Return_Statement,
N_Extended_Return_Statement,
N_Selective_Accept,
N_Timed_Entry_Call,
N_Exit_Statement,
N_If_Statement,
N_Accept_Alternative,
N_Delay_Alternative,
N_Elsif_Part,
N_Entry_Body_Formal_Part,
N_Iteration_Scheme,
N_Terminate_Alternative,
N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Concrete_Subprogram_Declaration,
N_Push_Constraint_Error_Label,
N_Push_Program_Error_Label,
N_Push_Storage_Error_Label,
N_Pop_Constraint_Error_Label,
N_Pop_Program_Error_Label,
N_Pop_Storage_Error_Label,
N_SCIL_Dispatch_Table_Tag_Init,
N_SCIL_Dispatching_Call,
N_SCIL_Membership_Test,
N_Abortable_Part,
N_Abstract_Subprogram_Declaration,
N_Access_Definition,
N_Access_To_Object_Definition,
N_Aspect_Specification,
N_Call_Marker,
N_Case_Expression_Alternative,
N_Case_Statement_Alternative,
N_Compilation_Unit,
N_Compilation_Unit_Aux,
N_Component_Association,
N_Component_Definition,
N_Component_List,
N_Contract,
N_Derived_Type_Definition,
N_Decimal_Fixed_Point_Definition,
N_Defining_Program_Unit_Name,
N_Delta_Constraint,
N_Designator,
N_Digits_Constraint,
N_Discriminant_Association,
N_Discriminant_Specification,
N_Enumeration_Type_Definition,
N_Entry_Body,
N_Entry_Call_Alternative,
N_Entry_Index_Specification,
N_Exception_Declaration,
N_Exception_Handler,
N_Floating_Point_Definition,
N_Formal_Decimal_Fixed_Point_Definition,
N_Formal_Derived_Type_Definition,
N_Formal_Discrete_Type_Definition,
N_Formal_Floating_Point_Definition,
N_Formal_Modular_Type_Definition,
N_Formal_Ordinary_Fixed_Point_Definition,
N_Formal_Package_Declaration,
N_Formal_Private_Type_Definition,
N_Formal_Incomplete_Type_Definition,
N_Formal_Signed_Integer_Type_Definition,
N_Freeze_Entity,
N_Freeze_Generic_Entity,
N_Generic_Association,
N_Handled_Sequence_Of_Statements,
N_Index_Or_Discriminant_Constraint,
N_Iterated_Component_Association,
N_Iterated_Element_Association,
N_Itype_Reference,
N_Label,
N_Modular_Type_Definition,
N_Number_Declaration,
N_Ordinary_Fixed_Point_Definition,
N_Others_Choice,
N_Package_Specification,
N_Parameter_Association,
N_Parameter_Specification,
N_Pragma,
N_Protected_Definition,
N_Range_Constraint,
N_Real_Range_Specification,
N_Record_Definition,
N_Signed_Integer_Type_Definition,
N_Single_Protected_Declaration,
N_Subunit,
N_Task_Definition,
N_Triggering_Alternative,
N_Use_Type_Clause,
N_Validate_Unchecked_Conversion,
N_Variable_Reference_Marker,
N_Variant,
N_Variant_Part,
N_With_Clause,
N_Unused_At_End,
-- End of concrete node types.
Between_Concrete_Node_And_Concrete_Entity_Types,
-- Concrete entity types:
E_Void,
E_Component,
E_Constant,
E_Discriminant,
E_Loop_Parameter,
E_Variable,
E_Out_Parameter,
E_In_Out_Parameter,
E_In_Parameter,
E_Generic_In_Out_Parameter,
E_Generic_In_Parameter,
E_Named_Integer,
E_Named_Real,
E_Enumeration_Type,
E_Enumeration_Subtype,
E_Signed_Integer_Type,
E_Signed_Integer_Subtype,
E_Modular_Integer_Type,
E_Modular_Integer_Subtype,
E_Ordinary_Fixed_Point_Type,
E_Ordinary_Fixed_Point_Subtype,
E_Decimal_Fixed_Point_Type,
E_Decimal_Fixed_Point_Subtype,
E_Floating_Point_Type,
E_Floating_Point_Subtype,
E_Access_Type,
E_Access_Subtype,
E_Access_Attribute_Type,
E_Allocator_Type,
E_General_Access_Type,
E_Access_Subprogram_Type,
E_Access_Protected_Subprogram_Type,
E_Anonymous_Access_Protected_Subprogram_Type,
E_Anonymous_Access_Subprogram_Type,
E_Anonymous_Access_Type,
E_Array_Type,
E_Array_Subtype,
E_String_Literal_Subtype,
E_Class_Wide_Type,
E_Class_Wide_Subtype,
E_Record_Type,
E_Record_Subtype,
E_Record_Type_With_Private,
E_Record_Subtype_With_Private,
E_Private_Type,
E_Private_Subtype,
E_Limited_Private_Type,
E_Limited_Private_Subtype,
E_Incomplete_Type,
E_Incomplete_Subtype,
E_Task_Type,
E_Task_Subtype,
E_Protected_Type,
E_Protected_Subtype,
E_Exception_Type,
E_Subprogram_Type,
E_Enumeration_Literal,
E_Function,
E_Operator,
E_Procedure,
E_Abstract_State,
E_Entry,
E_Entry_Family,
E_Block,
E_Entry_Index_Parameter,
E_Exception,
E_Generic_Function,
E_Generic_Procedure,
E_Generic_Package,
E_Label,
E_Loop,
E_Return_Statement,
E_Package,
E_Package_Body,
E_Protected_Body,
E_Task_Body,
E_Subprogram_Body
-- End of concrete entity types.
); -- Type_Enum
end Gen_IL.Types;

453
gcc/ada/gen_il-utils.adb Normal file
View File

@ -0,0 +1,453 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L . U T I L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Gen_IL.Utils is
procedure Nil (T : Node_Or_Entity_Type) is
begin
null;
end Nil;
function Node_Or_Entity (Root : Root_Type) return String is
begin
if Root = Node_Kind then
return "Node";
else
return "Entity";
end if;
end Node_Or_Entity;
function Num_Concrete_Descendants
(T : Node_Or_Entity_Type) return Natural is
begin
return Concrete_Type'Pos (Type_Table (T).Last) -
Concrete_Type'Pos (Type_Table (T).First) + 1;
end Num_Concrete_Descendants;
function First_Abstract (Root : Root_Type) return Abstract_Type is
(case Root is
when Node_Kind => Abstract_Node'First,
when others => Abstract_Entity'First); -- Entity_Kind
function Last_Abstract (Root : Root_Type) return Abstract_Type is
(case Root is
when Node_Kind => Abstract_Node'Last,
when others => Abstract_Entity'Last); -- Entity_Kind
function First_Concrete (Root : Root_Type) return Concrete_Type is
(case Root is
when Node_Kind => Concrete_Node'First,
when others => Concrete_Entity'First); -- Entity_Kind
function Last_Concrete (Root : Root_Type) return Concrete_Type is
(case Root is
when Node_Kind => Concrete_Node'Last,
when others => Concrete_Entity'Last); -- Entity_Kind
function First_Field (Root : Root_Type) return Field_Enum is
(case Root is
when Node_Kind => Node_Field'First,
when others => Entity_Field'First); -- Entity_Kind
function Last_Field (Root : Root_Type) return Field_Enum is
(case Root is
when Node_Kind => Node_Field'Last,
when others => Entity_Field'Last); -- Entity_Kind
-- First and Last node or entity fields
procedure Verify_Type_Table is
begin
for T in Node_Or_Entity_Type loop
if Type_Table (T) /= null then
if not Type_Table (T).Is_Union then
case T is
when Concrete_Node | Concrete_Entity =>
pragma Assert (Type_Table (T).First = T);
pragma Assert (Type_Table (T).Last = T);
when Abstract_Node | Abstract_Entity =>
pragma Assert
(Type_Table (T).First < Type_Table (T).Last);
when Boundaries =>
null;
end case;
end if;
end if;
end loop;
end Verify_Type_Table;
function Id_Image (T : Type_Enum) return String is
begin
case T is
when Flag =>
return "Boolean";
when Node_Kind =>
return "Node_Id";
when Entity_Kind =>
return "Entity_Id";
when Nkind_Type =>
return "Node_Kind";
when Ekind_Type =>
return "Entity_Kind";
when others =>
return Image (T) & "_Id";
end case;
end Id_Image;
function Get_Set_Id_Image (T : Type_Enum) return String is
begin
case T is
when Node_Kind =>
return "Node_Id";
when Entity_Kind =>
return "Entity_Id";
when Nkind_Type =>
return "Node_Kind";
when Ekind_Type =>
return "Entity_Kind";
when others =>
return Image (T);
end case;
end Get_Set_Id_Image;
function Image (T : Opt_Type_Enum) return String is
begin
case T is
-- We special case the following; otherwise the compiler will give
-- "wrong case" warnings in compiler code.
when N_Pop_xxx_Label =>
return "N_Pop_xxx_Label";
when N_Push_Pop_xxx_Label =>
return "N_Push_Pop_xxx_Label";
when N_Push_xxx_Label =>
return "N_Push_xxx_Label";
when N_Raise_xxx_Error =>
return "N_Raise_xxx_Error";
when N_SCIL_Node =>
return "N_SCIL_Node";
when N_SCIL_Dispatch_Table_Tag_Init =>
return "N_SCIL_Dispatch_Table_Tag_Init";
when N_SCIL_Dispatching_Call =>
return "N_SCIL_Dispatching_Call";
when N_SCIL_Membership_Test =>
return "N_SCIL_Membership_Test";
when others =>
return Capitalize (T'Img);
end case;
end Image;
function Image_Sans_N (T : Opt_Type_Enum) return String is
Im : constant String := Image (T);
pragma Assert (Im (1 .. 2) = "N_");
begin
return Im (3 .. Im'Last);
end Image_Sans_N;
procedure Put_Images (S : in out Sink'Class; U : Type_Vector) is
First_Time : Boolean := True;
begin
Indent (S, 3);
for T of U loop
if First_Time then
First_Time := False;
else
Put (S, "\n| ");
end if;
Put (S, "\1", Image (T));
end loop;
Outdent (S, 3);
end Put_Images;
procedure Put_Id_Images (S : in out Sink'Class; U : Type_Vector) is
First_Time : Boolean := True;
begin
Indent (S, 3);
for T of U loop
if First_Time then
First_Time := False;
else
Put (S, "\n| ");
end if;
Put (S, "\1", Id_Image (T));
end loop;
Outdent (S, 3);
end Put_Id_Images;
function Image (F : Opt_Field_Enum) return String is
begin
case F is
-- Special cases for the same reason as in the above Image
-- function.
when Alloc_For_BIP_Return =>
return "Alloc_For_BIP_Return";
when Assignment_OK =>
return "Assignment_OK";
when Backwards_OK =>
return "Backwards_OK";
when BIP_Initialization_Call =>
return "BIP_Initialization_Call";
when Body_Needed_For_SAL =>
return "Body_Needed_For_SAL";
when Conversion_OK =>
return "Conversion_OK";
when CR_Discriminant =>
return "CR_Discriminant";
when DTC_Entity =>
return "DTC_Entity";
when DT_Entry_Count =>
return "DT_Entry_Count";
when DT_Offset_To_Top_Func =>
return "DT_Offset_To_Top_Func";
when DT_Position =>
return "DT_Position";
when Forwards_OK =>
return "Forwards_OK";
when Has_Inherited_DIC =>
return "Has_Inherited_DIC";
when Has_Own_DIC =>
return "Has_Own_DIC";
when Has_RACW =>
return "Has_RACW";
when Has_SP_Choice =>
return "Has_SP_Choice";
when Ignore_SPARK_Mode_Pragmas =>
return "Ignore_SPARK_Mode_Pragmas";
when Is_Constr_Subt_For_UN_Aliased =>
return "Is_Constr_Subt_For_UN_Aliased";
when Is_CPP_Class =>
return "Is_CPP_Class";
when Is_CUDA_Kernel =>
return "Is_CUDA_Kernel";
when Is_DIC_Procedure =>
return "Is_DIC_Procedure";
when Is_Discrim_SO_Function =>
return "Is_Discrim_SO_Function";
when Is_Elaboration_Checks_OK_Id =>
return "Is_Elaboration_Checks_OK_Id";
when Is_Elaboration_Checks_OK_Node =>
return "Is_Elaboration_Checks_OK_Node";
when Is_Elaboration_Warnings_OK_Id =>
return "Is_Elaboration_Warnings_OK_Id";
when Is_Elaboration_Warnings_OK_Node =>
return "Is_Elaboration_Warnings_OK_Node";
when Is_Known_Guaranteed_ABE =>
return "Is_Known_Guaranteed_ABE";
when Is_RACW_Stub_Type =>
return "Is_RACW_Stub_Type";
when Is_SPARK_Mode_On_Node =>
return "Is_SPARK_Mode_On_Node";
when Local_Raise_Not_OK =>
return "Local_Raise_Not_OK";
when OK_To_Rename =>
return "OK_To_Rename";
when Referenced_As_LHS =>
return "Referenced_As_LHS";
when RM_Size =>
return "RM_Size";
when SCIL_Controlling_Tag =>
return "SCIL_Controlling_Tag";
when SCIL_Entity =>
return "SCIL_Entity";
when SCIL_Tag_Value =>
return "SCIL_Tag_Value";
when SCIL_Target_Prim =>
return "SCIL_Target_Prim";
when Shift_Count_OK =>
return "Shift_Count_OK";
when SPARK_Aux_Pragma =>
return "SPARK_Aux_Pragma";
when SPARK_Aux_Pragma_Inherited =>
return "SPARK_Aux_Pragma_Inherited";
when SPARK_Pragma =>
return "SPARK_Pragma";
when SPARK_Pragma_Inherited =>
return "SPARK_Pragma_Inherited";
when Split_PPC =>
return "Split_PPC";
when SSO_Set_High_By_Default =>
return "SSO_Set_High_By_Default";
when SSO_Set_Low_By_Default =>
return "SSO_Set_Low_By_Default";
when TSS_Elist =>
return "TSS_Elist";
when others =>
return Capitalize (F'Img);
end case;
end Image;
function Image (Default : Field_Default_Value) return String is
(Capitalize (Default'Img));
function Value_Image (Default : Field_Default_Value) return String is
begin
if Default = No_Default then
return Image (Default);
else
-- Strip off the prefix and capitalize it
declare
Im : constant String := Image (Default);
Prefix : constant String := "Default_";
begin
pragma Assert (Im (1 .. Prefix'Length) = Prefix);
return Im (Prefix'Length + 1 .. Im'Last);
end;
end if;
end Value_Image;
procedure Iterate_Types
(Root : Node_Or_Entity_Type;
Pre, Post : not null access procedure (T : Node_Or_Entity_Type) :=
Nil'Access)
is
procedure Recursive (T : Node_Or_Entity_Type);
-- Recursive walk
procedure Recursive (T : Node_Or_Entity_Type) is
begin
Pre (T);
for Child of Type_Table (T).Children loop
Recursive (Child);
end loop;
Post (T);
end Recursive;
begin
Recursive (Root);
end Iterate_Types;
function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type)
return Boolean is
begin
if Ancestor = Descendant then
return True;
elsif Descendant in Root_Type then
return False;
else
return Is_Descendant (Ancestor, Type_Table (Descendant).Parent);
end if;
end Is_Descendant;
procedure Put_Type_Hierarchy (S : in out Sink'Class; Root : Root_Type) is
Level : Natural := 0;
function Indentation return String is ((1 .. 3 * Level => ' '));
-- Indentation string of space characters. We can't use the Indent
-- primitive, because we want this indentation after the "--".
procedure Pre (T : Node_Or_Entity_Type);
procedure Post (T : Node_Or_Entity_Type);
-- Pre and Post actions passed to Iterate_Types
procedure Pre (T : Node_Or_Entity_Type) is
begin
if not Type_Table (T).Allow_Overlap then
Put (S, "-- \1\2\n", Indentation, Image (T));
end if;
Level := Level + 1;
end Pre;
procedure Post (T : Node_Or_Entity_Type) is
begin
Level := Level - 1;
if not Type_Table (T).Allow_Overlap then
-- Put out an "end" line only if there are many descendants, for
-- an arbitrary definition of "many".
if Num_Concrete_Descendants (T) > 10 then
Put (S, "-- \1end \2\n", Indentation, Image (T));
end if;
end if;
end Post;
N_Or_E : constant String :=
(case Root is
when Node_Kind => "nodes",
when others => "entities"); -- Entity_Kind
begin
Put (S, "-- Type hierarchy for \1\n", N_Or_E);
Put (S, "--\n");
Iterate_Types (Root, Pre'Access, Post'Access);
Put (S, "--\n");
Put (S, "-- End type hierarchy for \1\n\n", N_Or_E);
end Put_Type_Hierarchy;
function Pos (T : Concrete_Type) return Root_Nat is
First : constant Concrete_Type :=
(if T in Concrete_Node then Concrete_Node'First
else Concrete_Entity'First);
begin
return Type_Enum'Pos (T) - Type_Enum'Pos (First);
end Pos;
Stdout : Sink'Class renames Files.Standard_Output.all;
-- The following procedures are for use in gdb. They use the 'Put_Image
-- attribute. That is commented out, because we don't want this new feature
-- used in the compiler. If you need this for debugging, just uncomment
-- those lines back in, and rebuild.
pragma Warnings (Off);
procedure Ptypes (V : Type_Vector) is
begin
-- Type_Vector'Put_Image (Stdout, V);
New_Line (Stdout);
Flush (Stdout);
end Ptypes;
procedure Pfields (V : Field_Vector) is
begin
-- Field_Vector'Put_Image (Stdout, V);
New_Line (Stdout);
Flush (Stdout);
end Pfields;
pragma Warnings (On);
end Gen_IL.Utils;

558
gcc/ada/gen_il-utils.ads Normal file
View File

@ -0,0 +1,558 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L . U T I L S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Containers.Vectors; use Ada.Containers;
with Gen_IL.Types; use Gen_IL.Types;
with Gen_IL.Fields; use Gen_IL.Fields;
package Gen_IL.Utils is
subtype Type_Enum is Opt_Type_Enum
range Opt_Type_Enum'Succ (No_Type) .. Opt_Type_Enum'Last;
-- Enumeration of types -- Opt_Type_Enum without the special null value
-- No_Type.
subtype Node_Or_Entity_Type is
Type_Enum range
Type_Enum'Succ (Between_Special_And_Abstract_Node_Types) ..
Type_Enum'Last;
subtype Abstract_Type is
Type_Enum range
Type_Enum'Succ (Between_Special_And_Abstract_Node_Types) ..
Type_Enum'Pred (Between_Abstract_Entity_And_Concrete_Node_Types);
subtype Abstract_Node is
Abstract_Type range
Type_Enum'Succ (Between_Special_And_Abstract_Node_Types) ..
Type_Enum'Pred (Between_Abstract_Node_And_Abstract_Entity_Types);
subtype Abstract_Entity is
Abstract_Type range
Type_Enum'Succ (Between_Abstract_Node_And_Abstract_Entity_Types) ..
Type_Enum'Pred (Between_Abstract_Entity_And_Concrete_Node_Types);
subtype Concrete_Type is
Type_Enum range
Type_Enum'Succ (Between_Abstract_Entity_And_Concrete_Node_Types) ..
Type_Enum'Last;
subtype Concrete_Node is
Concrete_Type range
Type_Enum'Succ (Between_Abstract_Entity_And_Concrete_Node_Types) ..
Type_Enum'Pred (Between_Concrete_Node_And_Concrete_Entity_Types);
subtype Concrete_Entity is
Concrete_Type range
Type_Enum'Succ (Between_Concrete_Node_And_Concrete_Entity_Types) ..
Type_Enum'Last;
subtype Root_Type is Abstract_Type with
Predicate => Root_Type in Node_Kind | Entity_Kind;
subtype Node_Type is Node_Or_Entity_Type with
Predicate => Node_Type in Abstract_Node | Concrete_Node;
subtype Entity_Type is Node_Or_Entity_Type with
Predicate => Entity_Type in Abstract_Entity | Concrete_Entity;
subtype Special_Type is Type_Enum range
Flag .. Type_Enum'Pred (Between_Special_And_Abstract_Node_Types);
subtype Traversal_Type is Type_Enum with Predicate =>
Traversal_Type in Node_Id | List_Id | Node_Type;
-- These are the types of fields traversed by Traverse_Func
subtype Entity_Node is Node_Type with
Predicate => Entity_Node in
N_Defining_Character_Literal
| N_Defining_Identifier
| N_Defining_Operator_Symbol;
function Image (T : Opt_Type_Enum) return String;
function Image_Sans_N (T : Opt_Type_Enum) return String;
-- Returns the image without the leading "N_"
subtype Boundaries is Type_Enum with
Predicate => Boundaries in
Between_Abstract_Node_And_Abstract_Entity_Types |
Between_Abstract_Entity_And_Concrete_Node_Types |
Between_Concrete_Node_And_Concrete_Entity_Types;
----------------
type Type_Set is array (Type_Enum) of Boolean;
type Type_Index is new Positive;
subtype Type_Count is Type_Index'Base range 0 .. Type_Index'Last;
package Type_Vectors is new Vectors (Type_Index, Type_Enum);
use Type_Vectors;
subtype Type_Vector is Type_Vectors.Vector;
procedure Ptypes (V : Type_Vector); -- for debugging
type Type_Array is array (Type_Index range <>) of Type_Enum;
subtype Field_Enum is Opt_Field_Enum
range Opt_Field_Enum'Succ (No_Field) .. Opt_Field_Enum'Last;
-- Enumeration of fields -- Opt_Field_Enum without the special null value
-- No_Field.
subtype Node_Header_Type is Type_Enum range
Nkind_Type .. Union_Id;
subtype Node_Header_Field is Field_Enum with Predicate =>
Node_Header_Field in Nkind .. Link | Ekind;
type Fields_Present_Array is array (Field_Enum) of Type_Set;
type Field_Set is array (Field_Enum) of Boolean;
type Fields_Per_Node_Type is array (Node_Or_Entity_Type) of Field_Set;
type Field_Index is new Positive;
subtype Field_Count is Field_Index'Base range 0 .. Field_Index'Last;
package Field_Vectors is new Vectors (Field_Index, Field_Enum);
subtype Field_Vector is Field_Vectors.Vector;
procedure Pfields (V : Field_Vector); -- for debugging
subtype Opt_Abstract_Type is Opt_Type_Enum with
Predicate => Opt_Abstract_Type = No_Type or
Opt_Abstract_Type in Abstract_Type;
procedure Put_Images (S : in out Sink'Class; U : Type_Vector);
procedure Put_Id_Images (S : in out Sink'Class; U : Type_Vector);
-- Put the types with vertical bars in between, as in
-- N_This | N_That | N_Other
-- or
-- N_This_Id | N_That_Id | N_Other_Id
function Id_Image (T : Type_Enum) return String;
function Get_Set_Id_Image (T : Type_Enum) return String;
type Bit_Offset is new Root_Nat range 0 .. 32_000 - 1;
-- There are fewer than 1000 fields. But offsets are in size units (1 bit
-- for flags, 32 bits for most others, also 2, 4, and 8).
type Field_Offset is new Bit_Offset;
type Type_Info (Is_Union : Boolean) is record
Parent : Opt_Abstract_Type;
-- Parent of this type (single inheritance). No_Type for a root
-- type (Node_Kind or Entity_Kind). For union types, this is
-- a root type.
Children : Type_Vector;
-- Inverse of Parent
Concrete_Descendants : Type_Vector;
case Is_Union is
when True =>
null;
when False =>
First, Last : Concrete_Type;
-- This type includes concrete types in the range First..Last. For
-- a concrete type, First=Last. For an abstract type, First..Last
-- includes two or more types.
Fields : Field_Vector;
Allow_Overlap : Boolean;
-- True to allow overlapping subranges
end case;
end record;
type Type_Info_Ptr is access all Type_Info;
Type_Table : array (Node_Or_Entity_Type) of Type_Info_Ptr;
-- Table mapping from enumeration literals representing types to
-- information about the type.
function Num_Concrete_Descendants
(T : Node_Or_Entity_Type) return Natural;
-- Number of concrete descendants of T, including (if T is concrete)
-- itself.
type Field_Default_Value is
(No_Default,
Default_Empty, -- Node_Id
Default_No_List, Default_Empty_List, -- List_Id
Default_False, Default_True, -- Flag
Default_No_Elist, -- Elist_Id
Default_No_Name, -- Name_Id
Default_Uint_0); -- Uint
-- Default value for a field in the Nmake functions. No_Default if the
-- field parameter has no default value. Otherwise this indicates the
-- default value used, which must matcht the type of the field.
type Type_Only_Enum is
(No_Type_Only, Base_Type_Only, Impl_Base_Type_Only, Root_Type_Only);
-- ????These correspond to the "[base type only]", "[implementation base
-- type only]", and "[root type only]" annotations in the old einfo.ads.
-- Move the relevant comments here. There is no comment explaining
-- [root type only] in the old einfo.ads.
function Image (Default : Field_Default_Value) return String;
function Value_Image (Default : Field_Default_Value) return String;
type Field_Info is record
Have_This_Field : Type_Vector;
Field_Type : Type_Enum;
-- Type of the field. Currently, we use Node_Id for all node-valued
-- fields, but we could narrow down to children of that. Similar for
-- Entity_Id.
Default_Value : Field_Default_Value;
Type_Only : Type_Only_Enum;
Pre : String_Ptr;
Offset : Field_Offset;
-- Offset of the field, in units of the field size. So if a field is 4
-- bits, it starts at bit number Offset*4 from the start of the node.
end record;
type Field_Info_Ptr is access all Field_Info;
Field_Table : array (Field_Enum) of Field_Info_Ptr;
-- Table mapping from enumeration literals representing fields to
-- information about the field.
procedure Verify_Type_Table;
----------------
subtype Node_Field is
Field_Enum range
Field_Enum'First ..
Field_Enum'Pred (Between_Node_And_Entity_Fields);
subtype Entity_Field is
Field_Enum range
Field_Enum'Succ (Between_Node_And_Entity_Fields) ..
Field_Enum'Last;
function Image (F : Opt_Field_Enum) return String;
procedure Nil (T : Node_Or_Entity_Type);
-- Null procedure
procedure Iterate_Types
(Root : Node_Or_Entity_Type;
Pre, Post : not null access procedure (T : Node_Or_Entity_Type) :=
Nil'Access);
-- Iterate top-down on the type hierarchy. Call Pre and Post before and
-- after walking child types. Note that this ignores union types, because
-- they are nonhierarchical.
function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type)
return Boolean;
-- True if Descendant is a descendant of Ancestor; that is,
-- True if Ancestor is an ancestor of Descendant. True for
-- a type itself.
procedure Put_Type_Hierarchy (S : in out Sink'Class; Root : Root_Type);
function Pos (T : Concrete_Type) return Root_Nat;
-- Return Node_Kind'Pos (T) or Entity_Kind'Pos (T)
----------------
-- The same field can be syntactic in some nodes but semantic in others:
type Field_Desc is record
F : Field_Enum;
Is_Syntactic : Boolean;
end record;
type Field_Sequence_Index is new Positive;
type Field_Sequence is array (Field_Sequence_Index range <>) of Field_Desc;
No_Fields : constant Field_Sequence := (1 .. 0 => <>);
type Field_Array is array (Bit_Offset range <>) of Opt_Field_Enum;
type Field_Array_Ptr is access all Field_Array;
type Type_Layout_Array is array (Concrete_Type) of Field_Array_Ptr;
-- Mapping from types to mappings from offsets to fields
type Offset_To_Fields_Mapping is
array (Bit_Offset range <>) of Field_Array_Ptr;
-- Mapping from bit offsets to fields using that offset
function First_Abstract (Root : Root_Type) return Abstract_Type;
function Last_Abstract (Root : Root_Type) return Abstract_Type;
-- First and Last abstract types descended from the Root
function First_Concrete (Root : Root_Type) return Concrete_Type;
function Last_Concrete (Root : Root_Type) return Concrete_Type;
-- First and Last concrete types descended from the Root
function First_Field (Root : Root_Type) return Field_Enum;
function Last_Field (Root : Root_Type) return Field_Enum;
-- First and Last node or entity fields
function Node_Or_Entity (Root : Root_Type) return String;
-- Return "Node" or "Entity" depending on whether Root = Node_Kind
type Sinfo_Node_Order_Index is new Positive;
Sinfo_Node_Order :
constant array (Sinfo_Node_Order_Index range <>) of Node_Type :=
-- The order in which the documentation of node kinds appears in the old
-- sinfo.ads. This is the same order of the functions in Nmake.
-- Sinfo_Node_Order was constructed by massaging nmake.ads.
(N_Unused_At_Start,
N_Unused_At_End,
N_Identifier,
N_Integer_Literal,
N_Real_Literal,
N_Character_Literal,
N_String_Literal,
N_Pragma,
N_Pragma_Argument_Association,
N_Defining_Identifier,
N_Full_Type_Declaration,
N_Subtype_Declaration,
N_Subtype_Indication,
N_Object_Declaration,
N_Number_Declaration,
N_Derived_Type_Definition,
N_Range_Constraint,
N_Range,
N_Enumeration_Type_Definition,
N_Defining_Character_Literal,
N_Signed_Integer_Type_Definition,
N_Modular_Type_Definition,
N_Floating_Point_Definition,
N_Real_Range_Specification,
N_Ordinary_Fixed_Point_Definition,
N_Decimal_Fixed_Point_Definition,
N_Digits_Constraint,
N_Unconstrained_Array_Definition,
N_Constrained_Array_Definition,
N_Component_Definition,
N_Discriminant_Specification,
N_Index_Or_Discriminant_Constraint,
N_Discriminant_Association,
N_Record_Definition,
N_Component_List,
N_Component_Declaration,
N_Variant_Part,
N_Variant,
N_Others_Choice,
N_Access_To_Object_Definition,
N_Access_Function_Definition,
N_Access_Procedure_Definition,
N_Access_Definition,
N_Incomplete_Type_Declaration,
N_Explicit_Dereference,
N_Indexed_Component,
N_Slice,
N_Selected_Component,
N_Attribute_Reference,
N_Aggregate,
N_Component_Association,
N_Extension_Aggregate,
N_Iterated_Component_Association,
N_Delta_Aggregate,
N_Iterated_Element_Association,
N_Null,
N_And_Then,
N_Or_Else,
N_In,
N_Not_In,
N_Op_And,
N_Op_Or,
N_Op_Xor,
N_Op_Eq,
N_Op_Ne,
N_Op_Lt,
N_Op_Le,
N_Op_Gt,
N_Op_Ge,
N_Op_Add,
N_Op_Subtract,
N_Op_Concat,
N_Op_Multiply,
N_Op_Divide,
N_Op_Mod,
N_Op_Rem,
N_Op_Expon,
N_Op_Plus,
N_Op_Minus,
N_Op_Abs,
N_Op_Not,
N_If_Expression,
N_Case_Expression,
N_Case_Expression_Alternative,
N_Quantified_Expression,
N_Type_Conversion,
N_Qualified_Expression,
N_Allocator,
N_Null_Statement,
N_Label,
N_Assignment_Statement,
N_Target_Name,
N_If_Statement,
N_Elsif_Part,
N_Case_Statement,
N_Case_Statement_Alternative,
N_Loop_Statement,
N_Iteration_Scheme,
N_Loop_Parameter_Specification,
N_Iterator_Specification,
N_Block_Statement,
N_Exit_Statement,
N_Goto_Statement,
N_Subprogram_Declaration,
N_Abstract_Subprogram_Declaration,
N_Function_Specification,
N_Procedure_Specification,
N_Designator,
N_Defining_Program_Unit_Name,
N_Operator_Symbol,
N_Defining_Operator_Symbol,
N_Parameter_Specification,
N_Subprogram_Body,
N_Procedure_Call_Statement,
N_Function_Call,
N_Parameter_Association,
N_Simple_Return_Statement,
N_Extended_Return_Statement,
N_Expression_Function,
N_Package_Declaration,
N_Package_Specification,
N_Package_Body,
N_Private_Type_Declaration,
N_Private_Extension_Declaration,
N_Use_Package_Clause,
N_Use_Type_Clause,
N_Object_Renaming_Declaration,
N_Exception_Renaming_Declaration,
N_Package_Renaming_Declaration,
N_Subprogram_Renaming_Declaration,
N_Generic_Package_Renaming_Declaration,
N_Generic_Procedure_Renaming_Declaration,
N_Generic_Function_Renaming_Declaration,
N_Task_Type_Declaration,
N_Single_Task_Declaration,
N_Task_Definition,
N_Task_Body,
N_Protected_Type_Declaration,
N_Single_Protected_Declaration,
N_Protected_Definition,
N_Protected_Body,
N_Entry_Declaration,
N_Accept_Statement,
N_Entry_Body,
N_Entry_Body_Formal_Part,
N_Entry_Index_Specification,
N_Entry_Call_Statement,
N_Requeue_Statement,
N_Delay_Until_Statement,
N_Delay_Relative_Statement,
N_Selective_Accept,
N_Accept_Alternative,
N_Delay_Alternative,
N_Terminate_Alternative,
N_Timed_Entry_Call,
N_Entry_Call_Alternative,
N_Conditional_Entry_Call,
N_Asynchronous_Select,
N_Triggering_Alternative,
N_Abortable_Part,
N_Abort_Statement,
N_Compilation_Unit,
N_Compilation_Unit_Aux,
N_With_Clause,
N_Subprogram_Body_Stub,
N_Package_Body_Stub,
N_Task_Body_Stub,
N_Protected_Body_Stub,
N_Subunit,
N_Exception_Declaration,
N_Handled_Sequence_Of_Statements,
N_Exception_Handler,
N_Raise_Statement,
N_Raise_Expression,
N_Generic_Subprogram_Declaration,
N_Generic_Package_Declaration,
N_Package_Instantiation,
N_Procedure_Instantiation,
N_Function_Instantiation,
N_Generic_Association,
N_Formal_Object_Declaration,
N_Formal_Type_Declaration,
N_Formal_Private_Type_Definition,
N_Formal_Derived_Type_Definition,
N_Formal_Incomplete_Type_Definition,
N_Formal_Discrete_Type_Definition,
N_Formal_Signed_Integer_Type_Definition,
N_Formal_Modular_Type_Definition,
N_Formal_Floating_Point_Definition,
N_Formal_Ordinary_Fixed_Point_Definition,
N_Formal_Decimal_Fixed_Point_Definition,
N_Formal_Concrete_Subprogram_Declaration,
N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Package_Declaration,
N_Attribute_Definition_Clause,
N_Aspect_Specification,
N_Enumeration_Representation_Clause,
N_Record_Representation_Clause,
N_Component_Clause,
N_Code_Statement,
N_Op_Rotate_Left,
N_Op_Rotate_Right,
N_Op_Shift_Left,
N_Op_Shift_Right_Arithmetic,
N_Op_Shift_Right,
N_Delta_Constraint,
N_At_Clause,
N_Mod_Clause,
N_Call_Marker,
N_Compound_Statement,
N_Contract,
N_Expanded_Name,
N_Expression_With_Actions,
N_Free_Statement,
N_Freeze_Entity,
N_Freeze_Generic_Entity,
N_Implicit_Label_Declaration,
N_Itype_Reference,
N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Storage_Error,
N_Push_Constraint_Error_Label,
N_Push_Program_Error_Label,
N_Push_Storage_Error_Label,
N_Pop_Constraint_Error_Label,
N_Pop_Program_Error_Label,
N_Pop_Storage_Error_Label,
N_Reference,
N_SCIL_Dispatch_Table_Tag_Init,
N_SCIL_Dispatching_Call,
N_SCIL_Membership_Test,
N_Unchecked_Expression,
N_Unchecked_Type_Conversion,
N_Validate_Unchecked_Conversion,
N_Variable_Reference_Marker);
end Gen_IL.Utils;

63
gcc/ada/gen_il.adb Normal file
View File

@ -0,0 +1,63 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Gen_IL is
function Image (X : Root_Int) return String is
Result : constant String := X'Img;
begin
if Result (1) = ' ' then
return Result (2 .. Result'Last);
else
return Result;
end if;
end Image;
procedure Capitalize (S : in out String) is
Cap : Boolean := True;
begin
for X of S loop
declare
Old : constant Character := X;
begin
if Cap then
X := To_Upper (X);
else
X := To_Lower (X);
end if;
Cap := not (Is_Letter (Old) or else Is_Digit (Old));
end;
end loop;
end Capitalize;
function Capitalize (S : String) return String is
begin
return Result : String (S'Range) := S do
Capitalize (Result);
end return;
end Capitalize;
end Gen_IL;

309
gcc/ada/gen_il.ads Normal file
View File

@ -0,0 +1,309 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E N _ I L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Warnings (Off); -- with clauses for children
with Ada.Strings.Text_Output.Formatting;
use Ada.Strings.Text_Output, Ada.Strings.Text_Output.Formatting;
with Ada.Strings.Text_Output.Files; use Ada.Strings.Text_Output.Files;
with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils;
with Ada.Characters.Handling; use Ada.Characters.Handling;
pragma Warnings (On);
package Gen_IL is -- generate intermediate language
-- This package and children generates the main intermediate language used
-- by the compiler, which is a decorated syntax tree.
-- Here's what the hand-written and generated code looks like. The make
-- files run the gen_il-main.adb program to generate the generated files
-- listed below, before building the compiler proper.
--
-- atree.ads, atree.adb: Rewrite according to low-level
-- design notes. Remove package Unchecked_Access.
-- Low-level getters and setters go in Atree_Private_Part.
-- These are called by the high-level automatically-generated
-- getters and setters in Sinfo.Nodes and Einfo.Entities.
-- Also used by Atree.Traverse_Func, and by Treepr.
--
-- sinfo.ads, einfo.ads: Remove getters and setters.
-- Remove Write_... routines used by old Treepr.
-- Keep commments describing the semantics of all the nodes,
-- entities, and fields. These comments are wrong, but only
-- a little, and I'm not going to try to fix them. At some
-- point, we could remove the comments giving field offsets
-- (e.g. "(Flag5-Sem)"), but for now, just note that that's
-- obsolete info.
--
-- einfo.adb, sinfo.adb: Delete.
--
-- gen_il.ads, gen_il.adb: Mostly empty root package for the
-- "generate intermediate language" program, which generates
-- all the files mentioned here.
-- The main program is gen_il-main.adb.
--
-- sinfo-utils.ads, sinfo-utils.adb, einfo-utils.ads, einfo-utils.adb:
-- Move all handwritten code currently in sinfo&einfo to here,
-- if it refers to stuff in sinfo-nodes.ads, einfo-entities.ads
-- This includes the "synthesized attributes".
--
-- gen_il-types.ads: Enumeration type containing one literal for
-- each type of interest. That includes all the Node_Kinds and
-- Entity_Kinds, plus the subtypes that include multiple
-- Node_Kinds and Entity_Kinds (all from the old sinfo/einfo),
-- plus all field types (Uint, Ureal, Name_Id, etc).
--
-- gen_il-fields.ads: Enumeration of all the fields of all node
-- and entity types.
--
-- gen_il-gen.ads, gen_il-gen.adb: Implementation of the "compiler"
-- for the "little language".
--
-- gen_il-gen-gen_nodes.adb: Procedure to generate Sinfo.Nodes
-- (by calling procedures in Gen_IL).
-- This defines what abstract and concrete node types exist,
-- and what fields they have. This and the next one are the
-- hard part. I'm planning to generate this semi-automatically.
-- But once it's working, we will maintain it by hand.
--
-- gen_il-gen-gen_entities.adb: Procedure to generate einfo-entities.*.
-- This defines what abstract and concrete entity types exist,
-- and what fields they have.
--
-- seinfo.ads: Generated by gen_il-main.adb. Contains declarations shared
-- by Sinfo.Nodes and Einfo.Entities.
--
-- sinfo-nodes.ads, sinfo-nodes.adb: Generated by gen_il-main.adb
-- (really by Gen_Nodes). Contains:
--
-- - Information in comments, such as what fields exist in what
-- node kinds, which might be hard to compute by hand for
-- inherited fields.
--
-- - Type Node_Kind. Same as the old Sinfo, but now generated.
-- One enumeral for each concrete node type in Gen_Nodes.
--
-- - One subtype of Node_Kind for each abstract type in Gen_Nodes.
-- Same as the old Sinfo, but now generated. E.g.:
--
-- subtype N_Representation_Clause is Node_Kind range
-- N_At_Clause .. N_Attribute_Definition_Clause;
--
-- - One subtype of Node_Id for each abstract and concrete type,
-- with a predicate requiring the right Nkind. E.g.:
--
-- subtype N_Representation_Clause_Id is
-- Node_Id with Predicate =>
-- Nkind (N_Representation_Clause_Id) in N_Representation_Clause;
--
-- - Getters and setters for every node field. If the field is defined
-- for all node kinds in one of the above Node_Id subtypes and no
-- others, then we use that as the parameter subtype:
--
-- function Abortable_Part
-- (N : N_Asynchronous_Select_Id) return Node_Id with Inline;
--
-- Otherwise, we use a precondition:
--
-- function Abstract_Present
-- (N : Node_Id) return Flag with Inline, Pre =>
-- N in N_Private_Extension_Declaration_Id
-- | N_Private_Type_Declaration_Id
-- | N_Derived_Type_Definition_Id
-- ...
--
-- - Type Node_Field: Enumeration of all node fields. Used by Treepr,
-- and in tables below.
--
-- - Table of syntactic fields. For each node kind, we have a sequence
-- of fields. A field is included if it exists in that node kind,
-- and it is syntactic, and it is of type Node_Id or List_Id.
-- Used by Traverse_Func.
--
-- - Table of node sizes, indexed by Node_Kind. Used by Atree when
-- allocating and copying nodes.
--
-- - Table mapping Node_Kinds to the sequence of fields that exist in
-- that Node_Kind. Used by Treepr.
--
-- - Node_Field_Descriptors: Table mapping fields to type and offset.
-- Used by Treepr to know where to find each field, and what its
-- type is, for printing.
--
-- - The body contains instantiations of the low-level getters and
-- setters declared in Atree, e.g.:
--
-- function Get_List_Id is new Get_32_Bit_Field (List_Id)
-- with Inline;
-- procedure Set_List_Id is new Set_32_Bit_Field (List_Id)
-- with Inline;
--
-- and bodies of the high-level getters and setters, e.g.:
--
-- function Actions
-- (N : Node_Id) return List_Id is
-- begin
-- return Get_List_Id (N, 4);
-- end Actions;
--
-- einfo-entities.ads, einfo-entities.adb: Generated by gen_il-main.adb
-- (really by Gen_Entities). Contains the same sort of stuff as
-- Sinfo.Nodes, except no table of syntactic fields.
--
-- nmake.ads, nmake.adb: Same contents as the old version, but generated by
-- Gen_IL instead of xnmake.
--
-- treepr.adb: Rewrite to use the tables in Nodes and Entities.
--
-- treeprs.ads: Delete. (Was automatically generated.)
-- Treepr no longer needs this; it can use 'Image on the
-- enumeration types in Nodes and Entities.
--
-- csinfo.adb, ceinfo.adb, xsinfo.adb, xeinfo.adb, xnmake.adb,
-- xtreeprs.adb, nmake.adt, treeprs.adt: Delete.
-- C++ code:
--
-- atree.h (hand-written code):
--
-- This code should be entirely deleted, and replaced with low-level
-- getters analogous to the generic getters in Atree. One getter for each
-- field size (currently 1, 2, 4, 8, and 32 bits. No need for setters.
--
-- ----------------
--
-- fe.h (hand-written code):
--
-- There are comments in various places that say that gigi
-- does not modify the tree. However, I discovered some stuff
-- in fe.h that modifies the tree:
--
-- #define End_Location sinfo__end_location
-- #define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code
-- #define Set_Present_Expr sinfo__set_present_expr
--
-- #define Set_Alignment einfo__set_alignment
-- #define Set_Component_Bit_Offset einfo__set_component_bit_offset
-- #define Set_Component_Size einfo__set_component_size
-- #define Set_Esize einfo__set_esize
-- #define Set_Mechanism einfo__set_mechanism
-- #define Set_Normalized_First_Bit einfo__set_normalized_first_bit
-- #define Set_Normalized_Position einfo__set_normalized_position
-- #define Set_RM_Size einfo__set_rm_size
--
-- #define Is_Entity_Name einfo__utils__is_entity_name
-- #define Get_Attribute_Definition_Clause \
-- einfo__utils__get_attribute_definition_clause
--
-- These setters and some getters need to be changed because the
-- setters and getters are moving from Sinfo to Sinfo.Nodes,
-- and from Einfo to Einfo.Entities. The last two will be in Einfo.Utils.
--
-- ----------------
--
-- sinfo.h (tool-generated code):
--
-- A bunch of #defines for the node kinds. These can remain the same.
--
-- A bunch of calls to SUBTYPE (macro defined in gcc-interface/ada.h).
-- These can remain the same.
--
-- A bunch of getters (no setters), like:
--
-- INLINE Boolean Abort_Present (Node_Id N)
-- { return Flag15 (N); }
--
-- Change this to call the new low-level getters.
-- Something like:
--
-- INLINE Boolean Abort_Present (Node_Id N)
-- { return Get_Flag (N, 15); }
--
-- Generate the low-level getters in the same file, before the above
-- high-level getters, one for each field type:
--
-- Flag
-- Node_Id
-- List_Id
-- Elist_Id
-- Name_Id
-- String_Id
-- Uint
-- Ureal
-- Node_Kind
-- Entity_Kind
-- Source_Ptr
-- Small_Paren_Count_Type
-- Union_Id
-- Convention_Id
-- Component_Alignment_Kind
-- Float_Rep_Kind
-- Mechanism_Type
--
-- These are in types.h.
--
-- ----------------
--
-- einfo.h (tool-generated code):
--
-- Can mostly remain the same, except:
--
-- Call low-level getters, as for sinfo.h.
--
-- The getters that are NOT inlined will be moved from
-- Einfo to Einfo.Entities.
-- I don't understand why some are not inlined (e.g Float_Rep?).
-- Most are not inlined because they are synthesized.
-- Maybe that should be hand written, and moved to a different file.
-- Or maybe Gen_IL should know about these fields.
--
-- We have code like:
-- INLINE B Is_Subprogram_Or_Generic_Subprogram (E Id)
-- { return IN (Ekind (Id), Subprogram_Kind) || IN (Ekind (Id),
-- Generic_Subprogram_Kind); }
-- That should be hand written, and moved to atree.h or fe.h.
-- Is_Record_Type requires special treatment, because Record_Kind is
-- a nonhierarchical type.
--
-- Looks like the getters are in alphabetical order.
-- Except for the Is_..._Type ones.
-- Misc declarations used throughout:
type Root_Int is new Integer;
function Image (X : Root_Int) return String;
-- Without the extra blank. You can derive from Root_Int or the subtypes
-- below, and inherit a convenient Image function that leaves out that
-- blank.
subtype Root_Nat is Root_Int range 0 .. Root_Int'Last;
subtype Root_Pos is Root_Int range 1 .. Root_Int'Last;
function Capitalize (S : String) return String;
procedure Capitalize (S : in out String);
-- Turns an identifier into Mixed_Case
type String_Ptr is access all String;
end Gen_IL;

1
gcc/ada/get_targ.ads
View File

@ -37,7 +37,6 @@
-- the Wide_Character_Type uses twice the size of a C char, instead of the
-- size of wchar_t.
with Einfo; use Einfo;
with Types; use Types;
package Get_Targ is

8
gcc/ada/ghost.adb
View File

@ -26,7 +26,9 @@
with Alloc;
with Aspects; use Aspects;
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Namet; use Namet;
@ -39,7 +41,9 @@ with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Table;

18
gcc/ada/gnat1drv.adb
View File

@ -65,7 +65,9 @@ with Sem_Eval;
with Sem_Prag;
with Sem_Type;
with Set_Targ;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with Snames; use Snames;
@ -610,12 +612,6 @@ procedure Gnat1drv is
Ttypes.Target_Strict_Alignment := True;
end if;
-- Increase size of allocated entities if debug flag -gnatd.N is set
if Debug_Flag_Dot_NN then
Atree.Num_Extension_Nodes := Atree.Num_Extension_Nodes + 1;
end if;
-- Disable static allocation of dispatch tables if -gnatd.t is enabled.
-- The front end's layout phase currently treats types that have
-- discriminant-dependent arrays as not being static even when a
@ -1093,10 +1089,6 @@ begin
-- Lib.Initialize needs to be called before Scan_Compiler_Arguments,
-- because it initializes a table filled by Scan_Compiler_Arguments.
-- Atree.Initialize needs to be called after Scan_Compiler_Arguments,
-- because the value specified by the -gnaten switch is used by
-- Atree.Initialize.
Osint.Initialize;
Fmap.Reset_Tables;
Lib.Initialize;
@ -1720,10 +1712,6 @@ begin
<<End_Of_Program>>
if Debug_Flag_Dot_AA then
Atree.Print_Statistics;
end if;
-- The outer exception handler handles an unrecoverable error
exception

4
gcc/ada/gnat_cuda.adb
View File

@ -25,14 +25,14 @@
-- This package defines CUDA-specific datastructures and functions.
with Atree; use Atree;
with Debug; use Debug;
with Elists; use Elists;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;

4
gcc/ada/impunit.adb
View File

@ -23,9 +23,9 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Errout; use Errout;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Fname.UF; use Fname.UF;
with Lib; use Lib;
with Namet; use Namet;

8
gcc/ada/inline.adb
View File

@ -27,7 +27,9 @@ with Alloc;
with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
@ -49,7 +51,9 @@ with Sem_Ch12; use Sem_Ch12;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;

5
gcc/ada/itypes.adb
View File

@ -23,9 +23,10 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo.Utils; use Einfo.Utils;
with Sem; use Sem;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Stand; use Stand;
with Targparm; use Targparm;
with Uintp; use Uintp;

3
gcc/ada/itypes.ads
View File

@ -25,7 +25,8 @@
-- This package contains declarations for handling of implicit types
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Sem_Util; use Sem_Util;
with Types; use Types;

8
gcc/ada/layout.adb
View File

@ -25,14 +25,18 @@
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Opt; use Opt;
with Sem_Aux; use Sem_Aux;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Ttypes; use Ttypes;
with Uintp; use Uintp;

7
gcc/ada/lib-load.adb
View File

@ -25,7 +25,8 @@
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
@ -38,7 +39,9 @@ with Output; use Output;
with Par;
with Restrict; use Restrict;
with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with Stand; use Stand;

8
gcc/ada/lib-writ.adb
View File

@ -27,7 +27,9 @@ with ALI; use ALI;
with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
@ -46,7 +48,9 @@ with Rident; use Rident;
with Stand; use Stand;
with Scn; use Scn;
with Sem_Eval; use Sem_Eval;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;

2
gcc/ada/lib-xref-spark_specific.adb
View File

@ -23,7 +23,7 @@
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Nmake; use Nmake;
with SPARK_Xrefs; use SPARK_Xrefs;

6
gcc/ada/lib-xref.adb
View File

@ -25,6 +25,8 @@
with Atree; use Atree;
with Csets; use Csets;
with Einfo; use Einfo;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Lib.Util; use Lib.Util;
@ -37,7 +39,9 @@ with Sem_Aux; use Sem_Aux;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;

2
gcc/ada/lib-xref.ads
View File

@ -26,7 +26,7 @@
-- This package contains for collecting and outputting cross-reference
-- information.
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with SPARK_Xrefs;
package Lib.Xref is

6
gcc/ada/lib.adb
View File

@ -29,11 +29,13 @@ pragma Style_Checks (All_Checks);
with Atree; use Atree;
with Csets; use Csets;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinput; use Sinput;
with Stand; use Stand;
with Stringt; use Stringt;

4
gcc/ada/libgnat/a-stobfi.adb
View File

@ -62,7 +62,7 @@ package body Ada.Strings.Text_Output.Basic_Files is
is
begin
return Create_From_FD
(OS.Create_File (Name, Fmode => OS.Text),
(OS.Create_File (Name, Fmode => OS.Binary),
Indent_Amount, Chunk_Length);
end Create_File;
@ -73,7 +73,7 @@ package body Ada.Strings.Text_Output.Basic_Files is
is
begin
return Create_From_FD
(OS.Create_New_File (Name, Fmode => OS.Text),
(OS.Create_New_File (Name, Fmode => OS.Binary),
Indent_Amount, Chunk_Length);
end Create_New_File;

2
gcc/ada/libgnat/a-stoubu.adb
View File

@ -78,7 +78,7 @@ package body Ada.Strings.Text_Output.Buffers is
S.Cur_Chunk.Next :=
Text_Output.Chunk_Access (Chunk_Access'(new Chunk (S.Chunk_Length)));
S.Cur_Chunk := S.Cur_Chunk.Next;
S.Num_Extra_Chunks := @ + 1;
S.Num_Extra_Chunks := S.Num_Extra_Chunks + 1;
S.Last := 0;
end Full_Method;

10
gcc/ada/libgnat/a-stoufi.adb
View File

@ -46,7 +46,7 @@ package body Ada.Strings.Text_Output.Files is
is
begin
if FD = OS.Invalid_FD then
raise Program_Error with OS.Errno_Message;
raise Program_Error;
end if;
return Result : File (Chunk_Length) do
Result.Indent_Amount := Indent_Amount;
@ -62,7 +62,7 @@ package body Ada.Strings.Text_Output.Files is
is
begin
return Create_From_FD
(OS.Create_File (Name, Fmode => OS.Text),
(OS.Create_File (Name, Fmode => OS.Binary),
Indent_Amount, Chunk_Length);
end Create_File;
@ -73,7 +73,7 @@ package body Ada.Strings.Text_Output.Files is
is
begin
return Create_From_FD
(OS.Create_New_File (Name, Fmode => OS.Text),
(OS.Create_New_File (Name, Fmode => OS.Binary),
Indent_Amount, Chunk_Length);
end Create_New_File;
@ -90,7 +90,7 @@ package body Ada.Strings.Text_Output.Files is
if S.FD not in OS.Standout | OS.Standerr then -- Don't close these
OS.Close (S.FD, Status);
if not Status then
raise Program_Error with OS.Errno_Message;
raise Program_Error;
end if;
end if;
end Close;
@ -103,7 +103,7 @@ package body Ada.Strings.Text_Output.Files is
OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last);
begin
if Res /= S.Last then
raise Program_Error with OS.Errno_Message;
raise Program_Error;
end if;
S.Last := 0;
end Flush_Method;

6
gcc/ada/libgnat/a-stouut.adb
View File

@ -57,7 +57,7 @@ package body Ada.Strings.Text_Output.Utils is
procedure Put_Octet (S : in out Sink'Class; Item : Character) is
begin
S.Last := @ + 1;
S.Last := S.Last + 1;
S.Cur_Chunk.Chars (S.Last) := Item;
pragma Assert (S.Chunk_Length = S.Cur_Chunk.Chars'Length);
if S.Last = S.Chunk_Length then
@ -75,7 +75,7 @@ package body Ada.Strings.Text_Output.Utils is
if S.Column = 1 then
Tab_To_Column (S, S.Indentation + 1);
end if;
S.Column := @ + 1;
S.Column := S.Column + 1;
end Adjust_Column;
procedure Put_7bit (S : in out Sink'Class; Item : Character_7) is
@ -196,7 +196,7 @@ package body Ada.Strings.Text_Output.Utils is
Line_Start := Index + 1;
end if;
Index := @ + 1;
Index := Index + 1;
end loop;
if Index > Line_Start then

190
gcc/ada/libgnat/a-stteou__bootstrap.ads Normal file
View File

@ -0,0 +1,190 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.TEXT_OUTPUT --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Simplified version used during bootstrap only
with Ada.Strings.UTF_Encoding;
package Ada.Strings.Text_Output with Pure is
-- This package provides a "Sink" abstraction, to which characters of type
-- Character, Wide_Character, and Wide_Wide_Character can be sent. This
-- type is used by the Put_Image attribute. In particular, T'Put_Image has
-- the following parameter types:
--
-- procedure T'Put_Image (S : in out Sink'Class; V : T);
--
-- The default generated code for Put_Image of a composite type will
-- typically call Put_Image on the components.
--
-- This is not a fully general abstraction that can be arbitrarily
-- extended. It is designed with particular extensions in mind, and these
-- extensions are declared in child packages of this package, because they
-- depend on implementation details in the private part of this
-- package.
--
-- Users are not expected to extend type Sink.
--
-- The primary extensions of Sink are:
--
-- Buffer. The characters sent to a Buffer are stored in memory, and can
-- be retrieved via Get functions. This is intended for the
-- implementation of the 'Image attribute. The compiler will generate a
-- T'Image function that declares a local Buffer, sends characters to
-- it, and then returns a call to Get, Destroying the Buffer on return.
--
-- function T'Image (V : T) return String is
-- Buf : Buffer := New_Buffer (...);
-- begin
-- T'Put_Image (Buf, V);
-- return Result : constant String := Get (Buf) do
-- Destroy (Buf);
-- end return;
-- end T'Image;
-- ????Perhaps Buffer should be controlled; if you don't like
-- controlled types, call Put_Image directly.
--
-- File. The characters are sent to a file, possibly opened by file
-- name, or possibly standard output or standard error. 'Put_Image
-- can be called directly on a File, thus avoiding any heap allocation.
type Sink (<>) is abstract tagged limited private;
type Sink_Access is access all Sink'Class with Storage_Size => 0;
-- Sink is a character sink; you can send characters to a Sink.
-- UTF-8 encoding is used.
procedure Full_Method (S : in out Sink) is abstract;
procedure Flush_Method (S : in out Sink) is abstract;
-- There is an internal buffer to store the characters. Full_Method is
-- called when the buffer is full, and Flush_Method may be called to flush
-- the buffer. For Buffer, Full_Method allocates more space for more
-- characters, and Flush_Method does nothing. For File, Full_Method and
-- Flush_Method do the same thing: write the characters to the file, and
-- empty the internal buffer.
--
-- These are the only dispatching subprograms on Sink. This is for
-- efficiency; we don't dispatch on every write to the Sink, but only when
-- the internal buffer is full (or upon client request).
--
-- Full_Method and Flush_Method must make the current chunk empty.
--
-- Additional operations operating on Sink'Class are declared in the Utils
-- child, including Full and Flush, which call the above.
function To_Wide (C : Character) return Wide_Character is
(Wide_Character'Val (Character'Pos (C)));
function To_Wide_Wide (C : Character) return Wide_Wide_Character is
(Wide_Wide_Character'Val (Character'Pos (C)));
function To_Wide_Wide (C : Wide_Character) return Wide_Wide_Character is
(Wide_Wide_Character'Val (Wide_Character'Pos (C)));
-- Conversions [Wide_]Character --> [Wide_]Wide_Character.
-- These cannot fail.
function From_Wide (C : Wide_Character) return Character is
(Character'Val (Wide_Character'Pos (C)));
function From_Wide_Wide (C : Wide_Wide_Character) return Character is
(Character'Val (Wide_Wide_Character'Pos (C)));
function From_Wide_Wide (C : Wide_Wide_Character) return Wide_Character is
(Wide_Character'Val (Wide_Wide_Character'Pos (C)));
-- Conversions [Wide_]Wide_Character --> [Wide_]Character.
-- These fail if the character is out of range.
function NL return Character is (ASCII.LF) with Inline;
function Wide_NL return Wide_Character is (To_Wide (Character'(NL)))
with Inline;
function Wide_Wide_NL return Wide_Wide_Character is
(To_Wide_Wide (Character'(NL))) with Inline;
-- Character representing new line. There is no support for CR/LF line
-- endings.
-- We have two subtypes of String that are encoded in UTF-8. UTF_8 cannot
-- contain newline characters; UTF_8_Lines can. Sending UTF_8 data to a
-- Sink is more efficient, because end-of-line processing is not needed.
-- Both of these are more efficient than [[Wide_]Wide_]String, because no
-- encoding is needed.
subtype UTF_8_Lines is UTF_Encoding.UTF_8_String;
subtype UTF_8 is UTF_8_Lines;
Default_Indent_Amount : constant Natural := 4;
Default_Chunk_Length : constant Positive := 500;
-- Experiment shows this value to be reasonably efficient; decreasing it
-- slows things down, but increasing it doesn't gain much.
private
-- For Buffer, the "internal buffer" mentioned above is implemented as a
-- linked list of chunks. When the current chunk is full, we allocate a new
-- one. For File, there is only one chunk. When it is full, we send the
-- data to the file, and empty it.
type Chunk;
type Chunk_Access is access all Chunk with Storage_Size => 0;
type Chunk (Length : Positive) is limited record
Next : Chunk_Access := null;
Chars : UTF_8_Lines (1 .. Length);
end record;
type Sink (Chunk_Length : Positive) is abstract tagged limited record
Indent_Amount : Natural;
Column : Positive := 1;
Indentation : Natural := 0;
All_7_Bits : Boolean := True;
-- For optimization of Text_Output.Buffers.Get (cf).
-- True if all characters seen so far fit in 7 bits.
-- 7-bit characters are represented the same in Character
-- and in UTF-8, so they don't need translation.
All_8_Bits : Boolean := True;
-- True if all characters seen so far fit in 8 bits.
-- This is needed in Text_Output.Buffers.Get to distinguish
-- the case where all characters are Latin-1 (so it should
-- decode) from the case where some characters are bigger than
-- 8 bits (so the result is implementation defined).
Cur_Chunk : Chunk_Access;
-- Points to the chunk we are currently sending characters to.
-- We want to say:
-- Cur_Chunk : Chunk_Access := Initial_Chunk'Access;
-- but that's illegal, so we have some horsing around to do.
Last : Natural := 0;
-- Last-used character in Cur_Chunk.all.
Initial_Chunk : aliased Chunk (Length => Chunk_Length);
-- For Buffer, this is the first chunk. Subsequent chunks are allocated
-- on the heap. For File, this is the only chunk, and there is no heap
-- allocation.
end record;
end Ada.Strings.Text_Output;

8
gcc/ada/live.adb
View File

@ -24,12 +24,16 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Lib; use Lib;
with Nlists; use Nlists;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Types; use Types;
package body Live is

37
gcc/ada/nlists.adb
View File

@ -30,7 +30,8 @@ with Alloc;
with Atree; use Atree;
with Debug; use Debug;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Table;
package body Nlists is
@ -39,9 +40,6 @@ package body Nlists is
-- permitted only when this switch is set to False; compiling without
-- assertions this lock has no effect.
use Atree_Private_Part;
-- Get access to Nodes table
----------------------------------
-- Implementation of Node Lists --
----------------------------------
@ -86,17 +84,16 @@ package body Nlists is
Table_Component_Type => Node_Or_Entity_Id,
Table_Index_Type => Node_Or_Entity_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Nodes_Initial,
Table_Increment => Alloc.Nodes_Increment,
Release_Threshold => Alloc.Nodes_Release_Threshold,
Table_Initial => Alloc.Node_Offsets_Initial,
Table_Increment => Alloc.Node_Offsets_Increment,
Table_Name => "Next_Node");
package Prev_Node is new Table.Table (
Table_Component_Type => Node_Or_Entity_Id,
Table_Index_Type => Node_Or_Entity_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Nodes_Initial,
Table_Increment => Alloc.Nodes_Increment,
Table_Initial => Alloc.Node_Offsets_Initial,
Table_Increment => Alloc.Node_Offsets_Increment,
Table_Name => "Prev_Node");
-----------------------
@ -188,7 +185,7 @@ package body Nlists is
Set_Last (To, Node);
Nodes.Table (Node).In_List := True;
Set_In_List (Node, True);
Set_Next (Node, Empty);
Set_Prev (Node, L);
@ -406,7 +403,7 @@ package body Nlists is
Set_Next (After, Node);
Nodes.Table (Node).In_List := True;
Set_In_List (Node, True);
Set_Prev (Node, After);
Set_Next (Node, Before);
@ -466,7 +463,7 @@ package body Nlists is
Set_Prev (Before, Node);
Nodes.Table (Node).In_List := True;
Set_In_List (Node, True);
Set_Prev (Node, After);
Set_Next (Node, Before);
@ -623,7 +620,7 @@ package body Nlists is
function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is
begin
return Nodes.Table (Node).In_List;
return In_List (Node);
end Is_List_Member;
-----------------------
@ -675,7 +672,7 @@ package body Nlists is
function List_Containing (Node : Node_Or_Entity_Id) return List_Id is
begin
pragma Assert (Is_List_Member (Node));
return List_Id (Nodes.Table (Node).Link);
return List_Id (Link (Node));
end List_Containing;
-----------------
@ -866,7 +863,7 @@ package body Nlists is
Set_First (List, Node);
Set_Last (List, Node);
Nodes.Table (Node).In_List := True;
Set_In_List (Node, True);
Set_List_Link (Node, List);
Set_Prev (Node, Empty);
Set_Next (Node, Empty);
@ -1083,7 +1080,7 @@ package body Nlists is
Set_First (To, Node);
Nodes.Table (Node).In_List := True;
Set_In_List (Node, True);
Set_Next (Node, F);
Set_Prev (Node, Empty);
@ -1292,7 +1289,7 @@ package body Nlists is
Set_Prev (Nxt, Prv);
end if;
Nodes.Table (Node).In_List := False;
Set_In_List (Node, False);
Set_Parent (Node, Empty);
end Remove;
@ -1341,7 +1338,7 @@ package body Nlists is
Set_Prev (Nxt, Empty);
end if;
Nodes.Table (Frst).In_List := False;
Set_In_List (Frst, False);
Set_Parent (Frst, Empty);
return Frst;
end;
@ -1392,7 +1389,7 @@ package body Nlists is
Set_Prev (Nxt2, Node);
end if;
Nodes.Table (Nxt).In_List := False;
Set_In_List (Nxt, False);
Set_Parent (Nxt, Empty);
end;
end if;
@ -1427,7 +1424,7 @@ package body Nlists is
procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
begin
pragma Assert (not Locked);
Nodes.Table (Node).Link := Union_Id (To);
Set_Link (Node, Union_Id (To));
end Set_List_Link;
--------------

21
gcc/ada/nlists.h
View File

@ -105,9 +105,6 @@ Prev (Node_Id Node)
extern Node_Id Prev_Non_Pragma (Node_Id);
static Boolean Is_Empty_List (List_Id);
static Boolean Is_Non_Empty_List (List_Id);
static Boolean Is_List_Member (Node_Id);
static List_Id List_Containing (Node_Id);
INLINE Boolean
Is_Empty_List (List_Id Id)
@ -115,24 +112,6 @@ Is_Empty_List (List_Id Id)
return (First (Id) == Empty);
}
INLINE Boolean
Is_Non_Empty_List (List_Id Id)
{
return (Present (Id) && First (Id) != Empty);
}
INLINE Boolean
Is_List_Member (Node_Id Node)
{
return Nodes_Ptr[Node - First_Node_Id].U.K.in_list;
}
INLINE List_Id
List_Containing (Node_Id Node)
{
return Nodes_Ptr[Node - First_Node_Id].V.NX.link;
}
#ifdef __cplusplus
}
#endif

80
gcc/ada/nmake.adt
View File

@ -1,80 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- N M A K E --
-- --
-- T e m p l a t e --
-- --
-- Copyright (C) 1992-2007, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This file is a template used as input to the utility program XNmake,
-- which reads this template, and the spec of Sinfo (sinfo.ads) and
-- generates the body and/or the spec for the Nmake package (files
-- nmake.ads and nmake.adb)
pragma Style_Checks (All_Checks);
-- Turn off subprogram order checking, since the routines here are
-- generated automatically in order.
with Atree; use Atree; -- body only
with Namet; use Namet; -- spec only
with Nlists; use Nlists; -- spec only
with Sinfo; use Sinfo; -- body only
with Snames; use Snames; -- body only
with Stand; use Stand; -- body only
with Types; use Types; -- spec only
with Uintp; use Uintp; -- spec only
with Urealp; use Urealp; -- spec only
package Nmake is
-- This package contains a set of routines used to construct tree nodes
-- using a functional style. There is one routine for each node type defined
-- in Sinfo with the general interface:
-- function Make_xxx (Sloc : Source_Ptr,
-- Field_Name_1 : Field_Name_1_Type [:= default]
-- Field_Name_2 : Field_Name_2_Type [:= default]
-- ...)
-- return Node_Id
-- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib"
-- in the Sinfo spec are excluded). In addition, the following four syntactic
-- fields are excluded:
-- Prev_Ids
-- More_Ids
-- Comes_From_Source
-- Paren_Count
-- since they are very rarely set in expanded code. If they need to be set,
-- to other than the default values (False, False, False, zero), then the
-- appropriate Set_xxx procedures must be used on the returned value.
-- Default values are provided only for flag fields (where the default is
-- False), and for optional fields. An optional field is one where the
-- comment line describing the field contains the string "(set to xxx if".
-- For such fields, a default value of xxx is provided."
-- Warning: since calls to Make_xxx routines are normal function calls, the
-- arguments can be evaluated in any order. This means that at most one such
-- argument can have side effects (e.g. be a call to a parse routine).
!!TEMPLATE INSERTION POINT
end Nmake;

2
gcc/ada/opt.ads
View File

@ -1528,7 +1528,7 @@ package Opt is
Table_Factor : Int := 1;
-- GNAT
-- Factor by which all initial table sizes set in Alloc are multiplied.
-- Used in Table to calculate initial table sizes (the initial table size
-- Used in Table to calculate initial table sizes. The initial table size
-- is the value in Alloc, used as the Table_Initial parameter value,
-- multiplied by the factor given here. The default value is used if no
-- -gnatT switch appears.

4
gcc/ada/par.adb
View File

@ -44,7 +44,9 @@ with Scn; use Scn;
with Sem_Util; use Sem_Util;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with Sinfo; use Sinfo;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Style;
with Stylesw; use Stylesw;

Some files were not shown because too many files have changed in this diff Show More