From fa6fd7b7afece6e0cfe197c9419ea3346d3c60b2 Mon Sep 17 00:00:00 2001 From: Alexandre Oliva Date: Tue, 31 Jul 2018 21:19:13 +0000 Subject: Introduce instance discriminators With -gnateS, the Ada compiler sets itself up to output discriminators for different instantiations of generics, but the middle and back ends have lacked support for that. This patch introduces the missing bits, translating the GNAT-internal representation of the per-file instance map to an instance_table that maps decls to instance discriminators. From: Alexandre Oliva , Olivier Hainque for gcc/ChangeLog * debug.h (decl_to_instance_map_t): New type. (decl_to_instance_map): Declare. (maybe_create_decl_to_instance_map): New inline function. * final.c (bb_discriminator, last_bb_discriminator): New statics, to track basic block discriminators. (final_start_function_1): Initialize them. (final_scan_insn_1): On NOTE_INSN_BASIC_BLOCK, track bb_discriminator. (decl_to_instance_map): New variable. (map_decl_to_instance, maybe_set_discriminator): New functions. (notice_source_line): Set discriminator. for gcc/ada/ChangeLog * trans.c: Include debug.h. (file_map): New static variable. (gigi): Set it. Create decl_to_instance_map when needed. (Subprogram_Body_to_gnu): Pass gnu_subprog_decl to... (Sloc_to_locus): ... this. Add decl parm, map it to instance. * gigi.h (Sloc_to_locus): Adjust declaration. for gcc/testsuite/ChangeLog * gnat.dg/dinst.adb: New. * gnat.dg/dinst_pkg.ads, gnat.dg/dinst_pkg.adb: New. Co-Authored-By: Olivier Hainque From-SVN: r263182 --- gcc/ada/ChangeLog | 10 ++++++++++ gcc/ada/gcc-interface/gigi.h | 2 +- gcc/ada/gcc-interface/trans.c | 29 ++++++++++++++++++++++++----- 3 files changed, 35 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c6f1911..8b1de0c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2018-07-31 Alexandre Oliva + Olivier Hainque + + * trans.c: Include debug.h. + (file_map): New static variable. + (gigi): Set it. Create decl_to_instance_map when needed. + (Subprogram_Body_to_gnu): Pass gnu_subprog_decl to... + (Sloc_to_locus): ... this. Add decl parm, map it to instance. + * gigi.h (Sloc_to_locus): Adjust declaration. + 2018-07-31 Arnaud Charlet * clean.adb, gnatchop.adb, gnatfind.adb, gnatls.adb, diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index a75cb90..b890195 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -285,7 +285,7 @@ extern void process_type (Entity_Id gnat_entity); location and false if it doesn't. If CLEAR_COLUMN is true, set the column information to 0. */ extern bool Sloc_to_locus (Source_Ptr Sloc, location_t *locus, - bool clear_column = false); + bool clear_column = false, const_tree decl = 0); /* Post an error message. MSG is the error message, properly annotated. NODE is the node at which to post the error and the node to use for the diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 31e098a..0371d00 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -41,6 +41,7 @@ #include "stmt.h" #include "varasm.h" #include "output.h" +#include "debug.h" #include "libfuncs.h" /* For set_stack_check_libfunc. */ #include "tree-iterator.h" #include "gimplify.h" @@ -255,6 +256,12 @@ static tree create_init_temporary (const char *, tree, tree *, Node_Id); static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; static const char *decode_name (const char *) ATTRIBUTE_UNUSED; +/* This makes gigi's file_info_ptr visible in this translation unit, + so that Sloc_to_locus can look it up when deciding whether to map + decls to instances. */ + +static struct File_Info_Type *file_map; + /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ @@ -300,6 +307,12 @@ gigi (Node_Id gnat_root, type_annotate_only = (gigi_operating_mode == 1); + if (Generate_SCO_Instance_Table != 0) + { + file_map = file_info_ptr; + maybe_create_decl_to_instance_map (number_file); + } + for (i = 0; i < number_file; i++) { /* Use the identifier table to make a permanent copy of the filename as @@ -701,6 +714,7 @@ gigi (Node_Id gnat_root, } /* Destroy ourselves. */ + file_map = NULL; destroy_gnat_decl (); destroy_gnat_utils (); @@ -3771,7 +3785,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) } /* Set the line number in the decl to correspond to that of the body. */ - if (!Sloc_to_locus (Sloc (gnat_node), &locus)) + if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl)) locus = input_location; DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus; @@ -9970,12 +9984,14 @@ maybe_implicit_deref (tree exp) return exp; } -/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code - location and false if it doesn't. If CLEAR_COLUMN is true, set the column - information to 0. */ +/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a + source code location and false if it doesn't. If CLEAR_COLUMN is + true, set the column information to 0. If DECL is given and SLOC + refers to a File with an instance, map DECL to that instance. */ bool -Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column) +Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column, + const_tree decl) { if (Sloc == No_Location) return false; @@ -9999,6 +10015,9 @@ Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column) *locus = linemap_position_for_line_and_column (line_table, map, line, column); + if (file_map && file_map[file - 1].Instance) + decl_to_instance_map->put (decl, file_map[file - 1].Instance); + return true; } -- cgit v1.1 From 1ae45251d9fb6b68046cbe1c6f942e1aacdeaf0a Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Fri, 3 Aug 2018 13:22:38 +0000 Subject: [Ada] Partially revert "Makefile patches from initial RISC-V cross/native build." This partially reverts r262482, at it broke canadian builds. 2018-08-03 Pierre-Marie de Rodat gcc/ada/ Reverts 2018-07-06 Jim Wilson * Make-generated.in (treeprs.ads): Use $(GNATMAKE) instead of gnatmake. (einfo.h, sinfo.h, stamp-snames, stamp-nmake): Likewise. * gcc-interface/Makefile.in (xoscons): Likewise. From-SVN: r263291 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/Make-generated.in | 10 +++++----- gcc/ada/gcc-interface/Makefile.in | 2 +- 3 files changed, 15 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8b1de0c..1095165 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-08-03 Pierre-Marie de Rodat + + Reverts + 2018-07-06 Jim Wilson + + * Make-generated.in (treeprs.ads): Use $(GNATMAKE) instead of gnatmake. + (einfo.h, sinfo.h, stamp-snames, stamp-nmake): Likewise. + * gcc-interface/Makefile.in (xoscons): Likewise. + 2018-07-31 Alexandre Oliva Olivier Hainque diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index bdcb62c..757eaa8 100644 --- a/gcc/ada/Make-generated.in +++ b/gcc/ada/Make-generated.in @@ -28,21 +28,21 @@ $(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/ -$(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 ) + (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_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 ) + (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_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 ) + (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 $(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true @@ -50,7 +50,7 @@ $(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUB -$(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 ) + (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 @@ -61,7 +61,7 @@ $(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nma -$(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) + (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 diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 601f23a..9a52e6d 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -613,7 +613,7 @@ OSCONS_EXTRACT=$(OSCONS_CC) $(GNATLIBCFLAGS_FOR_C) -S s-oscons-tmplt.i -$(MKDIR) ./bldtools/oscons $(RM) $(addprefix ./bldtools/oscons/,$(notdir $^)) $(CP) $^ ./bldtools/oscons - (cd ./bldtools/oscons ; $(GNATMAKE) -q xoscons) + (cd ./bldtools/oscons ; gnatmake -q xoscons) $(RTSDIR)/s-oscons.ads: ../stamp-gnatlib1-$(RTSDIR) s-oscons-tmplt.c gsocket.h ./bldtools/oscons/xoscons $(RM) $(RTSDIR)/s-oscons-tmplt.i $(RTSDIR)/s-oscons-tmplt.s -- cgit v1.1 From a6ac1bf6002509be4d8b425eb08378c686883258 Mon Sep 17 00:00:00 2001 From: Alexandre Oliva Date: Tue, 7 Aug 2018 05:54:11 +0000 Subject: Add missing gcc-interface/ to 2018-07-31 ChangeLog entry From-SVN: r263351 --- gcc/ada/ChangeLog | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1095165..792811f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -10,12 +10,12 @@ 2018-07-31 Alexandre Oliva Olivier Hainque - * trans.c: Include debug.h. + * gcc-interface/trans.c: Include debug.h. (file_map): New static variable. (gigi): Set it. Create decl_to_instance_map when needed. (Subprogram_Body_to_gnu): Pass gnu_subprog_decl to... (Sloc_to_locus): ... this. Add decl parm, map it to instance. - * gigi.h (Sloc_to_locus): Adjust declaration. + * gcc-interface/gigi.h (Sloc_to_locus): Adjust declaration. 2018-07-31 Arnaud Charlet -- cgit v1.1 From b649008486249ff86a068db6117b94b8c7b8a62b Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Tue, 21 Aug 2018 11:59:28 +0000 Subject: [Ada] Bump copyright notices to 2018 2018-08-21 Pierre-Marie de Rodat gcc/ada/ * libgnarl/a-intnam__dragonfly.ads, libgnarl/s-osinte__dragonfly.adb, libgnarl/s-osinte__dragonfly.ads, libgnarl/s-osinte__gnu.adb, libgnarl/s-osinte__gnu.ads, libgnarl/s-osinte__hpux-dce.adb, libgnarl/s-osinte__hpux-dce.ads, libgnarl/s-taprop__hpux-dce.adb, libgnarl/s-taspri__hpux-dce.ads: Bump copyright notices to 2018. From-SVN: r263698 --- gcc/ada/libgnarl/a-intnam__dragonfly.ads | 2 +- gcc/ada/libgnarl/s-osinte__dragonfly.adb | 2 +- gcc/ada/libgnarl/s-osinte__dragonfly.ads | 2 +- gcc/ada/libgnarl/s-osinte__gnu.adb | 2 +- gcc/ada/libgnarl/s-osinte__gnu.ads | 2 +- gcc/ada/libgnarl/s-osinte__hpux-dce.adb | 2 +- gcc/ada/libgnarl/s-osinte__hpux-dce.ads | 2 +- gcc/ada/libgnarl/s-taprop__hpux-dce.adb | 2 +- gcc/ada/libgnarl/s-taspri__hpux-dce.ads | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnarl/a-intnam__dragonfly.ads b/gcc/ada/libgnarl/a-intnam__dragonfly.ads index 1de9735..8fb16f3 100644 --- a/gcc/ada/libgnarl/a-intnam__dragonfly.ads +++ b/gcc/ada/libgnarl/a-intnam__dragonfly.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2018, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.adb b/gcc/ada/libgnarl/s-osinte__dragonfly.adb index dc9e19c..3cf18d1 100644 --- a/gcc/ada/libgnarl/s-osinte__dragonfly.adb +++ b/gcc/ada/libgnarl/s-osinte__dragonfly.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2018, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.ads b/gcc/ada/libgnarl/s-osinte__dragonfly.ads index a67702c..5a4255f 100644 --- a/gcc/ada/libgnarl/s-osinte__dragonfly.ads +++ b/gcc/ada/libgnarl/s-osinte__dragonfly.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2018, 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__gnu.adb b/gcc/ada/libgnarl/s-osinte__gnu.adb index fb099ac..3147748 100644 --- a/gcc/ada/libgnarl/s-osinte__gnu.adb +++ b/gcc/ada/libgnarl/s-osinte__gnu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2015-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2015-2018, 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__gnu.ads b/gcc/ada/libgnarl/s-osinte__gnu.ads index 183c5b8..0482a4e 100644 --- a/gcc/ada/libgnarl/s-osinte__gnu.ads +++ b/gcc/ada/libgnarl/s-osinte__gnu.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2018, 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb index a9d46a0..84d5101 100644 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2018, AdaCore -- -- -- -- 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads index 28fb5ba..36c4b9c 100644 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2018, 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- -- diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb index 1c5dcc1..6a1bb86 100644 --- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads index 137f34b..9c75f29 100644 --- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads +++ b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2018, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- -- cgit v1.1 From d40800cfe589cf55e074ed151c7a607d5680997a Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Tue, 21 Aug 2018 14:44:25 +0000 Subject: [Ada] Add sa_messages.ad[sb] for SPARK 2014 These new source files will make it possible to build SPARK 2014 from a snapshot of GCC FSF sources. 2018-08-21 Pierre-Marie de Rodat gcc/ada/ * sa_messages.ads, sa_messages.adb: New source files. From-SVN: r263706 --- gcc/ada/ChangeLog | 4 + gcc/ada/sa_messages.adb | 539 ++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sa_messages.ads | 267 ++++++++++++++++++++++++ 3 files changed, 810 insertions(+) create mode 100644 gcc/ada/sa_messages.adb create mode 100644 gcc/ada/sa_messages.ads (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 792811f..9bbcc9d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2018-08-21 Pierre-Marie de Rodat + + * sa_messages.ads, sa_messages.adb: New source files. + 2018-08-03 Pierre-Marie de Rodat Reverts diff --git a/gcc/ada/sa_messages.adb b/gcc/ada/sa_messages.adb new file mode 100644 index 0000000..30ae48c --- /dev/null +++ b/gcc/ada/sa_messages.adb @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- C O D E P E E R / S P A R K -- +-- -- +-- Copyright (C) 2015-2018, AdaCore -- +-- -- +-- This 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. This software is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY 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 this software; see file -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Directories; use Ada.Directories; +with Ada.Strings.Unbounded.Hash; + +with Ada.Text_IO; use Ada.Text_IO; +with GNATCOLL.JSON; use GNATCOLL.JSON; + +package body SA_Messages is + + ----------------------- + -- Local subprograms -- + ----------------------- + + function "<" (Left, Right : SA_Message) return Boolean is + (if Left.Kind /= Right.Kind then + Left.Kind < Right.Kind + else + Left.Kind in Check_Kind + and then Left.Check_Result < Right.Check_Result); + + function "<" (Left, Right : Simple_Source_Location) return Boolean is + (if Left.File_Name /= Right.File_Name then + Left.File_Name < Right.File_Name + elsif Left.Line /= Right.Line then + Left.Line < Right.Line + else + Left.Column < Right.Column); + + function "<" (Left, Right : Source_Locations) return Boolean is + (if Left'Length /= Right'Length then + Left'Length < Right'Length + elsif Left'Length = 0 then + False + elsif Left (Left'Last) /= Right (Right'Last) then + Left (Left'Last) < Right (Right'Last) + else + Left (Left'First .. Left'Last - 1) < + Right (Right'First .. Right'Last - 1)); + + function "<" (Left, Right : Source_Location) return Boolean is + (Left.Locations < Right.Locations); + + function Base_Location + (Location : Source_Location) return Simple_Source_Location is + (Location.Locations (1)); + + function Hash (Key : SA_Message) return Hash_Type; + function Hash (Key : Source_Location) return Hash_Type; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Message_And_Location) return Boolean is + (if Left.Message = Right.Message + then Left.Location < Right.Location + else Left.Message < Right.Message); + + ------------ + -- Column -- + ------------ + + function Column (Location : Source_Location) return Column_Number is + (Base_Location (Location).Column); + + --------------- + -- File_Name -- + --------------- + + function File_Name (Location : Source_Location) return String is + (To_String (Base_Location (Location).File_Name)); + + function File_Name (Location : Source_Location) return Unbounded_String is + (Base_Location (Location).File_Name); + + ------------------------ + -- Enclosing_Instance -- + ------------------------ + + function Enclosing_Instance + (Location : Source_Location) return Source_Location_Or_Null is + (Count => Location.Count - 1, + Locations => Location.Locations (2 .. Location.Count)); + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Message_And_Location) return Hash_Type is + (Hash (Key.Message) + Hash (Key.Location)); + + function Hash (Key : SA_Message) return Hash_Type is + begin + return Result : Hash_Type := + Hash_Type'Mod (Message_Kind'Pos (Key.Kind)) + do + if Key.Kind in Check_Kind then + Result := Result + + Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result)); + end if; + end return; + end Hash; + + function Hash (Key : Source_Location) return Hash_Type is + begin + return Result : Hash_Type := Hash_Type'Mod (Key.Count) do + for Loc of Key.Locations loop + Result := Result + Hash (Loc.File_Name); + Result := Result + Hash_Type'Mod (Loc.Line); + Result := Result + Hash_Type'Mod (Loc.Column); + end loop; + end return; + end Hash; + + --------------- + -- Iteration -- + --------------- + + function Iteration (Location : Source_Location) return Iteration_Id is + (Base_Location (Location).Iteration); + + ---------- + -- Line -- + ---------- + + function Line (Location : Source_Location) return Line_Number is + (Base_Location (Location).Line); + + -------------- + -- Location -- + -------------- + + function Location + (Item : Message_And_Location) return Source_Location is + (Item.Location); + + ---------- + -- Make -- + ---------- + + function Make + (File_Name : String; + Line : Line_Number; + Column : Column_Number; + Iteration : Iteration_Id; + Enclosing_Instance : Source_Location_Or_Null) return Source_Location + is + begin + return Result : Source_Location + (Count => Enclosing_Instance.Count + 1) + do + Result.Locations (1) := + (File_Name => To_Unbounded_String (File_Name), + Line => Line, + Column => Column, + Iteration => Iteration); + + Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations; + end return; + end Make; + + ------------------ + -- Make_Msg_Loc -- + ------------------ + + function Make_Msg_Loc + (Msg : SA_Message; + Loc : Source_Location) return Message_And_Location + is + begin + return Message_And_Location'(Count => Loc.Count, + Message => Msg, + Location => Loc); + end Make_Msg_Loc; + + ------------- + -- Message -- + ------------- + + function Message (Item : Message_And_Location) return SA_Message is + (Item.Message); + + package Field_Names is + + -- A Source_Location value is represented in JSON as a two or three + -- field value having fields Message_Kind (a string) and Locations (an + -- array); if the Message_Kind indicates a check kind, then a third + -- field is present: Check_Result (a string). The element type of the + -- Locations array is a value having at least 4 fields: + -- File_Name (a string), Line (an integer), Column (an integer), + -- and Iteration_Kind (an integer); if the Iteration_Kind field + -- has the value corresponding to the enumeration literal Numbered, + -- then two additional integer fields are present, Iteration_Number + -- and Iteration_Of_Total. + + Check_Result : constant String := "Check_Result"; + Column : constant String := "Column"; + File_Name : constant String := "File_Name"; + Iteration_Kind : constant String := "Iteration_Kind"; + Iteration_Number : constant String := "Iteration_Number"; + Iteration_Of_Total : constant String := "Iteration_Total"; + Line : constant String := "Line"; + Locations : constant String := "Locations"; + Message_Kind : constant String := "Message_Kind"; + Messages : constant String := "Messages"; + end Field_Names; + + package body Writing is + File : File_Type; + -- The file to which output will be written (in Close, not in Write) + + Messages : JSON_Array; + -- Successive calls to Write append messages to this list + + ----------------------- + -- Local subprograms -- + ----------------------- + + function To_JSON_Array + (Locations : Source_Locations) return JSON_Array; + -- Represent a Source_Locations array as a JSON_Array + + function To_JSON_Value + (Location : Simple_Source_Location) return JSON_Value; + -- Represent a Simple_Source_Location as a JSON_Value + + ----------- + -- Close -- + ----------- + + procedure Close is + Value : constant JSON_Value := Create_Object; + + begin + -- only one field for now + Set_Field (Value, Field_Names.Messages, Messages); + Put_Line (File, Write (Item => Value, Compact => False)); + Clear (Messages); + Close (File => File); + end Close; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open return Boolean is (Is_Open (File)); + + ---------- + -- Open -- + ---------- + + procedure Open (File_Name : String) is + begin + Create (File => File, Mode => Out_File, Name => File_Name); + Clear (Messages); + end Open; + + ------------------- + -- To_JSON_Array -- + ------------------- + + function To_JSON_Array + (Locations : Source_Locations) return JSON_Array + is + begin + return Result : JSON_Array := Empty_Array do + for Location of Locations loop + Append (Result, To_JSON_Value (Location)); + end loop; + end return; + end To_JSON_Array; + + ------------------- + -- To_JSON_Value -- + ------------------- + + function To_JSON_Value + (Location : Simple_Source_Location) return JSON_Value + is + begin + return Result : constant JSON_Value := Create_Object do + Set_Field (Result, Field_Names.File_Name, Location.File_Name); + Set_Field (Result, Field_Names.Line, Integer (Location.Line)); + Set_Field (Result, Field_Names.Column, Integer (Location.Column)); + Set_Field (Result, Field_Names.Iteration_Kind, Integer'( + Iteration_Kind'Pos (Location.Iteration.Kind))); + + if Location.Iteration.Kind = Numbered then + Set_Field (Result, Field_Names.Iteration_Number, + Location.Iteration.Number); + Set_Field (Result, Field_Names.Iteration_Of_Total, + Location.Iteration.Of_Total); + end if; + end return; + end To_JSON_Value; + + ----------- + -- Write -- + ----------- + + procedure Write (Message : SA_Message; Location : Source_Location) is + Value : constant JSON_Value := Create_Object; + + begin + Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img); + + if Message.Kind in Check_Kind then + Set_Field + (Value, Field_Names.Check_Result, Message.Check_Result'Img); + end if; + + Set_Field + (Value, Field_Names.Locations, To_JSON_Array (Location.Locations)); + Append (Messages, Value); + end Write; + end Writing; + + package body Reading is + File : File_Type; + -- The file from which messages are read (in Open, not in Read) + + Messages : JSON_Array; + -- The list of messages that were read in from File + + Next_Index : Positive; + -- The index of the message in Messages which will be returned by the + -- next call to Get. + + Parse_Full_Path : Boolean := True; + -- if the full path or only the base name of the file should be parsed + + ----------- + -- Close -- + ----------- + + procedure Close is + begin + Clear (Messages); + Close (File); + end Close; + + ---------- + -- Done -- + ---------- + + function Done return Boolean is (Next_Index > Length (Messages)); + + --------- + -- Get -- + --------- + + function Get return Message_And_Location is + Value : constant JSON_Value := Get (Messages, Next_Index); + + function Get_Message (Kind : Message_Kind) return SA_Message; + -- Return SA_Message of given kind, filling in any non-discriminant + -- by reading from Value. + + function Make + (Location : Source_Location; + Message : SA_Message) return Message_And_Location; + -- Constructor + + function To_Location + (Encoded : JSON_Array; + Full_Path : Boolean) return Source_Location; + -- Decode a Source_Location from JSON_Array representation + + function To_Simple_Location + (Encoded : JSON_Value; + Full_Path : Boolean) return Simple_Source_Location; + -- Decode a Simple_Source_Location from JSON_Value representation + + ----------------- + -- Get_Message -- + ----------------- + + function Get_Message (Kind : Message_Kind) return SA_Message is + begin + -- If we had AI12-0086, then we could use aggregates here (which + -- would be better than field-by-field assignment for the usual + -- maintainability reasons). But we don't, so we won't. + + return Result : SA_Message (Kind => Kind) do + if Kind in Check_Kind then + Result.Check_Result := + SA_Check_Result'Value + (Get (Value, Field_Names.Check_Result)); + end if; + end return; + end Get_Message; + + ---------- + -- Make -- + ---------- + + function Make + (Location : Source_Location; + Message : SA_Message) return Message_And_Location + is + (Count => Location.Count, Message => Message, Location => Location); + + ----------------- + -- To_Location -- + ----------------- + + function To_Location + (Encoded : JSON_Array; + Full_Path : Boolean) return Source_Location is + begin + return Result : Source_Location (Count => Length (Encoded)) do + for I in Result.Locations'Range loop + Result.Locations (I) := + To_Simple_Location (Get (Encoded, I), Full_Path); + end loop; + end return; + end To_Location; + + ------------------------ + -- To_Simple_Location -- + ------------------------ + + function To_Simple_Location + (Encoded : JSON_Value; + Full_Path : Boolean) return Simple_Source_Location + is + function Get_Iteration_Id + (Kind : Iteration_Kind) return Iteration_Id; + -- Given the discriminant for an Iteration_Id value, return the + -- entire value. + + ---------------------- + -- Get_Iteration_Id -- + ---------------------- + + function Get_Iteration_Id (Kind : Iteration_Kind) + return Iteration_Id + is + begin + -- Initialize non-discriminant fields, if any + + return Result : Iteration_Id (Kind => Kind) do + if Kind = Numbered then + Result := + (Kind => Numbered, + Number => + Get (Encoded, Field_Names.Iteration_Number), + Of_Total => + Get (Encoded, Field_Names.Iteration_Of_Total)); + end if; + end return; + end Get_Iteration_Id; + + -- Local variables + + FN : constant Unbounded_String := + Get (Encoded, Field_Names.File_Name); + + -- Start of processing for To_Simple_Location + + begin + return + (File_Name => + (if Full_Path then + FN + else + To_Unbounded_String (Simple_Name (To_String (FN)))), + Line => + Line_Number (Integer'(Get (Encoded, Field_Names.Line))), + Column => + Column_Number (Integer'(Get (Encoded, Field_Names.Column))), + Iteration => + Get_Iteration_Id + (Kind => Iteration_Kind'Val (Integer'(Get + (Encoded, Field_Names.Iteration_Kind))))); + end To_Simple_Location; + + -- Start of processing for Get + + begin + Next_Index := Next_Index + 1; + + return Make + (Message => + Get_Message + (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))), + Location => + To_Location + (Get (Value, Field_Names.Locations), Parse_Full_Path)); + end Get; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open return Boolean is (Is_Open (File)); + + ---------- + -- Open -- + ---------- + + procedure Open (File_Name : String; Full_Path : Boolean := True) is + File_Text : Unbounded_String := Null_Unbounded_String; + + begin + Parse_Full_Path := Full_Path; + Open (File => File, Mode => In_File, Name => File_Name); + + -- File read here, not in Get, but that's an implementation detail + + while not End_Of_File (File) loop + Append (File_Text, Get_Line (File)); + end loop; + + Messages := Get (Read (File_Text), Field_Names.Messages); + Next_Index := 1; + end Open; + end Reading; + +end SA_Messages; diff --git a/gcc/ada/sa_messages.ads b/gcc/ada/sa_messages.ads new file mode 100644 index 0000000..93226a7 --- /dev/null +++ b/gcc/ada/sa_messages.ads @@ -0,0 +1,267 @@ +------------------------------------------------------------------------------ +-- C O D E P E E R / S P A R K -- +-- -- +-- Copyright (C) 2015-2018, AdaCore -- +-- -- +-- This 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. This software is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY 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 this software; see file -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Containers; use Ada.Containers; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +package SA_Messages is + + -- This package can be used for reading/writing a file containing a + -- sequence of static anaysis results. Each element can describe a runtime + -- check whose outcome has been statically determined, or it might be a + -- warning or diagnostic message. It is expected that typically CodePeer + -- will do the writing and SPARK will do the reading; this will allow SPARK + -- to get the benefit of CodePeer's analysis. + -- + -- Each item is represented as a pair consisting of a message and an + -- associated source location. Source locations may refer to a location + -- within the expansion of an instance of a generic; this is represented + -- by combining the corresponding location within the generic with the + -- location of the instance (repeated if the instance itself occurs within + -- a generic). In addition, the type Iteration_Id is intended for use in + -- distinguishing messages which refer to a specific iteration of a loop + -- (this case can arise, for example, if CodePeer chooses to unroll a + -- for-loop). This data structure is only general enough to support the + -- kinds of unrolling that are currently planned for CodePeer. For + -- example, an Iteration_Id can only identify an iteration of the nearest + -- enclosing loop of the associated File/Line/Column source location. + -- This is not a problem because CodePeer doesn't unroll loops which + -- contain other loops. + + type Message_Kind is ( + + -- Check kinds + + Array_Index_Check, + Divide_By_Zero_Check, + Tag_Check, + Discriminant_Check, + Range_Check, + Overflow_Check, + Assertion_Check, + + -- Warning kinds + + Suspicious_Range_Precondition_Warning, + Suspicious_First_Precondition_Warning, + Suspicious_Input_Warning, + Suspicious_Constant_Operation_Warning, + Unread_In_Out_Parameter_Warning, + Unassigned_In_Out_Parameter_Warning, + Non_Analyzed_Call_Warning, + Procedure_Does_Not_Return_Warning, + Check_Fails_On_Every_Call_Warning, + Unknown_Call_Warning, + Dead_Store_Warning, + Dead_Outparam_Store_Warning, + Potentially_Dead_Store_Warning, + Same_Value_Dead_Store_Warning, + Dead_Block_Warning, + Infinite_Loop_Warning, + Dead_Edge_Warning, + Plain_Dead_Edge_Warning, + True_Dead_Edge_Warning, + False_Dead_Edge_Warning, + True_Condition_Dead_Edge_Warning, + False_Condition_Dead_Edge_Warning, + Unrepeatable_While_Loop_Warning, + Dead_Block_Continuation_Warning, + Local_Lock_Of_Global_Object_Warning, + Analyzed_Module_Warning, + Non_Analyzed_Module_Warning, + Non_Analyzed_Procedure_Warning, + Incompletely_Analyzed_Procedure_Warning); + + -- Assertion_Check includes checks for user-defined PPCs (both specific + -- and class-wide), Assert pragma checks, subtype predicate checks, + -- type invariant checks (specific and class-wide), and checks for + -- implementation-defined assertions such as Assert_And_Cut, Assume, + -- Contract_Cases, Default_Initial_Condition, Initial_Condition, + -- Loop_Invariant, Loop_Variant, and Refined_Post. + -- + -- TBD: it might be nice to distinguish these different kinds of assertions + -- as is done in SPARK's VC_Kind enumeration type, but any distinction + -- which isn't already present in CP's BE_Message_Subkind enumeration type + -- would require more work on the CP side. + -- + -- The warning kinds are pretty much a copy of the set of + -- Be_Message_Subkind values for which CP's Is_Warning predicate returns + -- True; see descriptive comment for each in CP's message_kinds.ads . + + subtype Check_Kind is Message_Kind + range Array_Index_Check .. Assertion_Check; + subtype Warning_Kind is Message_Kind + range Message_Kind'Succ (Check_Kind'Last) .. Message_Kind'Last; + + -- Possible outcomes of the static analysis of a runtime check + -- + -- Not_Statically_Known_With_Low_Severity could be used instead of of + -- Not_Statically_Known if there is some reason to believe that (although + -- the tool couldn't prove it) the check is likely to always pass (in CP + -- terms, if the corresponding CP message has severity Low as opposed to + -- Medium). It's not clear yet whether SPARK will care about this + -- distinction. + + type SA_Check_Result is + (Statically_Known_Success, + Not_Statically_Known_With_Low_Severity, + Not_Statically_Known, + Statically_Known_Failure); + + type SA_Message (Kind : Message_Kind := Message_Kind'Last) is record + case Kind is + when Check_Kind => + Check_Result : SA_Check_Result; + + when Warning_Kind => + null; + end case; + end record; + + type Source_Location_Or_Null (<>) is private; + Null_Location : constant Source_Location_Or_Null; + subtype Source_Location is Source_Location_Or_Null with + Dynamic_Predicate => Source_Location /= Null_Location; + + type Line_Number is new Positive; + type Column_Number is new Positive; + + function File_Name (Location : Source_Location) return String; + function File_Name (Location : Source_Location) return Unbounded_String; + function Line (Location : Source_Location) return Line_Number; + function Column (Location : Source_Location) return Column_Number; + + type Iteration_Kind is (None, Initial, Subsequent, Numbered); + -- None is for the usual no-unrolling case. + -- Initial and Subsequent are for use in the case where only the first + -- iteration of a loop (or some part thereof, such as the termination + -- test of a while-loop) is unrolled. + -- Numbered is for use in the case where a for-loop with a statically + -- known number of iterations is fully unrolled. + + subtype Iteration_Number is Integer range 1 .. 255; + subtype Iteration_Total is Integer range 2 .. 255; + + type Iteration_Id (Kind : Iteration_Kind := None) is record + case Kind is + when Numbered => + Number : Iteration_Number; + Of_Total : Iteration_Total; + when others => + null; + end case; + end record; + + function Iteration (Location : Source_Location) return Iteration_Id; + + function Enclosing_Instance + (Location : Source_Location) return Source_Location_Or_Null; + -- For a source location occurring within the expansion of an instance of a + -- generic unit, the Line, Column, and File_Name selectors will indicate a + -- location within the generic; the Enclosing_Instance selector yields the + -- location of the declaration of the instance. + + function Make + (File_Name : String; + Line : Line_Number; + Column : Column_Number; + Iteration : Iteration_Id; + Enclosing_Instance : Source_Location_Or_Null) return Source_Location; + -- Constructor + + type Message_And_Location (<>) is private; + + function Location (Item : Message_And_Location) return Source_Location; + function Message (Item : Message_And_Location) return SA_Message; + + function Make_Msg_Loc + (Msg : SA_Message; + Loc : Source_Location) return Message_And_Location; + -- Selectors + + function "<" (Left, Right : Message_And_Location) return Boolean; + function Hash (Key : Message_And_Location) return Hash_Type; + -- Actuals for container instances + + File_Extension : constant String; -- ".json" (but could change in future) + -- Clients may wish to use File_Extension in constructing + -- File_Name parameters for calls to Open. + + package Writing is + function Is_Open return Boolean; + + procedure Open (File_Name : String) with + Precondition => not Is_Open, + Postcondition => Is_Open; + -- Behaves like Text_IO.Create with respect to error cases + + procedure Write (Message : SA_Message; Location : Source_Location); + + procedure Close with + Precondition => Is_Open, + Postcondition => not Is_Open; + -- Behaves like Text_IO.Close with respect to error cases + end Writing; + + package Reading is + function Is_Open return Boolean; + + procedure Open (File_Name : String; Full_Path : Boolean := True) with + Precondition => not Is_Open, + Postcondition => Is_Open; + -- Behaves like Text_IO.Open with respect to error cases + + function Done return Boolean with + Precondition => Is_Open; + + function Get return Message_And_Location with + Precondition => not Done; + + procedure Close with + Precondition => Is_Open, + Postcondition => not Is_Open; + -- Behaves like Text_IO.Close with respect to error cases + end Reading; + +private + type Simple_Source_Location is record + File_Name : Unbounded_String := Null_Unbounded_String; + Line : Line_Number := Line_Number'Last; + Column : Column_Number := Column_Number'Last; + Iteration : Iteration_Id := (Kind => None); + end record; + + type Source_Locations is + array (Natural range <>) of Simple_Source_Location; + + type Source_Location_Or_Null (Count : Natural) is record + Locations : Source_Locations (1 .. Count); + end record; + + Null_Location : constant Source_Location_Or_Null := + (Count => 0, Locations => (others => <>)); + + type Message_And_Location (Count : Positive) is record + Message : SA_Message; + Location : Source_Location (Count => Count); + end record; + + File_Extension : constant String := ".json"; +end SA_Messages; -- cgit v1.1 From b7e875ce96282a9c4ecc6cfd4f043c1039e5b7e3 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Tue, 21 Aug 2018 14:44:30 +0000 Subject: [Ada] Handle pragmas that come from aspects for GNATprove In GNATprove we appear to abuse a routine related to cross-references and expect it to deliver exact results, which is not what it was designed for. This patch is a temporary solution to avoid crashes in GNATprove; it doesn't affect the frontend or other backends, because this code is used exclusively by GNATprove (it is located in the frontend for technical reasons). No tests provided. 2018-08-21 Piotr Trojanek gcc/ada/ * lib-xref.ads, lib-xref-spark_specific.adb (Enclosing_Subprogram_Or_Library_Package): Now roughtly works for pragmas that come from aspect specifications. From-SVN: r263707 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/lib-xref-spark_specific.adb | 12 +++++++++++- gcc/ada/lib-xref.ads | 5 +++++ 3 files changed, 22 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9bbcc9d..dcbec9b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-08-21 Piotr Trojanek + + * lib-xref.ads, lib-xref-spark_specific.adb + (Enclosing_Subprogram_Or_Library_Package): Now roughtly works + for pragmas that come from aspect specifications. + 2018-08-21 Pierre-Marie de Rodat * sa_messages.ads, sa_messages.adb: New source files. diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 0ce834a..00fe71a 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -228,7 +228,17 @@ package body SPARK_Specific is end loop; if Nkind (Context) = N_Pragma then - Context := Parent (Context); + -- When used for cross-references then aspects might not be + -- yet linked to pragmas; when used for AST navigation in + -- GNATprove this routine is expected to follow those links. + + if From_Aspect_Specification (Context) then + Context := Corresponding_Aspect (Context); + pragma Assert (Nkind (Context) = N_Aspect_Specification); + Context := Entity (Context); + else + Context := Parent (Context); + end if; end if; when N_Entry_Body diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 5c7a086..903e64e 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -632,6 +632,11 @@ package Lib.Xref is -- Return the closest enclosing subprogram or library-level package. -- This ensures that GNATprove can distinguish local variables from -- global variables. + -- + -- ??? This routine should only be used for processing related to + -- cross-references, where it might return wrong result but must avoid + -- crashes on ill-formed source code. It is wrong to use it where exact + -- result is needed. procedure Generate_Dereference (N : Node_Id; -- cgit v1.1 From f20b5ef46d7338e626286721a74e3fd3385e8be0 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 21 Aug 2018 14:44:35 +0000 Subject: [Ada] Enumeration types with non-standard representation The compiler may report errors on enumeration types with non-standard representation (i.e. at least one literal has a representation value different from its 'Pos value) processing attribute 'Enum_Rep. It may also generate wrong code for the evaluation of 'Enum_Rep raising Constraint_Error at runtime. 2018-08-21 Javier Miranda gcc/ada/ * checks.ads (Determine_Range): Adding documentation. * checks.adb (Determine_Range): Don't deal with enumerated types with non-standard representation. (Convert_And_Check_Range): For conversion of enumeration types with non standard representation to an integer type perform a direct conversion to the target integer type. gcc/testsuite/ * gnat.dg/enum4.adb: New testcase. From-SVN: r263708 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/checks.adb | 39 ++++++++++++++++++++++++++++++++++----- gcc/ada/checks.ads | 18 ++++++++++-------- 3 files changed, 53 insertions(+), 13 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dcbec9b..1161394 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-08-21 Javier Miranda + + * checks.ads (Determine_Range): Adding documentation. + * checks.adb (Determine_Range): Don't deal with enumerated types + with non-standard representation. + (Convert_And_Check_Range): For conversion of enumeration types + with non standard representation to an integer type perform a + direct conversion to the target integer type. + 2018-08-21 Piotr Trojanek * lib-xref.ads, lib-xref-spark_specific.adb diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 871f1f7..f399cda 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4490,6 +4490,11 @@ package body Checks is or else not Is_Discrete_Type (Typ) + -- Don't deal with enumerated types with non-standard representation + + or else (Is_Enumeration_Type (Typ) + and then Present (Enum_Pos_To_Rep (Base_Type (Typ)))) + -- Ignore type for which an error has been posted, since range in -- this case may well be a bogosity deriving from the error. Also -- ignore if error posted on the reference node. @@ -6758,9 +6763,36 @@ package body Checks is ----------------------------- procedure Convert_And_Check_Range is - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Conv_Node : Node_Id; begin + -- For enumeration types with non-standard representation this is a + -- direct conversion from the enumeration type to the target integer + -- type, which is treated by the back end as a normal integer type + -- conversion, treating the enumeration type as an integer, which is + -- exactly what we want. We set Conversion_OK to make sure that the + -- analyzer does not complain about what otherwise might be an + -- illegal conversion. + + if Is_Enumeration_Type (Source_Base_Type) + and then Present (Enum_Pos_To_Rep (Source_Base_Type)) + and then Is_Integer_Type (Target_Base_Type) + then + Conv_Node := + OK_Convert_To ( + Typ => Target_Base_Type, + Expr => Duplicate_Subexpr (N)); + + -- Common case + + else + Conv_Node := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), + Expression => Duplicate_Subexpr (N)); + end if; + -- We make a temporary to hold the value of the converted value -- (converted to the base type), and then do the test against this -- temporary. The conversion itself is replaced by an occurrence of @@ -6776,10 +6808,7 @@ package body Checks is Defining_Identifier => Tnn, Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), Constant_Present => True, - Expression => - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), - Expression => Duplicate_Subexpr (N))), + Expression => Conv_Node), Make_Raise_Constraint_Error (Loc, Condition => diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 85affc4..f2eed3d 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -310,14 +310,16 @@ package Checks is -- then OK is True on return, and Lo and Hi are set to a conservative -- estimate of the possible range of values of N. Thus if OK is True on -- return, the value of the subexpression N is known to lie in the range - -- Lo .. Hi (inclusive). If the expression is not of a discrete type, or - -- some kind of error condition is detected, then OK is False on exit, and - -- Lo/Hi are set to No_Uint. Thus the significance of OK being False on - -- return is that no useful information is available on the range of the - -- expression. Assume_Valid determines whether the processing is allowed to - -- assume that values are in range of their subtypes. If it is set to True, - -- then this assumption is valid, if False, then processing is done using - -- base types to allow invalid values. + -- Lo .. Hi (inclusive). For enumeration and character literals the values + -- returned are the Pos value in the relevant enumeration type. If the + -- expression is not of a discrete type, or some kind of error condition + -- is detected, then OK is False on exit, and Lo/Hi are set to No_Uint. + -- Thus the significance of OK being False on return is that no useful + -- information is available on the range of the expression. Assume_Valid + -- determines whether the processing is allowed to assume that values are + -- in range of their subtypes. If it is set to True, then this assumption + -- is valid, if False, then processing is done using base types to allow + -- invalid values. procedure Determine_Range_R (N : Node_Id; -- cgit v1.1 From d8251d001b3507ffb80b26f4d17f1daa99a5dc4a Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 21 Aug 2018 14:44:41 +0000 Subject: [Ada] Dynamically resizable, load factor-based hash table This patch introduces a dynamically resizable, load factor-based hash table in unit GNAT.Dynamic_HTables. 2018-08-21 Hristian Kirtchev gcc/ada/ * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package Dynamic_HTable. gcc/testsuite/ * gnat.dg/dynhash.adb: New testcase. From-SVN: r263709 --- gcc/ada/ChangeLog | 5 + gcc/ada/libgnat/g-dynhta.adb | 834 ++++++++++++++++++++++++++++++++++++++++++- gcc/ada/libgnat/g-dynhta.ads | 310 ++++++++++++++-- 3 files changed, 1116 insertions(+), 33 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1161394..31420a3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-08-21 Hristian Kirtchev + + * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package + Dynamic_HTable. + 2018-08-21 Javier Miranda * checks.ads (Determine_Range): Adding documentation. diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index a6e2734..b093e79 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -38,11 +38,10 @@ package body GNAT.Dynamic_HTables is ------------------- package body Static_HTable is - function Get_Non_Null (T : Instance) return Elmt_Ptr; -- Returns Null_Ptr if Iterator_Started is False or if the Table is - -- empty. Returns Iterator_Ptr if non null, or the next non null - -- element in table if any. + -- empty. Returns Iterator_Ptr if non null, or the next non null element + -- in table if any. --------- -- Get -- @@ -363,7 +362,834 @@ package body GNAT.Dynamic_HTables is begin E.Next := Next; end Set_Next; - end Simple_HTable; + -------------------- + -- Dynamic_HTable -- + -------------------- + + package body Dynamic_HTable is + Minimum_Size : constant Bucket_Range_Type := 32; + -- Minimum size of the buckets + + Safe_Compression_Size : constant Bucket_Range_Type := + Minimum_Size * Compression_Factor; + -- Maximum safe size for hash table compression. Beyond this size, a + -- compression will violate the minimum size constraint on the buckets. + + Safe_Expansion_Size : constant Bucket_Range_Type := + Bucket_Range_Type'Last / Expansion_Factor; + -- Maximum safe size for hash table expansion. Beyond this size, an + -- expansion will overflow the buckets. + + procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr); + pragma Inline (Destroy_Buckets); + -- Destroy all nodes within buckets Bkts + + procedure Detach (Nod : Node_Ptr); + pragma Inline (Detach); + -- Detach node Nod from the bucket it resides in + + procedure Ensure_Circular (Head : Node_Ptr); + pragma Inline (Ensure_Circular); + -- Ensure that dummy head Head is circular with respect to itself + + procedure Ensure_Created (T : Instance); + pragma Inline (Ensure_Created); + -- Verify that hash table T is created. Raise Not_Created if this is not + -- the case. + + procedure Ensure_Unlocked (T : Instance); + pragma Inline (Ensure_Unlocked); + -- Verify that hash table T is unlocked. Raise Table_Locked if this is + -- not the case. + + function Find_Bucket + (Bkts : Bucket_Table_Ptr; + Key : Key_Type) return Node_Ptr; + pragma Inline (Find_Bucket); + -- Find the bucket among buckets Bkts which corresponds to key Key, and + -- return its dummy head. + + function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr; + pragma Inline (Find_Node); + -- Traverse a bucket indicated by dummy head Head to determine whether + -- there exists a node with key Key. If such a node exists, return it, + -- otherwise return null. + + procedure First_Valid_Node + (T : Instance; + Low_Bkt : Bucket_Range_Type; + High_Bkt : Bucket_Range_Type; + Idx : out Bucket_Range_Type; + Nod : out Node_Ptr); + pragma Inline (First_Valid_Node); + -- Find the first valid node in the buckets of hash table T constrained + -- by the range Low_Bkt .. High_Bkt. If such a node exists, return its + -- bucket index in Idx and reference in Nod. If no such node exists, + -- Idx is set to 0 and Nod to null. + + procedure Free is + new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr); + + procedure Free is + new Ada.Unchecked_Deallocation (Hash_Table, Instance); + + procedure Free is + new Ada.Unchecked_Deallocation (Node, Node_Ptr); + + function Is_Valid (Iter : Iterator) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether iterator Iter refers to a valid key-value pair + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether node Nod is non-null and does not refer to dummy + -- head Head, thus making it valid. + + function Load_Factor (T : Instance) return Threshold_Type; + pragma Inline (Load_Factor); + -- Calculate the load factor of hash table T + + procedure Lock (T : Instance); + pragma Inline (Lock); + -- Lock all mutation functionality of hash table T + + procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type); + pragma Inline (Mutate_And_Rehash); + -- Replace the buckets of hash table T with a new set of buckets of size + -- Size. Rehash all key-value pairs from the old to the new buckets. + + procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr); + pragma Inline (Prepend); + -- Insert node Nod immediately after dummy head Head + + procedure Unlock (T : Instance); + pragma Inline (Unlock); + -- Unlock all mutation functionality of hash table T + + ------------ + -- Create -- + ------------ + + function Create (Initial_Size : Bucket_Range_Type) return Instance is + Size : constant Bucket_Range_Type := + Bucket_Range_Type'Max (Initial_Size, Minimum_Size); + -- Ensure that the buckets meet a minimum size + + T : constant Instance := new Hash_Table; + + begin + T.Buckets := new Bucket_Table (0 .. Size - 1); + T.Initial_Size := Size; + + return T; + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (T : Instance; Key : Key_Type) is + procedure Compress; + pragma Inline (Compress); + -- Determine whether hash table T requires compression, and if so, + -- half its size. + + -------------- + -- Compress -- + -------------- + + procedure Compress is + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + Old_Size : constant Bucket_Range_Type := T.Buckets'Length; + + begin + -- The ratio of pairs to buckets is under the desited threshold. + -- Compress the hash table only when there is still room to do so. + + if Load_Factor (T) < Compression_Threshold + and then Old_Size >= Safe_Compression_Size + then + Mutate_And_Rehash (T, Old_Size / Compression_Factor); + end if; + end Compress; + + -- Local variables + + Head : Node_Ptr; + Nod : Node_Ptr; + + -- Start of processing for Delete + + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Try to find a node in the bucket which matches the key + + Nod := Find_Node (Head, Key); + + -- If such a node exists, remove it from the bucket and deallocate it + + if Is_Valid (Nod, Head) then + Detach (Nod); + Free (Nod); + + T.Pairs := T.Pairs - 1; + + -- Compress the hash table if the load factor drops below + -- Compression_Threshold. + + Compress; + end if; + end Delete; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (T : in out Instance) is + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Destroy all nodes in all buckets + + Destroy_Buckets (T.Buckets); + Free (T.Buckets); + Free (T); + end Destroy; + + --------------------- + -- Destroy_Buckets -- + --------------------- + + procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr) is + procedure Destroy_Bucket (Head : Node_Ptr); + pragma Inline (Destroy_Bucket); + -- Destroy all nodes in a bucket with dummy head Head + + -------------------- + -- Destroy_Bucket -- + -------------------- + + procedure Destroy_Bucket (Head : Node_Ptr) is + Nod : Node_Ptr; + + begin + -- Destroy all valid nodes which follow the dummy head + + while Is_Valid (Head.Next, Head) loop + Nod := Head.Next; + + Detach (Nod); + Free (Nod); + end loop; + end Destroy_Bucket; + + -- Start of processing for Destroy_Buckets + + begin + pragma Assert (Bkts /= null); + + for Scan_Idx in Bkts'Range loop + Destroy_Bucket (Bkts (Scan_Idx)'Access); + end loop; + end Destroy_Buckets; + + ------------ + -- Detach -- + ------------ + + procedure Detach (Nod : Node_Ptr) is + pragma Assert (Nod /= null); + + Next : constant Node_Ptr := Nod.Next; + Prev : constant Node_Ptr := Nod.Prev; + + begin + pragma Assert (Next /= null); + pragma Assert (Prev /= null); + + Prev.Next := Next; + Next.Prev := Prev; + + Nod.Next := null; + Nod.Prev := null; + end Detach; + + --------------------- + -- Ensure_Circular -- + --------------------- + + procedure Ensure_Circular (Head : Node_Ptr) is + pragma Assert (Head /= null); + + begin + if Head.Next = null and then Head.Prev = null then + Head.Next := Head; + Head.Prev := Head; + end if; + end Ensure_Circular; + + -------------------- + -- Ensure_Created -- + -------------------- + + procedure Ensure_Created (T : Instance) is + begin + if T = null then + raise Not_Created; + end if; + end Ensure_Created; + + --------------------- + -- Ensure_Unlocked -- + --------------------- + + procedure Ensure_Unlocked (T : Instance) is + begin + pragma Assert (T /= null); + + -- The hash table has at least one outstanding iterator + + if T.Locked > 0 then + raise Table_Locked; + end if; + end Ensure_Unlocked; + + ----------------- + -- Find_Bucket -- + ----------------- + + function Find_Bucket + (Bkts : Bucket_Table_Ptr; + Key : Key_Type) return Node_Ptr + is + pragma Assert (Bkts /= null); + + Idx : constant Bucket_Range_Type := Hash (Key) mod Bkts'Length; + + begin + return Bkts (Idx)'Access; + end Find_Bucket; + + --------------- + -- Find_Node -- + --------------- + + function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- Traverse the nodes of the bucket, looking for a key-value pair + -- with the same key. + + Nod := Head.Next; + while Is_Valid (Nod, Head) loop + if Equivalent_Keys (Nod.Key, Key) then + return Nod; + end if; + + Nod := Nod.Next; + end loop; + + return null; + end Find_Node; + + ---------------------- + -- First_Valid_Node -- + ---------------------- + + procedure First_Valid_Node + (T : Instance; + Low_Bkt : Bucket_Range_Type; + High_Bkt : Bucket_Range_Type; + Idx : out Bucket_Range_Type; + Nod : out Node_Ptr) + is + Head : Node_Ptr; + + begin + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + -- Assume that no valid node exists + + Idx := 0; + Nod := null; + + -- Examine the buckets of the hash table within the requested range, + -- looking for the first valid node. + + for Scan_Idx in Low_Bkt .. High_Bkt loop + Head := T.Buckets (Scan_Idx)'Access; + + -- The bucket contains at least one valid node, return the first + -- such node. + + if Is_Valid (Head.Next, Head) then + Idx := Scan_Idx; + Nod := Head.Next; + return; + end if; + end loop; + end First_Valid_Node; + + --------- + -- Get -- + --------- + + function Get (T : Instance; Key : Key_Type) return Value_Type is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Try to find a node in the bucket which matches the key + + Nod := Find_Node (Head, Key); + + -- If such a node exists, return the value of the key-value pair + + if Is_Valid (Nod, Head) then + return Nod.Value; + end if; + + return No_Value; + end Get; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Iterator) return Boolean is + Is_OK : constant Boolean := Is_Valid (Iter); + T : constant Instance := Iter.Table; + + begin + pragma Assert (T /= null); + + -- The iterator is no longer valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the hash table + -- because the iterator cannot be advanced any further. + + if not Is_OK then + Unlock (T); + end if; + + return Is_OK; + end Has_Next; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Iter : Iterator) return Boolean is + begin + -- The invariant of Iterate and Next ensures that the iterator always + -- refers to a valid node if there exists one. + + return Iter.Nod /= null; + end Is_Valid; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is + begin + -- A node is valid if it is non-null, and does not refer to the dummy + -- head of some bucket. + + return Nod /= null and then Nod /= Head; + end Is_Valid; + + ------------- + -- Iterate -- + ------------- + + function Iterate (T : Instance) return Iterator is + Iter : Iterator; + + begin + Ensure_Created (T); + pragma Assert (T.Buckets /= null); + + -- Initialize the iterator to reference the first valid node in + -- the full range of hash table buckets. If no such node exists, + -- the iterator is left in a state which does not allow it to + -- advance. + + First_Valid_Node + (T => T, + Low_Bkt => T.Buckets'First, + High_Bkt => T.Buckets'Last, + Idx => Iter.Idx, + Nod => Iter.Nod); + + -- Associate the iterator with the hash table to allow for future + -- mutation functionality unlocking. + + Iter.Table := T; + + -- Lock all mutation functionality of the hash table while it is + -- being iterated on. + + Lock (T); + + return Iter; + end Iterate; + + ----------------- + -- Load_Factor -- + ----------------- + + function Load_Factor (T : Instance) return Threshold_Type is + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + begin + -- The load factor is the ratio of key-value pairs to buckets + + return Threshold_Type (T.Pairs) / Threshold_Type (T.Buckets'Length); + end Load_Factor; + + ---------- + -- Lock -- + ---------- + + procedure Lock (T : Instance) is + begin + -- The hash table may be locked multiple times if multiple iterators + -- are operating over it. + + T.Locked := T.Locked + 1; + end Lock; + + ----------------------- + -- Mutate_And_Rehash -- + ----------------------- + + procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type) is + procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr); + pragma Inline (Rehash); + -- Remove all nodes from buckets From and rehash them into buckets To + + procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr); + pragma Inline (Rehash_Bucket); + -- Detach all nodes starting from dummy head Head and rehash them + -- into To. + + procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr); + pragma Inline (Rehash_Node); + -- Rehash node Nod into To + + ------------ + -- Rehash -- + ------------ + + procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr) is + begin + pragma Assert (From /= null); + pragma Assert (To /= null); + + for Scan_Idx in From'Range loop + Rehash_Bucket (From (Scan_Idx)'Access, To); + end loop; + end Rehash; + + ------------------- + -- Rehash_Bucket -- + ------------------- + + procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- Detach all nodes which follow the dummy head + + while Is_Valid (Head.Next, Head) loop + Nod := Head.Next; + + Detach (Nod); + Rehash_Node (Nod, To); + end loop; + end Rehash_Bucket; + + ----------------- + -- Rehash_Node -- + ----------------- + + procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is + pragma Assert (Nod /= null); + + Head : Node_Ptr; + + begin + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (To, Nod.Key); + + -- Ensure that the dummy head of an empty bucket is circular with + -- respect to itself. + + Ensure_Circular (Head); + + -- Prepend the node to the bucket + + Prepend (Nod, Head); + end Rehash_Node; + + -- Local declarations + + Old_Bkts : Bucket_Table_Ptr; + + -- Start of processing for Mutate_And_Rehash + + begin + pragma Assert (T /= null); + + Old_Bkts := T.Buckets; + T.Buckets := new Bucket_Table (0 .. Size - 1); + + -- Transfer and rehash all key-value pairs from the old buckets to + -- the new buckets. + + Rehash (From => Old_Bkts, To => T.Buckets); + Free (Old_Bkts); + end Mutate_And_Rehash; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Iterator; Key : out Key_Type) is + Is_OK : constant Boolean := Is_Valid (Iter); + Saved : constant Node_Ptr := Iter.Nod; + T : constant Instance := Iter.Table; + Head : Node_Ptr; + + begin + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + -- The iterator is no longer valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the hash table as + -- the iterator cannot be advanced any further. + + if not Is_OK then + Unlock (T); + raise Iterator_Exhausted; + end if; + + -- Advance to the next node along the same bucket + + Iter.Nod := Iter.Nod.Next; + Head := T.Buckets (Iter.Idx)'Access; + + -- If the new node is no longer valid, then this indicates that the + -- current bucket has been exhausted. Advance to the next valid node + -- within the remaining range of buckets. If no such node exists, the + -- iterator is left in a state which does not allow it to advance. + + if not Is_Valid (Iter.Nod, Head) then + First_Valid_Node + (T => T, + Low_Bkt => Iter.Idx + 1, + High_Bkt => T.Buckets'Last, + Idx => Iter.Idx, + Nod => Iter.Nod); + end if; + + Key := Saved.Key; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is + pragma Assert (Nod /= null); + pragma Assert (Head /= null); + + Next : constant Node_Ptr := Head.Next; + + begin + Head.Next := Nod; + Next.Prev := Nod; + + Nod.Next := Next; + Nod.Prev := Head; + end Prepend; + + --------- + -- Put -- + --------- + + procedure Put + (T : Instance; + Key : Key_Type; + Value : Value_Type) + is + procedure Expand; + pragma Inline (Expand); + -- Determine whether hash table T requires expansion, and if so, + -- double its size. + + procedure Prepend_Or_Replace (Head : Node_Ptr); + pragma Inline (Prepend_Or_Replace); + -- Update the value of a node within a bucket with dummy head Head + -- whose key is Key to Value. If there is no such node, prepend a new + -- key-value pair to the bucket. + + ------------ + -- Expand -- + ------------ + + procedure Expand is + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + Old_Size : constant Bucket_Range_Type := T.Buckets'Length; + + begin + -- The ratio of pairs to buckets is over the desited threshold. + -- Expand the hash table only when there is still room to do so. + + if Load_Factor (T) > Expansion_Threshold + and then Old_Size <= Safe_Expansion_Size + then + Mutate_And_Rehash (T, Old_Size * Expansion_Factor); + end if; + end Expand; + + ------------------------ + -- Prepend_Or_Replace -- + ------------------------ + + procedure Prepend_Or_Replace (Head : Node_Ptr) is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- If the bucket containst at least one valid node, then there is + -- a chance that a node with the same key as Key exists. If this + -- is the case, the value of that node must be updated. + + Nod := Head.Next; + while Is_Valid (Nod, Head) loop + if Equivalent_Keys (Nod.Key, Key) then + Nod.Value := Value; + return; + end if; + + Nod := Nod.Next; + end loop; + + -- At this point the bucket is either empty, or none of the nodes + -- match key Key. Prepend a new key-value pair. + + Nod := new Node'(Key, Value, null, null); + + Prepend (Nod, Head); + end Prepend_Or_Replace; + + -- Local variables + + Head : Node_Ptr; + + -- Start of processing for Put + + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Ensure that the dummy head of an empty bucket is circular with + -- respect to itself. + + Ensure_Circular (Head); + + -- In case the bucket already contains a node with the same key, + -- replace its value, otherwise prepend a new key-value pair. + + Prepend_Or_Replace (Head); + + T.Pairs := T.Pairs + 1; + + -- Expand the hash table if the ratio of pairs to buckets goes over + -- Expansion_Threshold. + + Expand; + end Put; + + ----------- + -- Reset -- + ----------- + + procedure Reset (T : Instance) is + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Destroy all nodes in all buckets + + Destroy_Buckets (T.Buckets); + Free (T.Buckets); + + -- Recreate the buckets using the original size from creation time + + T.Buckets := new Bucket_Table (0 .. T.Initial_Size - 1); + T.Pairs := 0; + end Reset; + + ---------- + -- Size -- + ---------- + + function Size (T : Instance) return Pair_Count_Type is + begin + Ensure_Created (T); + + return T.Pairs; + end Size; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (T : Instance) is + begin + -- The hash table may be locked multiple times if multiple iterators + -- are operating over it. + + T.Locked := T.Locked - 1; + end Unlock; + end Dynamic_HTable; + end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index ea331c0..41574fd 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -31,13 +31,11 @@ -- Hash table searching routines --- This package contains three separate packages. The Simple_HTable package +-- This package contains two separate packages. The Simple_HTable package -- provides a very simple abstraction that associates one element to one key -- value and takes care of all allocations automatically using the heap. The -- Static_HTable package provides a more complex interface that allows full --- control over allocation. The Load_Factor_HTable package provides a more --- complex abstraction where collisions are resolved by chaining, and the --- table grows by a percentage after the load factor has been exceeded. +-- control over allocation. -- This package provides a facility similar to that of GNAT.HTable, except -- that this package declares types that can be used to define dynamic @@ -48,6 +46,8 @@ -- GNAT.HTable to keep as much coherency as possible between these two -- related units. +pragma Compiler_Unit_Warning; + package GNAT.Dynamic_HTables is ------------------- @@ -85,40 +85,38 @@ package GNAT.Dynamic_HTables is Null_Ptr : Elmt_Ptr; -- The null value of the Elmt_Ptr type + with function Next (E : Elmt_Ptr) return Elmt_Ptr; with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - with function Next (E : Elmt_Ptr) return Elmt_Ptr; -- The type must provide an internal link for the sake of the -- staticness of the HTable. type Key is limited private; with function Get_Key (E : Elmt_Ptr) return Key; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; + with function Hash (F : Key) return Header_Num; + with function Equal (F1 : Key; F2 : Key) return Boolean; package Static_HTable is - type Instance is private; Nil : constant Instance; procedure Reset (T : in out Instance); - -- Resets the hash table by releasing all memory associated with - -- it. The hash table can safely be reused after this call. For the - -- most common case where Elmt_Ptr is an access type, and Null_Ptr is - -- null, this is only needed if the same table is reused in a new - -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is - -- other than null, then Reset must be called before the first use of - -- the hash table. + -- Resets the hash table by releasing all memory associated with it. The + -- hash table can safely be reused after this call. For the most common + -- case where Elmt_Ptr is an access type, and Null_Ptr is null, this is + -- only needed if the same table is reused in a new context. If Elmt_Ptr + -- is other than an access type, or Null_Ptr is other than null, then + -- Reset must be called before the first use of the hash table. procedure Set (T : in out Instance; E : Elmt_Ptr); -- Insert the element pointer in the HTable function Get (T : Instance; K : Key) return Elmt_Ptr; - -- Returns the latest inserted element pointer with the given Key - -- or null if none. + -- Returns the latest inserted element pointer with the given Key or + -- null if none. procedure Remove (T : Instance; K : Key); - -- Removes the latest inserted element pointer associated with the - -- given key if any, does nothing if none. + -- Removes the latest inserted element pointer associated with the given + -- key if any, does nothing if none. function Get_First (T : Instance) return Elmt_Ptr; -- Returns Null_Ptr if the Htable is empty, otherwise returns one @@ -126,11 +124,11 @@ package GNAT.Dynamic_HTables is -- function will return the same element. function Get_Next (T : Instance) return Elmt_Ptr; - -- Returns an unspecified element that has not been returned by the - -- same function since the last call to Get_First or Null_Ptr if - -- there is no such element or Get_First has never been called. If - -- there is no call to 'Set' in between Get_Next calls, all the - -- elements of the Htable will be traversed. + -- Returns an unspecified element that has not been returned by the same + -- function since the last call to Get_First or Null_Ptr if there is no + -- such element or Get_First has never been called. If there is no call + -- to 'Set' in between Get_Next calls, all the elements of the Htable + -- will be traversed. private type Table_Type is array (Header_Num) of Elmt_Ptr; @@ -169,11 +167,10 @@ package GNAT.Dynamic_HTables is -- a given key type Key is private; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; + with function Hash (F : Key) return Header_Num; + with function Equal (F1 : Key; F2 : Key) return Boolean; package Simple_HTable is - type Instance is private; Nil : constant Instance; @@ -233,7 +230,6 @@ package GNAT.Dynamic_HTables is -- same restrictions apply as Get_Next. private - type Element_Wrapper; type Elmt_Ptr is access all Element_Wrapper; type Element_Wrapper is record @@ -260,7 +256,263 @@ package GNAT.Dynamic_HTables is type Instance is new Tab.Instance; Nil : constant Instance := Instance (Tab.Nil); - end Simple_HTable; + -------------------- + -- Dynamic_HTable -- + -------------------- + + -- The following package offers a hash table abstraction with the following + -- characteristics: + -- + -- * Dynamic resizing based on load factor. + -- * Creation of multiple instances, of different sizes. + -- * Iterable keys. + -- + -- This type of hash table is best used in scenarios where the size of the + -- key set is not known. The dynamic resizing aspect allows for performance + -- to remain within reasonable bounds as the size of the key set grows. + -- + -- The following use pattern must be employed when operating this table: + -- + -- Table : Instance := Create (); + -- + -- + -- + -- Destroy (Table); + -- + -- The destruction of the table reclaims all storage occupied by it. + + -- The following type denotes the underlying range of the hash table + -- buckets. + + type Bucket_Range_Type is mod 2 ** 32; + + -- The following type denotes the multiplicative factor used in expansion + -- and compression of the hash table. + + subtype Factor_Type is Bucket_Range_Type range 2 .. 100; + + -- The following type denotes the number of key-value pairs stored in the + -- hash table. + + type Pair_Count_Type is range 0 .. 2 ** 31 - 1; + + -- The following type denotes the threshold range used in expansion and + -- compression of the hash table. + + subtype Threshold_Type is Long_Float range 0.0 .. Long_Float'Last; + + generic + type Key_Type is private; + type Value_Type is private; + -- The types of the key-value pairs stored in the hash table + + No_Value : Value_Type; + -- An indicator for a non-existent value + + Expansion_Threshold : Threshold_Type; + Expansion_Factor : Factor_Type; + -- Once the load factor goes over Expansion_Threshold, the size of the + -- buckets is increased using the formula + -- + -- New_Size = Old_Size * Expansion_Factor + -- + -- An Expansion_Threshold of 1.5 and Expansion_Factor of 2 indicate that + -- the size of the buckets will be doubled once the load factor exceeds + -- 1.5. + + Compression_Threshold : Threshold_Type; + Compression_Factor : Factor_Type; + -- Once the load factor drops below Compression_Threshold, the size of + -- the buckets is decreased using the formula + -- + -- New_Size = Old_Size / Compression_Factor + -- + -- A Compression_Threshold of 0.5 and Compression_Factor of 2 indicate + -- that the size of the buckets will be halved once the load factor + -- drops below 0.5. + + with function Equivalent_Keys + (Left : Key_Type; + Right : Key_Type) return Boolean; + -- Determine whether two keys are equivalent + + with function Hash (Key : Key_Type) return Bucket_Range_Type; + -- Map an arbitrary key into the range of buckets + + package Dynamic_HTable is + + ---------------------- + -- Table operations -- + ---------------------- + + -- The following type denotes a hash table handle. Each instance must be + -- created using routine Create. + + type Instance is private; + Nil : constant Instance; + + Not_Created : exception; + -- This exception is raised when the hash table has not been created by + -- routine Create, and an attempt is made to read or mutate its state. + + Table_Locked : exception; + -- This exception is raised when the hash table is being iterated on, + -- and an attempt is made to mutate its state. + + function Create (Initial_Size : Bucket_Range_Type) return Instance; + -- Create a new table with bucket capacity Initial_Size. This routine + -- must be called at the start of a hash table's lifetime. + + procedure Delete (T : Instance; Key : Key_Type); + -- Delete the value which corresponds to key Key from hash table T. The + -- routine has no effect if the value is not present in the hash table. + -- This action will raise Table_Locked if the hash table has outstanding + -- iterators. If the load factor drops below Compression_Threshold, the + -- size of the buckets is decreased by Copression_Factor. + + procedure Destroy (T : in out Instance); + -- Destroy the contents of hash table T, rendering it unusable. This + -- routine must be called at the end of a hash table's lifetime. This + -- action will raise Table_Locked if the hash table has outstanding + -- iterators. + + function Get (T : Instance; Key : Key_Type) return Value_Type; + -- Obtain the value which corresponds to key Key from hash table T. If + -- the value does not exist, return No_Value. + + procedure Put + (T : Instance; + Key : Key_Type; + Value : Value_Type); + -- Associate value Value with key Key in hash table T. If the table + -- already contains a mapping of the same key to a previous value, the + -- previous value is overwritten. This action will raise Table_Locked + -- if the hash table has outstanding iterators. If the load factor goes + -- over Expansion_Threshold, the size of the buckets is increased by + -- Expansion_Factor. + + procedure Reset (T : Instance); + -- Destroy the contents of hash table T, and reset it to its initial + -- created state. This action will raise Table_Locked if the hash table + -- has outstanding iterators. + + function Size (T : Instance) return Pair_Count_Type; + -- Obtain the number of key-value pairs in hash table T + + ------------------------- + -- Iterator operations -- + ------------------------- + + -- The following type represents a key iterator. An iterator locks + -- all mutation operations, and unlocks them once it is exhausted. + -- The iterator must be used with the following pattern: + -- + -- Iter := Iterate (My_Table); + -- while Has_Next (Iter) loop + -- Key := Next (Iter); + -- . . . + -- end loop; + -- + -- It is possible to advance the iterator by using Next only, however + -- this risks raising Iterator_Exhausted. + + type Iterator is private; + + Iterator_Exhausted : exception; + -- This exception is raised when an iterator is exhausted and further + -- attempts to advance it are made by calling routine Next. + + function Iterate (T : Instance) return Iterator; + -- Obtain an iterator over the keys of hash table T. This action locks + -- all mutation functionality of the associated hash table. + + function Has_Next (Iter : Iterator) return Boolean; + -- Determine whether iterator Iter has more keys to examine. If the + -- iterator has been exhausted, restore all mutation functionality of + -- the associated hash table. + + procedure Next + (Iter : in out Iterator; + Key : out Key_Type); + -- Return the current key referenced by iterator Iter and advance to + -- the next available key. If the iterator has been exhausted and + -- further attempts are made to advance it, this routine restores + -- mutation functionality of the associated hash table, and then + -- raises Iterator_Exhausted. + + private + -- The following type represents a doubly linked list node used to + -- store a key-value pair. There are several reasons to use a doubly + -- linked list: + -- + -- * Most read and write operations utilize the same primitve + -- routines to locate, create, and delete a node, allowing for + -- greater degree of code sharing. + -- + -- * Special cases are eliminated by maintaining a circular node + -- list with a dummy head (see type Bucket_Table). + -- + -- A node is said to be "valid" if it is non-null, and does not refer to + -- the dummy head of some bucket. + + type Node; + type Node_Ptr is access all Node; + type Node is record + Key : Key_Type; + Value : Value_Type := No_Value; + -- Key-value pair stored in a bucket + + Prev : Node_Ptr := null; + Next : Node_Ptr := null; + end record; + + -- The following type represents a bucket table. Each bucket contains a + -- circular doubly linked list of nodes with a dummy head. Initially, + -- the head does not refer to itself. This is intentional because it + -- improves the performance of creation, compression, and expansion by + -- avoiding a separate pass to link a head to itself. Several routines + -- ensure that the head is properly formed. + + type Bucket_Table is array (Bucket_Range_Type range <>) of aliased Node; + type Bucket_Table_Ptr is access Bucket_Table; + + -- The following type represents a hash table + + type Hash_Table is record + Buckets : Bucket_Table_Ptr := null; + -- Reference to the compressing / expanding buckets + + Initial_Size : Bucket_Range_Type := 0; + -- The initial size of the buckets as specified at creation time + + Locked : Natural := 0; + -- Number of outstanding iterators + + Pairs : Pair_Count_Type := 0; + -- Number of key-value pairs in the buckets + end record; + + type Instance is access Hash_Table; + Nil : constant Instance := null; + + -- The following type represents a key iterator + + type Iterator is record + Idx : Bucket_Range_Type := 0; + -- Index of the current bucket being examined. This index is always + -- kept within the range of the buckets. + + Nod : Node_Ptr := null; + -- Reference to the current node being examined within the current + -- bucket. The invariant of the iterator requires that this field + -- always point to a valid node. A value of null indicates that the + -- iterator is exhausted. + + Table : Instance := null; + -- Reference to the associated hash table + end record; + end Dynamic_HTable; + end GNAT.Dynamic_HTables; -- cgit v1.1 From 8a2f6bbe45fe2dff64d613365fe2ddb2b1922e2f Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:44:46 +0000 Subject: [Ada] Compiler abort on call to expr. function for default discriminant If a discriminant specification has a default that is a call to an expression function, that function has to be frozen at the point of a call to the initialization procedure for an object of the record type, even though the call does not appear to come from source. 2018-08-21 Ed Schonberg gcc/ada/ * sem_res.adb (Resolve_Call): Force the freezing of an expression function that is called to provide a default value for a defaulted discriminant in an object initialization. gcc/testsuite/ * gnat.dg/expr_func5.adb: New testcase. From-SVN: r263710 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/sem_res.adb | 13 ++++++++++++- 2 files changed, 18 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 31420a3..7bae0cf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-08-21 Ed Schonberg + + * sem_res.adb (Resolve_Call): Force the freezing of an + expression function that is called to provide a default value + for a defaulted discriminant in an object initialization. + 2018-08-21 Hristian Kirtchev * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ddfa543..13612aa 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6067,7 +6067,10 @@ package body Sem_Res is -- (including the body of another expression function) which would -- place the freeze node in the wrong scope. An expression function -- is frozen in the usual fashion, by the appearance of a real body, - -- or at the end of a declarative part. + -- or at the end of a declarative part. However an implcit call to + -- an expression function may appear when it is part of a default + -- expression in a call to an initialiation procedure, and must be + -- frozen now, even if the body is inserted at a later point. if Is_Entity_Name (Subp) and then not In_Spec_Expression @@ -6076,6 +6079,14 @@ package body Sem_Res is (not Is_Expression_Function_Or_Completion (Entity (Subp)) or else Scope (Entity (Subp)) = Current_Scope) then + if Is_Expression_Function (Entity (Subp)) then + + -- Force freeze of expression function in call. + + Set_Comes_From_Source (Subp, True); + Set_Must_Not_Freeze (Subp, False); + end if; + Freeze_Expression (Subp); end if; -- cgit v1.1 From 83fadfd9ab43f7870d309ebb46e460cec82994a2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 21 Aug 2018 14:44:51 +0000 Subject: [Ada] Set_Targ: add a CodePeer annotation 2018-08-21 Arnaud Charlet gcc/ada/ * set_targ.adb: Mark some CodePeer message as Intentional. From-SVN: r263711 --- gcc/ada/ChangeLog | 4 ++++ gcc/ada/set_targ.adb | 3 +++ 2 files changed, 7 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7bae0cf..809fd0a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2018-08-21 Arnaud Charlet + + * set_targ.adb: Mark some CodePeer message as Intentional. + 2018-08-21 Ed Schonberg * sem_res.adb (Resolve_Call): Force the freezing of an diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index 0340ee6..4c717c5 100755 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -917,6 +917,9 @@ begin Get_Back_End_Config_File; begin if Back_End_Config_File /= null then + pragma Gnat_Annotate + (CodePeer, Intentional, "test always false", + "some variant body will return non null"); Read_Target_Dependent_Values (Back_End_Config_File.all); -- Otherwise we get all values from the back end directly -- cgit v1.1 From 3f99a611cab3ff6f5dab0e99ec2cf3a89b99cb1b Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 21 Aug 2018 14:44:56 +0000 Subject: [Ada] Crash on entry in generic with dynamic elaboration checks This patch modifies the set of attributes that applies to entries and entry families to include elaboration entities used by the access-before-elaboration mechanism. 2018-08-21 Hristian Kirtchev gcc/ada/ * einfo.adb (Elaboration_Entity): Include entries and entry families in the set of legal entities. (Elaboration_Entity_Required): Include entries and entry families in the set of legal entities. (Set_Elaboration_Entity): Include entries and entry families in the set of legal entities. (Set_Elaboration_Entity_Required): Include entries and entry families in the set of legal entities. (Write_Field13_Name): Update the output of attribute Elaboration_Entity. * einfo.ads: Attributes Elaboration_Entity and Elaboration_Entity_Required now apply to entries and entry families. gcc/testsuite/ * gnat.dg/elab6.adb, gnat.dg/elab6.ads, gnat.dg/elab6_pkg.adb, gnat.dg/elab6_pkg.ads: New testcase. From-SVN: r263712 --- gcc/ada/ChangeLog | 16 ++++++++++++++++ gcc/ada/einfo.adb | 12 +++++++----- gcc/ada/einfo.ads | 15 ++++++++------- 3 files changed, 31 insertions(+), 12 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 809fd0a..0cecad0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2018-08-21 Hristian Kirtchev + + * einfo.adb (Elaboration_Entity): Include entries and entry + families in the set of legal entities. + (Elaboration_Entity_Required): Include entries and entry + families in the set of legal entities. + (Set_Elaboration_Entity): Include entries and entry families in + the set of legal entities. + (Set_Elaboration_Entity_Required): Include entries and entry + families in the set of legal entities. + (Write_Field13_Name): Update the output of attribute + Elaboration_Entity. + * einfo.ads: Attributes Elaboration_Entity and + Elaboration_Entity_Required now apply to entries and entry + families. + 2018-08-21 Arnaud Charlet * set_targ.adb: Mark some CodePeer message as Intentional. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e89ea5a..c9cdfc2 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1182,7 +1182,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); return Node13 (Id); @@ -1193,7 +1193,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); return Flag174 (Id); @@ -4412,7 +4412,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); Set_Node13 (Id, V); @@ -4423,7 +4423,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); Set_Flag174 (Id, V); @@ -10355,7 +10355,9 @@ package body Einfo is => Write_Str ("Component_Clause"); - when E_Function + when E_Entry + | E_Entry_Family + | E_Function | E_Procedure | E_Package | Generic_Unit_Kind diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8e5bf65..dbe1ad6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1090,10 +1090,10 @@ package Einfo is -- to the spec as possible. -- Elaboration_Entity (Node13) --- Defined in generic and non-generic package and subprogram entities. --- This is a counter associated with the unit that is initially set to --- zero, is incremented when an elaboration request for the unit is --- made, and is decremented when a finalization request for the unit +-- Defined in entry, entry family, [generic] package, and subprogram +-- entities. This is a counter associated with the unit that is initially +-- set to zero, is incremented when an elaboration request for the unit +-- is made, and is decremented when a finalization request for the unit -- is made. This is used for three purposes. First, it is used to -- implement access before elaboration checks (the counter must be -- non-zero to call a subprogram at elaboration time). Second, it is @@ -1110,9 +1110,9 @@ package Einfo is -- is elaboration code), but is simply not used for any purpose. -- Elaboration_Entity_Required (Flag174) --- Defined in generic and non-generic package and subprogram entities. --- Set only if Elaboration_Entity is non-Empty to indicate that the --- counter is required to be non-zero even if there is no other +-- Defined in entry, entry family, [generic] package, and subprogram +-- entities. Set only if Elaboration_Entity is non-Empty to indicate that +-- the counter is required to be non-zero even if there is no other -- elaboration code. This occurs when the Elaboration_Entity counter -- is used for access before elaboration checks. If the counter is -- only used to prevent multiple execution of the elaboration code, @@ -6058,6 +6058,7 @@ package Einfo is -- E_Entry_Family -- Protected_Body_Subprogram (Node11) -- Barrier_Function (Node12) + -- Elaboration_Entity (Node13) -- Postconditions_Proc (Node14) -- Entry_Parameters_Type (Node15) -- First_Entity (Node17) -- cgit v1.1 From c36d21ee42349ea0e8565daa2013ba4f193d4ffe Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:45:04 +0000 Subject: [Ada] Fix scope computation for entry bodies and accept alternatives 2018-08-21 Ed Schonberg gcc/ada/ * exp_ch9.adb (Reset_Scopes): Do not recurse into type declarations when resetting the scope of entities declared the procedures generated for entry bodies and accept alternatives. Use the entity of the procedure declaration, not its body, as the new scope. From-SVN: r263713 --- gcc/ada/ChangeLog | 8 ++++++++ gcc/ada/exp_ch9.adb | 26 +++++++++++++++++--------- 2 files changed, 25 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0cecad0..d90f01a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2018-08-21 Ed Schonberg + + * exp_ch9.adb (Reset_Scopes): Do not recurse into type + declarations when resetting the scope of entities declared the + procedures generated for entry bodies and accept alternatives. + Use the entity of the procedure declaration, not its body, as + the new scope. + 2018-08-21 Hristian Kirtchev * einfo.adb (Elaboration_Entity): Include entries and entry diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e7561df..d7e6663 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -479,7 +479,9 @@ package body Exp_Ch9 is procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id); -- Reset the scope of declarations and blocks at the top level of Proc_Body -- to be E. Used after expanding entry bodies into their corresponding - -- procedures. + -- procedures. This is needed during unnesting to determine whether a + -- body geenrated for an entry or an accept alternative includes uplevel + -- references. function Trivial_Accept_OK return Boolean; -- If there is no DO-END block for an accept, or if the DO-END block has @@ -3807,7 +3809,7 @@ package body Exp_Ch9 is New_Occurrence_Of (RTE (RE_Get_GNAT_Exception), Loc))))))))); - Reset_Scopes_To (Proc_Body, Bod_Id); + Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); return Proc_Body; end if; end Build_Protected_Entry; @@ -10703,7 +10705,7 @@ package body Exp_Ch9 is Make_Defining_Identifier (Eloc, New_External_Name (Chars (Ename), 'A', Num_Accept)); - -- Link the acceptor to the original receiving entry + -- Link the acceptor to the original receiving entry. Set_Ekind (PB_Ent, E_Procedure); Set_Receiving_Entry (PB_Ent, Eent); @@ -14831,10 +14833,12 @@ package body Exp_Ch9 is --------------------- procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id) is + function Reset_Scope (N : Node_Id) return Traverse_Result; -- Temporaries may have been declared during expansion of the procedure - -- alternative. Indicate that their scope is the new body, to prevent - -- generation of spurious uplevel references for these entities. + -- created for an entry body or an accept alternative. Indicate that + -- their scope is the new body, to unsure proper generation of uplevel + -- references where needed during unnesting. procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); @@ -14855,13 +14859,19 @@ package body Exp_Ch9 is Set_Scope (Entity (Identifier (N)), E); return Skip; - elsif Nkind (N) = N_Package_Declaration then + -- Ditto for a package declaration or a full type declaration, etc. + + elsif Nkind (N) = N_Package_Declaration + or else Nkind (N) in N_Declaration + or else Nkind (N) in N_Renaming_Declaration + then Set_Scope (Defining_Entity (N), E); return Skip; elsif N = Proc_Body then - -- Scan declarations + -- Scan declarations in new body. Declarations in the statement + -- part will be handled during later traversal. Decl := First (Declarations (N)); while Present (Decl) loop @@ -14871,8 +14881,6 @@ package body Exp_Ch9 is elsif N /= Proc_Body and then Nkind (N) in N_Proper_Body then return Skip; - elsif Nkind (N) = N_Defining_Identifier then - Set_Scope (N, E); end if; return OK; -- cgit v1.1 From 2201fa7bd34d215e4aeeb961d41f60f3fb80f101 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 21 Aug 2018 14:45:49 +0000 Subject: [Ada] General purpose doubly linked list for compiler and tool use This patch adds unit GNAT.Lists which currently contains the implementation of a general purpose doubly linked list intended for use by the compiler and the tools around it. 2018-08-21 Hristian Kirtchev gcc/ada/ * impunit.adb: Add g-lists to the set of non-implementation units. * libgnat/g-lists.adb, libgnat/g-lists.ads: New unit. * Makefile.rtl: Add g-lists to the set of non-tasking units. * gcc-interface/Make-lang.in: Add g-lists to the set of files used by gnat1. gcc/testsuite/ * gnat.dg/linkedlist.adb: New testcase. From-SVN: r263714 --- gcc/ada/ChangeLog | 9 + gcc/ada/Makefile.rtl | 1 + gcc/ada/gcc-interface/Make-lang.in | 1 + gcc/ada/impunit.adb | 1 + gcc/ada/libgnat/g-lists.adb | 635 +++++++++++++++++++++++++++++++++++++ gcc/ada/libgnat/g-lists.ads | 245 ++++++++++++++ 6 files changed, 892 insertions(+) create mode 100644 gcc/ada/libgnat/g-lists.adb create mode 100644 gcc/ada/libgnat/g-lists.ads (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d90f01a..f21b11c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-08-21 Hristian Kirtchev + + * impunit.adb: Add g-lists to the set of non-implementation + units. + * libgnat/g-lists.adb, libgnat/g-lists.ads: New unit. + * Makefile.rtl: Add g-lists to the set of non-tasking units. + * gcc-interface/Make-lang.in: Add g-lists to the set of files + used by gnat1. + 2018-08-21 Ed Schonberg * exp_ch9.adb (Reset_Scopes): Do not recurse into type diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 7eaa9ba..2e4ee8d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -427,6 +427,7 @@ GNATRTL_NONTASKING_OBJS= \ g-htable$(objext) \ g-io$(objext) \ g-io_aux$(objext) \ + g-lists$(objext) \ g-locfil$(objext) \ g-mbdira$(objext) \ g-mbflra$(objext) \ diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index d51d397..d8dac73 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -319,6 +319,7 @@ GNAT_ADA_OBJS = \ ada/libgnat/g-dynhta.o \ ada/libgnat/g-hesora.o \ ada/libgnat/g-htable.o \ + ada/libgnat/g-lists.o \ ada/libgnat/g-spchge.o \ ada/libgnat/g-speche.o \ ada/libgnat/g-u3spch.o \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index cfa1d5e..7d35902 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -281,6 +281,7 @@ package body Impunit is ("g-htable", F), -- GNAT.Htable ("g-io ", F), -- GNAT.IO ("g-io_aux", F), -- GNAT.IO_Aux + ("g-lists ", F), -- GNAT.Lists ("g-locfil", F), -- GNAT.Lock_Files ("g-mbdira", F), -- GNAT.MBBS_Discrete_Random ("g-mbflra", F), -- GNAT.MBBS_Float_Random diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb new file mode 100644 index 0000000..a058f33 --- /dev/null +++ b/gcc/ada/libgnat/g-lists.adb @@ -0,0 +1,635 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . L I S T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body GNAT.Lists is + + package body Doubly_Linked_List is + procedure Delete_Node (L : Instance; Nod : Node_Ptr); + pragma Inline (Delete_Node); + -- Detach and delete node Nod from list L + + procedure Ensure_Circular (Head : Node_Ptr); + pragma Inline (Ensure_Circular); + -- Ensure that dummy head Head is circular with respect to itself + + procedure Ensure_Created (L : Instance); + pragma Inline (Ensure_Created); + -- Verify that list L is created. Raise Not_Created if this is not the + -- case. + + procedure Ensure_Full (L : Instance); + pragma Inline (Ensure_Full); + -- Verify that list L contains at least one element. Raise List_Empty if + -- this is not the case. + + procedure Ensure_Unlocked (L : Instance); + pragma Inline (Ensure_Unlocked); + -- Verify that list L is unlocked. Raise List_Locked if this is not the + -- case. + + function Find_Node + (Head : Node_Ptr; + Elem : Element_Type) return Node_Ptr; + pragma Inline (Find_Node); + -- Travers a list indicated by dummy head Head to determine whethe there + -- exists a node with element Elem. If such a node exists, return it, + -- otherwise return null; + + procedure Free is new Ada.Unchecked_Deallocation (Linked_List, Instance); + + procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); + + procedure Insert_Between + (L : Instance; + Elem : Element_Type; + Left : Node_Ptr; + Right : Node_Ptr); + pragma Inline (Insert_Between); + -- Insert element Elem between nodes Left and Right of list L + + function Is_Valid (Iter : Iterator) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether iterator Iter refers to a valid element + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether node Nod is non-null and does not refer to dummy + -- head Head, thus making it valid. + + procedure Lock (L : Instance); + pragma Inline (Lock); + -- Lock all mutation functionality of list L + + procedure Unlock (L : Instance); + pragma Inline (Unlock); + -- Unlock all mutation functionality of list L + + ------------ + -- Append -- + ------------ + + procedure Append (L : Instance; Elem : Element_Type) is + Head : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + -- Ensure that the dummy head of an empty list is circular with + -- respect to itself. + + Head := L.Nodes'Access; + Ensure_Circular (Head); + + -- Append the node by inserting it between the last node and the + -- dummy head. + + Insert_Between + (L => L, + Elem => Elem, + Left => Head.Prev, + Right => Head); + end Append; + + ------------ + -- Create -- + ------------ + + function Create return Instance is + begin + return new Linked_List; + end Create; + + -------------- + -- Contains -- + -------------- + + function Contains (L : Instance; Elem : Element_Type) return Boolean is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Elem); + + return Is_Valid (Nod, Head); + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (L : Instance; Elem : Element_Type) is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Full (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Elem); + + if Is_Valid (Nod, Head) then + Delete_Node (L, Nod); + end if; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (L : Instance) is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Full (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Head.Next; + + if Is_Valid (Nod, Head) then + Delete_Node (L, Nod); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (L : Instance) is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Full (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Head.Prev; + + if Is_Valid (Nod, Head) then + Delete_Node (L, Nod); + end if; + end Delete_Last; + + ----------------- + -- Delete_Node -- + ----------------- + + procedure Delete_Node (L : Instance; Nod : Node_Ptr) is + Ref : Node_Ptr := Nod; + + pragma Assert (Ref /= null); + + Next : constant Node_Ptr := Ref.Next; + Prev : constant Node_Ptr := Ref.Prev; + + begin + pragma Assert (L /= null); + pragma Assert (Next /= null); + pragma Assert (Prev /= null); + + Prev.Next := Next; -- Prev ---> Next + Next.Prev := Prev; -- Prev <--> Next + + Ref.Next := null; + Ref.Prev := null; + + L.Elements := L.Elements - 1; + + Free (Ref); + end Delete_Node; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (L : in out Instance) is + Head : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + + while Is_Valid (Head.Next, Head) loop + Delete_Node (L, Head.Next); + end loop; + + Free (L); + end Destroy; + + --------------------- + -- Ensure_Circular -- + --------------------- + + procedure Ensure_Circular (Head : Node_Ptr) is + pragma Assert (Head /= null); + + begin + if Head.Next = null and then Head.Prev = null then + Head.Next := Head; + Head.Prev := Head; + end if; + end Ensure_Circular; + + -------------------- + -- Ensure_Created -- + -------------------- + + procedure Ensure_Created (L : Instance) is + begin + if L = null then + raise Not_Created; + end if; + end Ensure_Created; + + ----------------- + -- Ensure_Full -- + ----------------- + + procedure Ensure_Full (L : Instance) is + begin + pragma Assert (L /= null); + + if L.Elements = 0 then + raise List_Empty; + end if; + end Ensure_Full; + + --------------------- + -- Ensure_Unlocked -- + --------------------- + + procedure Ensure_Unlocked (L : Instance) is + begin + pragma Assert (L /= null); + + -- The list has at least one outstanding iterator + + if L.Locked > 0 then + raise List_Locked; + end if; + end Ensure_Unlocked; + + --------------- + -- Find_Node -- + --------------- + + function Find_Node + (Head : Node_Ptr; + Elem : Element_Type) return Node_Ptr + is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- Traverse the nodes of the list, looking for a matching element + + Nod := Head.Next; + while Is_Valid (Nod, Head) loop + if Nod.Elem = Elem then + return Nod; + end if; + + Nod := Nod.Next; + end loop; + + return null; + end Find_Node; + + ----------- + -- First -- + ----------- + + function First (L : Instance) return Element_Type is + begin + Ensure_Created (L); + Ensure_Full (L); + + return L.Nodes.Next.Elem; + end First; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Iterator) return Boolean is + Is_OK : constant Boolean := Is_Valid (Iter); + + begin + -- The iterator is no longer valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the list because + -- the iterator cannot be advanced any further. + + if not Is_OK then + Unlock (Iter.List); + end if; + + return Is_OK; + end Has_Next; + + ------------------ + -- Insert_After -- + ------------------ + + procedure Insert_After + (L : Instance; + After : Element_Type; + Elem : Element_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, After); + + if Is_Valid (Nod, Head) then + Insert_Between + (L => L, + Elem => Elem, + Left => Nod, + Right => Nod.Next); + end if; + end Insert_After; + + ------------------- + -- Insert_Before -- + ------------------- + + procedure Insert_Before + (L : Instance; + Before : Element_Type; + Elem : Element_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Before); + + if Is_Valid (Nod, Head) then + Insert_Between + (L => L, + Elem => Elem, + Left => Nod.Prev, + Right => Nod); + end if; + end Insert_Before; + + -------------------- + -- Insert_Between -- + -------------------- + + procedure Insert_Between + (L : Instance; + Elem : Element_Type; + Left : Node_Ptr; + Right : Node_Ptr) + is + pragma Assert (L /= null); + pragma Assert (Left /= null); + pragma Assert (Right /= null); + + Nod : constant Node_Ptr := + new Node'(Elem => Elem, + Next => Right, -- Left Nod ---> Right + Prev => Left); -- Left <--- Nod ---> Right + + begin + Left.Next := Nod; -- Left <--> Nod ---> Right + Right.Prev := Nod; -- Left <--> Nod <--> Right + + L.Elements := L.Elements + 1; + end Insert_Between; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (L : Instance) return Boolean is + begin + Ensure_Created (L); + + return L.Elements = 0; + end Is_Empty; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Iter : Iterator) return Boolean is + begin + -- The invariant of Iterate and Next ensures that the iterator always + -- refers to a valid node if there exists one. + + return Is_Valid (Iter.Nod, Iter.List.Nodes'Access); + end Is_Valid; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is + begin + -- A node is valid if it is non-null, and does not refer to the dummy + -- head of some list. + + return Nod /= null and then Nod /= Head; + end Is_Valid; + + ------------- + -- Iterate -- + ------------- + + function Iterate (L : Instance) return Iterator is + begin + Ensure_Created (L); + + -- Lock all mutation functionality of the list while it is being + -- iterated on. + + Lock (L); + + return (List => L, Nod => L.Nodes.Next); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (L : Instance) return Element_Type is + begin + Ensure_Created (L); + Ensure_Full (L); + + return L.Nodes.Prev.Elem; + end Last; + + ------------ + -- Length -- + ------------ + + function Length (L : Instance) return Element_Count_Type is + begin + Ensure_Created (L); + + return L.Elements; + end Length; + + ---------- + -- Lock -- + ---------- + + procedure Lock (L : Instance) is + begin + pragma Assert (L /= null); + + -- The list may be locked multiple times if multiple iterators are + -- operating over it. + + L.Locked := L.Locked + 1; + end Lock; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type) + is + Is_OK : constant Boolean := Is_Valid (Iter); + Saved : constant Node_Ptr := Iter.Nod; + + begin + -- The iterator is no linger valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the list as the + -- iterator cannot be advanced any further. + + if not Is_OK then + Unlock (Iter.List); + raise Iterator_Exhausted; + end if; + + -- Advance to the next node along the list + + Iter.Nod := Iter.Nod.Next; + Elem := Saved.Elem; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (L : Instance; Elem : Element_Type) is + Head : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + -- Ensure that the dummy head of an empty list is circular with + -- respect to itself. + + Head := L.Nodes'Access; + Ensure_Circular (Head); + + -- Append the node by inserting it between the dummy head and the + -- first node. + + Insert_Between + (L => L, + Elem => Elem, + Left => Head, + Right => Head.Next); + end Prepend; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (L : Instance; + Old_Elem : Element_Type; + New_Elem : Element_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Old_Elem); + + if Is_Valid (Nod, Head) then + Nod.Elem := New_Elem; + end if; + end Replace; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : Instance) is + begin + pragma Assert (L /= null); + + -- The list may be locked multiple times if multiple iterators are + -- operating over it. + + L.Locked := L.Locked - 1; + end Unlock; + end Doubly_Linked_List; + +end GNAT.Lists; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads new file mode 100644 index 0000000..777b4f6 --- /dev/null +++ b/gcc/ada/libgnat/g-lists.ads @@ -0,0 +1,245 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . L I S T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package GNAT.Lists is + + ------------------------ + -- Doubly_Linked_List -- + ------------------------ + + -- The following package offers a doubly linked list abstraction with the + -- following characteristics: + -- + -- * Creation of multiple instances, of different sizes. + -- * Iterable elements. + -- + -- The following use pattern must be employed with this list: + -- + -- List : Instance := Create; + -- + -- + -- + -- Destroy (List) + -- + -- The destruction of the list reclaims all storage occupied by it. + + -- The following type denotes the number of elements stored in a list + + type Element_Count_Type is range 0 .. 2 ** 31 - 1; + + generic + type Element_Type is private; + + with function "=" + (Left : Element_Type; + Right : Element_Type) return Boolean; + + package Doubly_Linked_List is + + --------------------- + -- List operations -- + --------------------- + + type Instance is private; + Nil : constant Instance; + + List_Empty : exception; + -- This exception is raised when the list is empty, and an attempt is + -- made to delete an element from it. + + List_Locked : exception; + -- This exception is raised when the list is being iterated on, and an + -- attempt is made to mutate its state. + + Not_Created : exception; + -- This exception is raised when the list has not been created by + -- routine Create, and an attempt is made to read or mutate its state. + + procedure Append (L : Instance; Elem : Element_Type); + -- Insert element Elem at the end of list L. This action will raise + -- List_Locked if the list has outstanding iterators. + + function Contains (L : Instance; Elem : Element_Type) return Boolean; + -- Determine whether list L contains element Elem + + function Create return Instance; + -- Create a new list + + procedure Delete (L : Instance; Elem : Element_Type); + -- Delete element Elem from list L. The routine has no effect if Elem is + -- not present. This action will raise + -- + -- * List_Empty if the list is empty. + -- * List_Locked if the list has outstanding iterators. + + procedure Delete_First (L : Instance); + -- Delete an element from the start of list L. This action will raise + -- + -- * List_Empty if the list is empty. + -- * List_Locked if the list has outstanding iterators. + + procedure Delete_Last (L : Instance); + -- Delete an element from the end of list L. This action will raise + -- + -- * List_Empty if the list is empty. + -- * List_Locked if the list has outstanding iterators. + + procedure Destroy (L : in out Instance); + -- Destroy the contents of list L. This routine must be called at the + -- end of a list's lifetime. This action will raise List_Locked if the + -- list has outstanding iterators. + + function First (L : Instance) return Element_Type; + -- Obtain an element from the start of list L. This action will raise + -- List_Empty if the list is empty. + + procedure Insert_After + (L : Instance; + After : Element_Type; + Elem : Element_Type); + -- Insert new element Elem after element After in list L. The routine + -- has no effect if After is not present. This action will raise + -- List_Locked if the list has outstanding iterators. + + procedure Insert_Before + (L : Instance; + Before : Element_Type; + Elem : Element_Type); + -- Insert new element Elem before element Before in list L. The routine + -- has no effect if After is not present. This action will raise + -- List_Locked if the list has outstanding iterators. + + function Is_Empty (L : Instance) return Boolean; + -- Determine whether list L is empty + + function Last (L : Instance) return Element_Type; + -- Obtain an element from the end of list L. This action will raise + -- List_Empty if the list is empty. + + function Length (L : Instance) return Element_Count_Type; + -- Obtain the number of elements in list L + + procedure Prepend (L : Instance; Elem : Element_Type); + -- Insert element Elem at the start of list L. This action will raise + -- List_Locked if the list has outstanding iterators. + + procedure Replace + (L : Instance; + Old_Elem : Element_Type; + New_Elem : Element_Type); + -- Replace old element Old_Elem with new element New_Elem in list L. The + -- routine has no effect if Old_Elem is not present. This action will + -- raise List_Locked if the list has outstanding iterators. + + ------------------------- + -- Iterator operations -- + ------------------------- + + -- The following type represents an element iterator. An iterator locks + -- all mutation operations, and ulocks them once it is exhausted. The + -- iterator must be used with the following pattern: + -- + -- Iter := Iterate (My_List); + -- while Has_Next (Iter) loop + -- Next (Iter, Element); + -- end loop; + -- + -- It is possible to advance the iterator by using Next only, however + -- this risks raising Iterator_Exhausted. + + type Iterator is private; + + Iterator_Exhausted : exception; + -- This exception is raised when an iterator is exhausted and further + -- attempts to advance it are made by calling routine Next. + + function Iterate (L : Instance) return Iterator; + -- Obtain an iterator over the elements of list L. This action locks all + -- mutation functionality of the associated list. + + function Has_Next (Iter : Iterator) return Boolean; + -- Determine whether iterator Iter has more elements to examine. If the + -- iterator has been exhausted, restore all mutation functionality of + -- the associated list. + + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type); + -- Return the current element referenced by iterator Iter and advance + -- to the next available element. If the iterator has been exhausted + -- and further attempts are made to advance it, this routine restores + -- mutation functionality of the associated list, and then raises + -- Iterator_Exhausted. + + private + -- The following type represents a list node + + type Node; + type Node_Ptr is access all Node; + type Node is record + Elem : Element_Type; + + Next : Node_Ptr := null; + Prev : Node_Ptr := null; + end record; + + -- The following type represents a list + + type Linked_List is record + Elements : Element_Count_Type := 0; + -- The number of elements in the list + + Locked : Natural := 0; + -- Number of outstanding iterators + + Nodes : aliased Node; + -- The dummy head of the list + end record; + + type Instance is access all Linked_List; + Nil : constant Instance := null; + + -- The following type represents an element iterator + + type Iterator is record + List : Instance := null; + -- Reference to the associated list + + Nod : Node_Ptr := null; + -- Reference to the current node being examined. The invariant of the + -- iterator requires that this field always points to a valid node. A + -- value of null indicates that the iterator is exhausted. + end record; + end Doubly_Linked_List; + +end GNAT.Lists; -- cgit v1.1 From c4b9b2916ceb22b57d72fee8f775e02a8851d086 Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Tue, 21 Aug 2018 14:46:07 +0000 Subject: [Ada] Define versions of dimension system for Float and Long_Float The dimension system in System.Dim.Mks is based on Long_Long_Float, which may not be convenient to people who want to use Float or Long_Float as basis. These new files provide units that define the dimension system based on Float in System.Dim.Float_Mks and on Long_Float in System.Dim.Long_Mks. Child packages Other_Prefixes and Mks_IO are also defined appropriately, with new instantiations for the various sizes of floating-point types. 2018-08-21 Yannick Moy gcc/ada/ * doc/gnat_ugn/gnat_and_program_execution.rst: Update documentation of dimensionality analysis. * gnat_ugn.texi: Regenerate. * Makefile.rtl, impunit.adb: Consider the new units. * libgnat/s-dfmkio.ads, libgnat/s-dfmopr.ads, libgnat/s-diflmk.ads: New units based on Float. * libgnat/s-dilomk.ads, libgnat/s-dlmkio.ads, libgnat/s-dlmopr.ads: New units based on Long_Float. * libgnat/s-dmotpr.ads: Rename to libgnat/s-dgmgop.ads and turn into an instance of System.Dim.Generic_Mks.Generic_Other_Prefixes. * libgnat/s-dimmks.ads: Rename to libgnat/s-digemk.ads and turn into an instance of System.Dim.Generic_Mks. From-SVN: r263715 --- gcc/ada/ChangeLog | 16 + gcc/ada/Makefile.rtl | 9 +- .../doc/gnat_ugn/gnat_and_program_execution.rst | 31 +- gcc/ada/gnat_ugn.texi | 42 ++- gcc/ada/impunit.adb | 8 + gcc/ada/libgnat/s-dfmkio.ads | 38 ++ gcc/ada/libgnat/s-dfmopr.ads | 35 ++ gcc/ada/libgnat/s-dgmgop.ads | 174 +++++++++ gcc/ada/libgnat/s-diflmk.ads | 34 ++ gcc/ada/libgnat/s-digemk.ads | 396 +++++++++++++++++++++ gcc/ada/libgnat/s-dilomk.ads | 34 ++ gcc/ada/libgnat/s-dimmks.ads | 363 +------------------ gcc/ada/libgnat/s-dlmkio.ads | 38 ++ gcc/ada/libgnat/s-dlmopr.ads | 35 ++ gcc/ada/libgnat/s-dmotpr.ads | 141 +------- 15 files changed, 866 insertions(+), 528 deletions(-) create mode 100644 gcc/ada/libgnat/s-dfmkio.ads create mode 100644 gcc/ada/libgnat/s-dfmopr.ads create mode 100644 gcc/ada/libgnat/s-dgmgop.ads create mode 100644 gcc/ada/libgnat/s-diflmk.ads create mode 100644 gcc/ada/libgnat/s-digemk.ads create mode 100644 gcc/ada/libgnat/s-dilomk.ads create mode 100644 gcc/ada/libgnat/s-dlmkio.ads create mode 100644 gcc/ada/libgnat/s-dlmopr.ads (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f21b11c..2b17d4a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2018-08-21 Yannick Moy + + * doc/gnat_ugn/gnat_and_program_execution.rst: Update + documentation of dimensionality analysis. + * gnat_ugn.texi: Regenerate. + * Makefile.rtl, impunit.adb: Consider the new units. + * libgnat/s-dfmkio.ads, libgnat/s-dfmopr.ads, + libgnat/s-diflmk.ads: New units based on Float. + * libgnat/s-dilomk.ads, libgnat/s-dlmkio.ads, + libgnat/s-dlmopr.ads: New units based on Long_Float. + * libgnat/s-dmotpr.ads: Rename to libgnat/s-dgmgop.ads and turn + into an instance of + System.Dim.Generic_Mks.Generic_Other_Prefixes. + * libgnat/s-dimmks.ads: Rename to libgnat/s-digemk.ads and turn + into an instance of System.Dim.Generic_Mks. + 2018-08-21 Hristian Kirtchev * impunit.adb: Add g-lists to the set of non-implementation diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 2e4ee8d..9542fe0 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -523,12 +523,20 @@ GNATRTL_NONTASKING_OBJS= \ s-conca9$(objext) \ s-crc32$(objext) \ s-crtl$(objext) \ + s-dfmkio$(objext) \ + s-dfmopr$(objext) \ + s-dgmgop$(objext) \ + s-dlmopr$(objext) \ s-diflio$(objext) \ + s-diflmk$(objext) \ + s-digemk$(objext) \ s-diinio$(objext) \ + s-dilomk$(objext) \ s-dim$(objext) \ s-dimkio$(objext) \ s-dimmks$(objext) \ s-direio$(objext) \ + s-dlmkio$(objext) \ s-dmotpr$(objext) \ s-dsaser$(objext) \ s-elaall$(objext) \ @@ -2762,4 +2770,3 @@ a-tags.o : a-tags.adb a-tags.ads s-memory.o : s-memory.adb s-memory.ads $(ADAC) -c $(ALL_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) - diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index 3e0c6ff..9cbdb15 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3280,19 +3280,18 @@ to use the proper subtypes in object declarations. .. index:: MKS_Type type The simplest way to impose dimensionality checking on a computation is to make -use of the package ``System.Dim.Mks``, -which is part of the GNAT library. This -package defines a floating-point type ``MKS_Type``, -for which a sequence of -dimension names are specified, together with their conventional abbreviations. -The following should be read together with the full specification of the -package, in file :file:`s-dimmks.ads`. +use of one of the instantiations of the package ``System.Dim.Generic_Mks``, which +are part of the GNAT library. This generic package defines a floating-point +type ``MKS_Type``, for which a sequence of dimension names are specified, +together with their conventional abbreviations. The following should be read +together with the full specification of the package, in file +:file:`s-digemk.ads`. - .. index:: s-dimmks.ads file + .. index:: s-digemk.ads file .. code-block:: ada - type Mks_Type is new Long_Long_Float + type Mks_Type is new Float_Type with Dimension_System => ( (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), @@ -3336,10 +3335,16 @@ as well as useful multiples of these units: day : constant Time := 60.0 * 24.0 * min; ... -Using this package, you can then define a derived unit by -providing the aspect that -specifies its dimensions within the MKS system, as well as the string to -be used for output of a value of that unit: +There are three instantiations of ``System.Dim.Generic_Mks`` defined in the +GNAT library: + +* ``System.Dim.Float_Mks`` based on ``Float`` defined in :file:`s-diflmk.ads`. +* ``System.Dim.Long_Mks`` based on ``Long_Float`` defined in :file:`s-dilomk.ads`. +* ``System.Dim.Mks`` based on ``Long_Long_Float`` defined in :file:`s-dimmks.ads`. + +Using one of these packages, you can then define a derived unit by providing +the aspect that specifies its dimensions within the MKS system, as well as the +string to be used for output of a value of that unit: .. code-block:: ada diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index b5972bb..dfff37d 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jul 13, 2018 +GNAT User's Guide for Native Platforms , Aug 17, 2018 AdaCore @@ -22606,20 +22606,19 @@ to use the proper subtypes in object declarations. @geindex MKS_Type type The simplest way to impose dimensionality checking on a computation is to make -use of the package @code{System.Dim.Mks}, -which is part of the GNAT library. This -package defines a floating-point type @code{MKS_Type}, -for which a sequence of -dimension names are specified, together with their conventional abbreviations. -The following should be read together with the full specification of the -package, in file @code{s-dimmks.ads}. +use of one of the instantiations of the package @code{System.Dim.Generic_Mks}, which +are part of the GNAT library. This generic package defines a floating-point +type @code{MKS_Type}, for which a sequence of dimension names are specified, +together with their conventional abbreviations. The following should be read +together with the full specification of the package, in file +@code{s-digemk.ads}. @quotation -@geindex s-dimmks.ads file +@geindex s-digemk.ads file @example -type Mks_Type is new Long_Long_Float +type Mks_Type is new Float_Type with Dimension_System => ( (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), @@ -22674,10 +22673,25 @@ as well as useful multiples of these units: @end example @end quotation -Using this package, you can then define a derived unit by -providing the aspect that -specifies its dimensions within the MKS system, as well as the string to -be used for output of a value of that unit: +There are three instantiations of @code{System.Dim.Generic_Mks} defined in the +GNAT library: + + +@itemize * + +@item +@code{System.Dim.Float_Mks} based on @code{Float} defined in @code{s-diflmk.ads}. + +@item +@code{System.Dim.Long_Mks} based on @code{Long_Float} defined in @code{s-dilomk.ads}. + +@item +@code{System.Dim.Mks} based on @code{Long_Long_Float} defined in @code{s-dimmks.ads}. +@end itemize + +Using one of these packages, you can then define a derived unit by providing +the aspect that specifies its dimensions within the MKS system, as well as the +string to be used for output of a value of that unit: @quotation diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 7d35902..3e5fbe0 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -373,10 +373,18 @@ package body Impunit is ("s-addima", F), -- System.Address_Image ("s-atocou", F), -- System.Atomic_Counters ("s-assert", F), -- System.Assertions + ("s-dfmkio", F), -- System.Dim.Float_Mks_IO + ("s-dfmopr", F), -- System.Dim.Float_Mks.Other_Prefixes + ("s-dgmgop", F), -- System.Dim.Generic_Mks.Generic_Other_Prefixes + ("s-dlmopr", F), -- System.Dim.Long_Mks.Other_Prefixes ("s-diflio", F), -- System.Dim.Float_IO + ("s-diflmk", F), -- System.Dim.Float_Mks + ("s-digemk", F), -- System.Dim.Generic_Mks ("s-diinio", F), -- System.Dim.Integer_IO + ("s-dilomk", F), -- System.Dim.Long_Mks ("s-dimkio", F), -- System.Dim.Mks_IO ("s-dimmks", F), -- System.Dim.Mks + ("s-dlmkio", F), -- System.Dim.Long_Mks_IO ("s-dmotpr", F), -- System.Dim.Mks.Other_Prefixes ("s-memory", F), -- System.Memory ("s-parint", F), -- System.Partition_Interface diff --git a/gcc/ada/libgnat/s-dfmkio.ads b/gcc/ada/libgnat/s-dfmkio.ads new file mode 100644 index 0000000..c9a96c2 --- /dev/null +++ b/gcc/ada/libgnat/s-dfmkio.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ M K S _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Provides output facilities for the Float MKS dimension system (see +-- System.Dim.Float_Mks and System.Dim.Float_IO). + +with System.Dim.Float_Mks; use System.Dim.Float_Mks; +with System.Dim.Float_IO; + +package System.Dim.Float_Mks_IO is new System.Dim.Float_IO (Mks_Type); diff --git a/gcc/ada/libgnat/s-dfmopr.ads b/gcc/ada/libgnat/s-dfmopr.ads new file mode 100644 index 0000000..6938feb --- /dev/null +++ b/gcc/ada/libgnat/s-dfmopr.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ M K S . O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks.Generic_Other_Prefixes; + +package System.Dim.Float_Mks.Other_Prefixes is + new System.Dim.Float_Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/libgnat/s-dgmgop.ads b/gcc/ada/libgnat/s-dgmgop.ads new file mode 100644 index 0000000..496056d --- /dev/null +++ b/gcc/ada/libgnat/s-dgmgop.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . G E N E R I C _ M K S -- +-- . G E N E R I C _ O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package that defines some other prefixes for the MKS base unit system. + +-- These prefixes have been defined in a child package in order to avoid too +-- many constant declarations in System.Dim.Generic_Mks. + +generic +package System.Dim.Generic_Mks.Generic_Other_Prefixes is + + -- SI prefixes for Meter + + pragma Warnings (Off); + -- Turn off the all the dimension warnings + + ym : constant Length := 1.0E-24; -- yocto + zm : constant Length := 1.0E-21; -- zepto + am : constant Length := 1.0E-18; -- atto + fm : constant Length := 1.0E-15; -- femto + pm : constant Length := 1.0E-12; -- pico + nm : constant Length := 1.0E-09; -- nano + Gm : constant Length := 1.0E+09; -- giga + Tm : constant Length := 1.0E+12; -- tera + Pem : constant Length := 1.0E+15; -- peta + Em : constant Length := 1.0E+18; -- exa + Zem : constant Length := 1.0E+21; -- zetta + Yom : constant Length := 1.0E+24; -- yotta + + -- SI prefixes for Kilogram + + yg : constant Mass := 1.0E-27; -- yocto + zg : constant Mass := 1.0E-24; -- zepto + ag : constant Mass := 1.0E-21; -- atto + fg : constant Mass := 1.0E-18; -- femto + pg : constant Mass := 1.0E-15; -- pico + ng : constant Mass := 1.0E-12; -- nano + Gg : constant Mass := 1.0E+06; -- giga + Tg : constant Mass := 1.0E+09; -- tera + Peg : constant Mass := 1.0E+13; -- peta + Eg : constant Mass := 1.0E+15; -- exa + Zeg : constant Mass := 1.0E+18; -- zetta + Yog : constant Mass := 1.0E+21; -- yotta + + -- SI prefixes for Second + + ys : constant Time := 1.0E-24; -- yocto + zs : constant Time := 1.0E-21; -- zepto + as : constant Time := 1.0E-18; -- atto + fs : constant Time := 1.0E-15; -- femto + ps : constant Time := 1.0E-12; -- pico + ns : constant Time := 1.0E-09; -- nano + Gs : constant Time := 1.0E+09; -- giga + Ts : constant Time := 1.0E+12; -- tera + Pes : constant Time := 1.0E+15; -- peta + Es : constant Time := 1.0E+18; -- exa + Zes : constant Time := 1.0E+21; -- zetta + Yos : constant Time := 1.0E+24; -- yotta + + -- SI prefixes for Ampere + + yA : constant Electric_Current := 1.0E-24; -- yocto + zA : constant Electric_Current := 1.0E-21; -- zepto + aA : constant Electric_Current := 1.0E-18; -- atto + fA : constant Electric_Current := 1.0E-15; -- femto + nA : constant Electric_Current := 1.0E-09; -- nano + uA : constant Electric_Current := 1.0E-06; -- micro (u) + GA : constant Electric_Current := 1.0E+09; -- giga + TA : constant Electric_Current := 1.0E+12; -- tera + PeA : constant Electric_Current := 1.0E+15; -- peta + EA : constant Electric_Current := 1.0E+18; -- exa + ZeA : constant Electric_Current := 1.0E+21; -- zetta + YoA : constant Electric_Current := 1.0E+24; -- yotta + + -- SI prefixes for Kelvin + + yK : constant Thermodynamic_Temperature := 1.0E-24; -- yocto + zK : constant Thermodynamic_Temperature := 1.0E-21; -- zepto + aK : constant Thermodynamic_Temperature := 1.0E-18; -- atto + fK : constant Thermodynamic_Temperature := 1.0E-15; -- femto + pK : constant Thermodynamic_Temperature := 1.0E-12; -- pico + nK : constant Thermodynamic_Temperature := 1.0E-09; -- nano + uK : constant Thermodynamic_Temperature := 1.0E-06; -- micro (u) + mK : constant Thermodynamic_Temperature := 1.0E-03; -- milli + cK : constant Thermodynamic_Temperature := 1.0E-02; -- centi + dK : constant Thermodynamic_Temperature := 1.0E-01; -- deci + daK : constant Thermodynamic_Temperature := 1.0E+01; -- deka + hK : constant Thermodynamic_Temperature := 1.0E+02; -- hecto + kK : constant Thermodynamic_Temperature := 1.0E+03; -- kilo + MeK : constant Thermodynamic_Temperature := 1.0E+06; -- mega + GK : constant Thermodynamic_Temperature := 1.0E+09; -- giga + TK : constant Thermodynamic_Temperature := 1.0E+12; -- tera + PeK : constant Thermodynamic_Temperature := 1.0E+15; -- peta + EK : constant Thermodynamic_Temperature := 1.0E+18; -- exa + ZeK : constant Thermodynamic_Temperature := 1.0E+21; -- zetta + YoK : constant Thermodynamic_Temperature := 1.0E+24; -- yotta + + -- SI prefixes for Mole + + ymol : constant Amount_Of_Substance := 1.0E-24; -- yocto + zmol : constant Amount_Of_Substance := 1.0E-21; -- zepto + amol : constant Amount_Of_Substance := 1.0E-18; -- atto + fmol : constant Amount_Of_Substance := 1.0E-15; -- femto + pmol : constant Amount_Of_Substance := 1.0E-12; -- pico + nmol : constant Amount_Of_Substance := 1.0E-09; -- nano + umol : constant Amount_Of_Substance := 1.0E-06; -- micro (u) + mmol : constant Amount_Of_Substance := 1.0E-03; -- milli + cmol : constant Amount_Of_Substance := 1.0E-02; -- centi + dmol : constant Amount_Of_Substance := 1.0E-01; -- deci + damol : constant Amount_Of_Substance := 1.0E+01; -- deka + hmol : constant Amount_Of_Substance := 1.0E+02; -- hecto + kmol : constant Amount_Of_Substance := 1.0E+03; -- kilo + Memol : constant Amount_Of_Substance := 1.0E+06; -- mega + Gmol : constant Amount_Of_Substance := 1.0E+09; -- giga + Tmol : constant Amount_Of_Substance := 1.0E+12; -- tera + Pemol : constant Amount_Of_Substance := 1.0E+15; -- peta + Emol : constant Amount_Of_Substance := 1.0E+18; -- exa + Zemol : constant Amount_Of_Substance := 1.0E+21; -- zetta + Yomol : constant Amount_Of_Substance := 1.0E+24; -- yotta + + -- SI prefixes for Candela + + ycd : constant Luminous_Intensity := 1.0E-24; -- yocto + zcd : constant Luminous_Intensity := 1.0E-21; -- zepto + acd : constant Luminous_Intensity := 1.0E-18; -- atto + fcd : constant Luminous_Intensity := 1.0E-15; -- femto + pcd : constant Luminous_Intensity := 1.0E-12; -- pico + ncd : constant Luminous_Intensity := 1.0E-09; -- nano + ucd : constant Luminous_Intensity := 1.0E-06; -- micro (u) + mcd : constant Luminous_Intensity := 1.0E-03; -- milli + ccd : constant Luminous_Intensity := 1.0E-02; -- centi + dcd : constant Luminous_Intensity := 1.0E-01; -- deci + dacd : constant Luminous_Intensity := 1.0E+01; -- deka + hcd : constant Luminous_Intensity := 1.0E+02; -- hecto + kcd : constant Luminous_Intensity := 1.0E+03; -- kilo + Mecd : constant Luminous_Intensity := 1.0E+06; -- mega + Gcd : constant Luminous_Intensity := 1.0E+09; -- giga + Tcd : constant Luminous_Intensity := 1.0E+12; -- tera + Pecd : constant Luminous_Intensity := 1.0E+15; -- peta + Ecd : constant Luminous_Intensity := 1.0E+18; -- exa + Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta + Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta + + pragma Warnings (On); +end System.Dim.Generic_Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/libgnat/s-diflmk.ads b/gcc/ada/libgnat/s-diflmk.ads new file mode 100644 index 0000000..435948e --- /dev/null +++ b/gcc/ada/libgnat/s-diflmk.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks; + +package System.Dim.Float_Mks is new System.Dim.Generic_Mks (Float); diff --git a/gcc/ada/libgnat/s-digemk.ads b/gcc/ada/libgnat/s-digemk.ads new file mode 100644 index 0000000..4f55ad4 --- /dev/null +++ b/gcc/ada/libgnat/s-digemk.ads @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . G E N E R I C _ M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Defines the MKS dimension system which is the SI system of units + +-- Some other prefixes of this system are defined in a child package (see +-- System.Dim.Generic_Mks.Generic_Other_Prefixes) in order to avoid too many +-- constant declarations in this package. + +-- The dimension terminology is defined in System.Dim package + +with Ada.Numerics; + +generic + type Float_Type is digits <>; + +package System.Dim.Generic_Mks is + + e : constant := Ada.Numerics.e; + Pi : constant := Ada.Numerics.Pi; + + -- Dimensioned type Mks_Type + + type Mks_Type is new Float_Type + with + Dimension_System => ( + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + + -- SI Base dimensioned subtypes + + subtype Length is Mks_Type + with + Dimension => (Symbol => 'm', + Meter => 1, + others => 0); + + subtype Mass is Mks_Type + with + Dimension => (Symbol => "kg", + Kilogram => 1, + others => 0); + + subtype Time is Mks_Type + with + Dimension => (Symbol => 's', + Second => 1, + others => 0); + + subtype Electric_Current is Mks_Type + with + Dimension => (Symbol => 'A', + Ampere => 1, + others => 0); + + subtype Thermodynamic_Temperature is Mks_Type + with + Dimension => (Symbol => 'K', + Kelvin => 1, + others => 0); + + subtype Amount_Of_Substance is Mks_Type + with + Dimension => (Symbol => "mol", + Mole => 1, + others => 0); + + subtype Luminous_Intensity is Mks_Type + with + Dimension => (Symbol => "cd", + Candela => 1, + others => 0); + + -- Initialize SI Base unit values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes (we can't assign 1.0*m to m). + + pragma Warnings (Off, "*assumed to be*"); + + m : constant Length := 1.0; + kg : constant Mass := 1.0; + s : constant Time := 1.0; + A : constant Electric_Current := 1.0; + K : constant Thermodynamic_Temperature := 1.0; + mol : constant Amount_Of_Substance := 1.0; + cd : constant Luminous_Intensity := 1.0; + + pragma Warnings (On, "*assumed to be*"); + + -- SI Derived dimensioned subtypes + + subtype Absorbed_Dose is Mks_Type + with + Dimension => (Symbol => "Gy", + Meter => 2, + Second => -2, + others => 0); + + subtype Angle is Mks_Type + with + Dimension => (Symbol => "rad", + others => 0); + + subtype Area is Mks_Type + with + Dimension => ( + Meter => 2, + others => 0); + + subtype Catalytic_Activity is Mks_Type + with + Dimension => (Symbol => "kat", + Second => -1, + Mole => 1, + others => 0); + + subtype Celsius_Temperature is Mks_Type + with + Dimension => (Symbol => "°C", + Kelvin => 1, + others => 0); + + subtype Electric_Capacitance is Mks_Type + with + Dimension => (Symbol => 'F', + Meter => -2, + Kilogram => -1, + Second => 4, + Ampere => 2, + others => 0); + + subtype Electric_Charge is Mks_Type + with + Dimension => (Symbol => 'C', + Second => 1, + Ampere => 1, + others => 0); + + subtype Electric_Conductance is Mks_Type + with + Dimension => (Symbol => 'S', + Meter => -2, + Kilogram => -1, + Second => 3, + Ampere => 2, + others => 0); + + subtype Electric_Potential_Difference is Mks_Type + with + Dimension => (Symbol => 'V', + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -1, + others => 0); + + -- Note the type punning below. The Symbol is a single "ohm" character + -- encoded in UTF-8 (ce a9 in hexadecimal), but this file is not compiled + -- with -gnatW8, so we're treating the string literal as a two-character + -- String. + + subtype Electric_Resistance is Mks_Type + with + Dimension => (Symbol => "Ω", + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -2, + others => 0); + + subtype Energy is Mks_Type + with + Dimension => (Symbol => 'J', + Meter => 2, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Equivalent_Dose is Mks_Type + with + Dimension => (Symbol => "Sv", + Meter => 2, + Second => -2, + others => 0); + + subtype Force is Mks_Type + with + Dimension => (Symbol => 'N', + Meter => 1, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Frequency is Mks_Type + with + Dimension => (Symbol => "Hz", + Second => -1, + others => 0); + + subtype Illuminance is Mks_Type + with + Dimension => (Symbol => "lx", + Meter => -2, + Candela => 1, + others => 0); + + subtype Inductance is Mks_Type + with + Dimension => (Symbol => 'H', + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -2, + others => 0); + + subtype Luminous_Flux is Mks_Type + with + Dimension => (Symbol => "lm", + Candela => 1, + others => 0); + + subtype Magnetic_Flux is Mks_Type + with + Dimension => (Symbol => "Wb", + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); + + subtype Magnetic_Flux_Density is Mks_Type + with + Dimension => (Symbol => 'T', + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); + + subtype Power is Mks_Type + with + Dimension => (Symbol => 'W', + Meter => 2, + Kilogram => 1, + Second => -3, + others => 0); + + subtype Pressure is Mks_Type + with + Dimension => (Symbol => "Pa", + Meter => -1, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Radioactivity is Mks_Type + with + Dimension => (Symbol => "Bq", + Second => -1, + others => 0); + + subtype Solid_Angle is Mks_Type + with + Dimension => (Symbol => "sr", + others => 0); + + subtype Speed is Mks_Type + with + Dimension => ( + Meter => 1, + Second => -1, + others => 0); + + subtype Volume is Mks_Type + with + Dimension => ( + Meter => 3, + others => 0); + + -- Initialize derived dimension values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes. + + pragma Warnings (Off, "*assumed to be*"); + + rad : constant Angle := 1.0; + sr : constant Solid_Angle := 1.0; + Hz : constant Frequency := 1.0; + N : constant Force := 1.0; + Pa : constant Pressure := 1.0; + J : constant Energy := 1.0; + W : constant Power := 1.0; + C : constant Electric_Charge := 1.0; + V : constant Electric_Potential_Difference := 1.0; + F : constant Electric_Capacitance := 1.0; + Ohm : constant Electric_Resistance := 1.0; + Si : constant Electric_Conductance := 1.0; + Wb : constant Magnetic_Flux := 1.0; + T : constant Magnetic_Flux_Density := 1.0; + H : constant Inductance := 1.0; + dC : constant Celsius_Temperature := 273.15; + lm : constant Luminous_Flux := 1.0; + lx : constant Illuminance := 1.0; + Bq : constant Radioactivity := 1.0; + Gy : constant Absorbed_Dose := 1.0; + Sv : constant Equivalent_Dose := 1.0; + kat : constant Catalytic_Activity := 1.0; + + -- SI prefixes for Meter + + um : constant Length := 1.0E-06; -- micro (u) + mm : constant Length := 1.0E-03; -- milli + cm : constant Length := 1.0E-02; -- centi + dm : constant Length := 1.0E-01; -- deci + dam : constant Length := 1.0E+01; -- deka + hm : constant Length := 1.0E+02; -- hecto + km : constant Length := 1.0E+03; -- kilo + Mem : constant Length := 1.0E+06; -- mega + + -- SI prefixes for Kilogram + + ug : constant Mass := 1.0E-09; -- micro (u) + mg : constant Mass := 1.0E-06; -- milli + cg : constant Mass := 1.0E-05; -- centi + dg : constant Mass := 1.0E-04; -- deci + g : constant Mass := 1.0E-03; -- gram + dag : constant Mass := 1.0E-02; -- deka + hg : constant Mass := 1.0E-01; -- hecto + Meg : constant Mass := 1.0E+03; -- mega + + -- SI prefixes for Second + + us : constant Time := 1.0E-06; -- micro (u) + ms : constant Time := 1.0E-03; -- milli + cs : constant Time := 1.0E-02; -- centi + ds : constant Time := 1.0E-01; -- deci + das : constant Time := 1.0E+01; -- deka + hs : constant Time := 1.0E+02; -- hecto + ks : constant Time := 1.0E+03; -- kilo + Mes : constant Time := 1.0E+06; -- mega + + -- Other constants for Second + + min : constant Time := 60.0 * s; + hour : constant Time := 60.0 * min; + day : constant Time := 24.0 * hour; + year : constant Time := 365.25 * day; + + -- SI prefixes for Ampere + + mA : constant Electric_Current := 1.0E-03; -- milli + cA : constant Electric_Current := 1.0E-02; -- centi + dA : constant Electric_Current := 1.0E-01; -- deci + daA : constant Electric_Current := 1.0E+01; -- deka + hA : constant Electric_Current := 1.0E+02; -- hecto + kA : constant Electric_Current := 1.0E+03; -- kilo + MeA : constant Electric_Current := 1.0E+06; -- mega + + pragma Warnings (On, "*assumed to be*"); +end System.Dim.Generic_Mks; diff --git a/gcc/ada/libgnat/s-dilomk.ads b/gcc/ada/libgnat/s-dilomk.ads new file mode 100644 index 0000000..2aaecae --- /dev/null +++ b/gcc/ada/libgnat/s-dilomk.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . L O N G _ M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks; + +package System.Dim.Long_Mks is new System.Dim.Generic_Mks (Long_Float); diff --git a/gcc/ada/libgnat/s-dimmks.ads b/gcc/ada/libgnat/s-dimmks.ads index f21f82d..bf89f1b 100644 --- a/gcc/ada/libgnat/s-dimmks.ads +++ b/gcc/ada/libgnat/s-dimmks.ads @@ -29,365 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Defines the MKS dimension system which is the SI system of units +with System.Dim.Generic_Mks; --- Some other prefixes of this system are defined in a child package (see --- System.Dim_Mks.Other_Prefixes) in order to avoid too many constant --- declarations in this package. - --- The dimension terminology is defined in System.Dim_IO package - -with Ada.Numerics; - -package System.Dim.Mks is - - e : constant := Ada.Numerics.e; - Pi : constant := Ada.Numerics.Pi; - - -- Dimensioned type Mks_Type - - type Mks_Type is new Long_Long_Float - with - Dimension_System => ( - (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), - (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), - (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), - (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), - (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), - (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), - (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - - -- SI Base dimensioned subtypes - - subtype Length is Mks_Type - with - Dimension => (Symbol => 'm', - Meter => 1, - others => 0); - - subtype Mass is Mks_Type - with - Dimension => (Symbol => "kg", - Kilogram => 1, - others => 0); - - subtype Time is Mks_Type - with - Dimension => (Symbol => 's', - Second => 1, - others => 0); - - subtype Electric_Current is Mks_Type - with - Dimension => (Symbol => 'A', - Ampere => 1, - others => 0); - - subtype Thermodynamic_Temperature is Mks_Type - with - Dimension => (Symbol => 'K', - Kelvin => 1, - others => 0); - - subtype Amount_Of_Substance is Mks_Type - with - Dimension => (Symbol => "mol", - Mole => 1, - others => 0); - - subtype Luminous_Intensity is Mks_Type - with - Dimension => (Symbol => "cd", - Candela => 1, - others => 0); - - -- Initialize SI Base unit values - - -- Turn off the all the dimension warnings for these basic assignments - -- since otherwise we would get complaints about assigning dimensionless - -- values to dimensioned subtypes (we can't assign 1.0*m to m). - - pragma Warnings (Off, "*assumed to be*"); - - m : constant Length := 1.0; - kg : constant Mass := 1.0; - s : constant Time := 1.0; - A : constant Electric_Current := 1.0; - K : constant Thermodynamic_Temperature := 1.0; - mol : constant Amount_Of_Substance := 1.0; - cd : constant Luminous_Intensity := 1.0; - - pragma Warnings (On, "*assumed to be*"); - - -- SI Derived dimensioned subtypes - - subtype Absorbed_Dose is Mks_Type - with - Dimension => (Symbol => "Gy", - Meter => 2, - Second => -2, - others => 0); - - subtype Angle is Mks_Type - with - Dimension => (Symbol => "rad", - others => 0); - - subtype Area is Mks_Type - with - Dimension => ( - Meter => 2, - others => 0); - - subtype Catalytic_Activity is Mks_Type - with - Dimension => (Symbol => "kat", - Second => -1, - Mole => 1, - others => 0); - - subtype Celsius_Temperature is Mks_Type - with - Dimension => (Symbol => "°C", - Kelvin => 1, - others => 0); - - subtype Electric_Capacitance is Mks_Type - with - Dimension => (Symbol => 'F', - Meter => -2, - Kilogram => -1, - Second => 4, - Ampere => 2, - others => 0); - - subtype Electric_Charge is Mks_Type - with - Dimension => (Symbol => 'C', - Second => 1, - Ampere => 1, - others => 0); - - subtype Electric_Conductance is Mks_Type - with - Dimension => (Symbol => 'S', - Meter => -2, - Kilogram => -1, - Second => 3, - Ampere => 2, - others => 0); - - subtype Electric_Potential_Difference is Mks_Type - with - Dimension => (Symbol => 'V', - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -1, - others => 0); - - -- Note the type punning below. The Symbol is a single "ohm" character - -- encoded in UTF-8 (ce a9 in hexadecimal), but this file is not compiled - -- with -gnatW8, so we're treating the string literal as a two-character - -- String. - - subtype Electric_Resistance is Mks_Type - with - Dimension => (Symbol => "Ω", - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -2, - others => 0); - - subtype Energy is Mks_Type - with - Dimension => (Symbol => 'J', - Meter => 2, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Equivalent_Dose is Mks_Type - with - Dimension => (Symbol => "Sv", - Meter => 2, - Second => -2, - others => 0); - - subtype Force is Mks_Type - with - Dimension => (Symbol => 'N', - Meter => 1, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Frequency is Mks_Type - with - Dimension => (Symbol => "Hz", - Second => -1, - others => 0); - - subtype Illuminance is Mks_Type - with - Dimension => (Symbol => "lx", - Meter => -2, - Candela => 1, - others => 0); - - subtype Inductance is Mks_Type - with - Dimension => (Symbol => 'H', - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -2, - others => 0); - - subtype Luminous_Flux is Mks_Type - with - Dimension => (Symbol => "lm", - Candela => 1, - others => 0); - - subtype Magnetic_Flux is Mks_Type - with - Dimension => (Symbol => "Wb", - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); - - subtype Magnetic_Flux_Density is Mks_Type - with - Dimension => (Symbol => 'T', - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); - - subtype Power is Mks_Type - with - Dimension => (Symbol => 'W', - Meter => 2, - Kilogram => 1, - Second => -3, - others => 0); - - subtype Pressure is Mks_Type - with - Dimension => (Symbol => "Pa", - Meter => -1, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Radioactivity is Mks_Type - with - Dimension => (Symbol => "Bq", - Second => -1, - others => 0); - - subtype Solid_Angle is Mks_Type - with - Dimension => (Symbol => "sr", - others => 0); - - subtype Speed is Mks_Type - with - Dimension => ( - Meter => 1, - Second => -1, - others => 0); - - subtype Volume is Mks_Type - with - Dimension => ( - Meter => 3, - others => 0); - - -- Initialize derived dimension values - - -- Turn off the all the dimension warnings for these basic assignments - -- since otherwise we would get complaints about assigning dimensionless - -- values to dimensioned subtypes. - - pragma Warnings (Off, "*assumed to be*"); - - rad : constant Angle := 1.0; - sr : constant Solid_Angle := 1.0; - Hz : constant Frequency := 1.0; - N : constant Force := 1.0; - Pa : constant Pressure := 1.0; - J : constant Energy := 1.0; - W : constant Power := 1.0; - C : constant Electric_Charge := 1.0; - V : constant Electric_Potential_Difference := 1.0; - F : constant Electric_Capacitance := 1.0; - Ohm : constant Electric_Resistance := 1.0; - Si : constant Electric_Conductance := 1.0; - Wb : constant Magnetic_Flux := 1.0; - T : constant Magnetic_Flux_Density := 1.0; - H : constant Inductance := 1.0; - dC : constant Celsius_Temperature := 273.15; - lm : constant Luminous_Flux := 1.0; - lx : constant Illuminance := 1.0; - Bq : constant Radioactivity := 1.0; - Gy : constant Absorbed_Dose := 1.0; - Sv : constant Equivalent_Dose := 1.0; - kat : constant Catalytic_Activity := 1.0; - - -- SI prefixes for Meter - - um : constant Length := 1.0E-06; -- micro (u) - mm : constant Length := 1.0E-03; -- milli - cm : constant Length := 1.0E-02; -- centi - dm : constant Length := 1.0E-01; -- deci - dam : constant Length := 1.0E+01; -- deka - hm : constant Length := 1.0E+02; -- hecto - km : constant Length := 1.0E+03; -- kilo - Mem : constant Length := 1.0E+06; -- mega - - -- SI prefixes for Kilogram - - ug : constant Mass := 1.0E-09; -- micro (u) - mg : constant Mass := 1.0E-06; -- milli - cg : constant Mass := 1.0E-05; -- centi - dg : constant Mass := 1.0E-04; -- deci - g : constant Mass := 1.0E-03; -- gram - dag : constant Mass := 1.0E-02; -- deka - hg : constant Mass := 1.0E-01; -- hecto - Meg : constant Mass := 1.0E+03; -- mega - - -- SI prefixes for Second - - us : constant Time := 1.0E-06; -- micro (u) - ms : constant Time := 1.0E-03; -- milli - cs : constant Time := 1.0E-02; -- centi - ds : constant Time := 1.0E-01; -- deci - das : constant Time := 1.0E+01; -- deka - hs : constant Time := 1.0E+02; -- hecto - ks : constant Time := 1.0E+03; -- kilo - Mes : constant Time := 1.0E+06; -- mega - - -- Other constants for Second - - min : constant Time := 60.0 * s; - hour : constant Time := 60.0 * min; - day : constant Time := 24.0 * hour; - year : constant Time := 365.25 * day; - - -- SI prefixes for Ampere - - mA : constant Electric_Current := 1.0E-03; -- milli - cA : constant Electric_Current := 1.0E-02; -- centi - dA : constant Electric_Current := 1.0E-01; -- deci - daA : constant Electric_Current := 1.0E+01; -- deka - hA : constant Electric_Current := 1.0E+02; -- hecto - kA : constant Electric_Current := 1.0E+03; -- kilo - MeA : constant Electric_Current := 1.0E+06; -- mega - - pragma Warnings (On, "*assumed to be*"); -end System.Dim.Mks; +package System.Dim.Mks is new System.Dim.Generic_Mks (Long_Long_Float); diff --git a/gcc/ada/libgnat/s-dlmkio.ads b/gcc/ada/libgnat/s-dlmkio.ads new file mode 100644 index 0000000..088727a --- /dev/null +++ b/gcc/ada/libgnat/s-dlmkio.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . L O N G _ M K S _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Provides output facilities for the Long_Float MKS dimension system (see +-- System.Dim.Long_Mks and System.Dim.Float_IO). + +with System.Dim.Long_Mks; use System.Dim.Long_Mks; +with System.Dim.Float_IO; + +package System.Dim.Long_Mks_IO is new System.Dim.Float_IO (Mks_Type); diff --git a/gcc/ada/libgnat/s-dlmopr.ads b/gcc/ada/libgnat/s-dlmopr.ads new file mode 100644 index 0000000..c9280b4 --- /dev/null +++ b/gcc/ada/libgnat/s-dlmopr.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . L O N G _ M K S . O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks.Generic_Other_Prefixes; + +package System.Dim.Long_Mks.Other_Prefixes is + new System.Dim.Long_Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/libgnat/s-dmotpr.ads b/gcc/ada/libgnat/s-dmotpr.ads index c0adcb3..041ce37 100644 --- a/gcc/ada/libgnat/s-dmotpr.ads +++ b/gcc/ada/libgnat/s-dmotpr.ads @@ -29,144 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- Package that defines some other prefixes for the MKS base unit system. - --- These prefixes have been defined in a child package in order to avoid too --- many constant declarations in System.Dim_Mks. +with System.Dim.Generic_Mks.Generic_Other_Prefixes; package System.Dim.Mks.Other_Prefixes is - - -- SI prefixes for Meter - - pragma Warnings (Off); - -- Turn off the all the dimension warnings - - ym : constant Length := 1.0E-24; -- yocto - zm : constant Length := 1.0E-21; -- zepto - am : constant Length := 1.0E-18; -- atto - fm : constant Length := 1.0E-15; -- femto - pm : constant Length := 1.0E-12; -- pico - nm : constant Length := 1.0E-09; -- nano - Gm : constant Length := 1.0E+09; -- giga - Tm : constant Length := 1.0E+12; -- tera - Pem : constant Length := 1.0E+15; -- peta - Em : constant Length := 1.0E+18; -- exa - Zem : constant Length := 1.0E+21; -- zetta - Yom : constant Length := 1.0E+24; -- yotta - - -- SI prefixes for Kilogram - - yg : constant Mass := 1.0E-27; -- yocto - zg : constant Mass := 1.0E-24; -- zepto - ag : constant Mass := 1.0E-21; -- atto - fg : constant Mass := 1.0E-18; -- femto - pg : constant Mass := 1.0E-15; -- pico - ng : constant Mass := 1.0E-12; -- nano - Gg : constant Mass := 1.0E+06; -- giga - Tg : constant Mass := 1.0E+09; -- tera - Peg : constant Mass := 1.0E+13; -- peta - Eg : constant Mass := 1.0E+15; -- exa - Zeg : constant Mass := 1.0E+18; -- zetta - Yog : constant Mass := 1.0E+21; -- yotta - - -- SI prefixes for Second - - ys : constant Time := 1.0E-24; -- yocto - zs : constant Time := 1.0E-21; -- zepto - as : constant Time := 1.0E-18; -- atto - fs : constant Time := 1.0E-15; -- femto - ps : constant Time := 1.0E-12; -- pico - ns : constant Time := 1.0E-09; -- nano - Gs : constant Time := 1.0E+09; -- giga - Ts : constant Time := 1.0E+12; -- tera - Pes : constant Time := 1.0E+15; -- peta - Es : constant Time := 1.0E+18; -- exa - Zes : constant Time := 1.0E+21; -- zetta - Yos : constant Time := 1.0E+24; -- yotta - - -- SI prefixes for Ampere - - yA : constant Electric_Current := 1.0E-24; -- yocto - zA : constant Electric_Current := 1.0E-21; -- zepto - aA : constant Electric_Current := 1.0E-18; -- atto - fA : constant Electric_Current := 1.0E-15; -- femto - nA : constant Electric_Current := 1.0E-09; -- nano - uA : constant Electric_Current := 1.0E-06; -- micro (u) - GA : constant Electric_Current := 1.0E+09; -- giga - TA : constant Electric_Current := 1.0E+12; -- tera - PeA : constant Electric_Current := 1.0E+15; -- peta - EA : constant Electric_Current := 1.0E+18; -- exa - ZeA : constant Electric_Current := 1.0E+21; -- zetta - YoA : constant Electric_Current := 1.0E+24; -- yotta - - -- SI prefixes for Kelvin - - yK : constant Thermodynamic_Temperature := 1.0E-24; -- yocto - zK : constant Thermodynamic_Temperature := 1.0E-21; -- zepto - aK : constant Thermodynamic_Temperature := 1.0E-18; -- atto - fK : constant Thermodynamic_Temperature := 1.0E-15; -- femto - pK : constant Thermodynamic_Temperature := 1.0E-12; -- pico - nK : constant Thermodynamic_Temperature := 1.0E-09; -- nano - uK : constant Thermodynamic_Temperature := 1.0E-06; -- micro (u) - mK : constant Thermodynamic_Temperature := 1.0E-03; -- milli - cK : constant Thermodynamic_Temperature := 1.0E-02; -- centi - dK : constant Thermodynamic_Temperature := 1.0E-01; -- deci - daK : constant Thermodynamic_Temperature := 1.0E+01; -- deka - hK : constant Thermodynamic_Temperature := 1.0E+02; -- hecto - kK : constant Thermodynamic_Temperature := 1.0E+03; -- kilo - MeK : constant Thermodynamic_Temperature := 1.0E+06; -- mega - GK : constant Thermodynamic_Temperature := 1.0E+09; -- giga - TK : constant Thermodynamic_Temperature := 1.0E+12; -- tera - PeK : constant Thermodynamic_Temperature := 1.0E+15; -- peta - EK : constant Thermodynamic_Temperature := 1.0E+18; -- exa - ZeK : constant Thermodynamic_Temperature := 1.0E+21; -- zetta - YoK : constant Thermodynamic_Temperature := 1.0E+24; -- yotta - - -- SI prefixes for Mole - - ymol : constant Amount_Of_Substance := 1.0E-24; -- yocto - zmol : constant Amount_Of_Substance := 1.0E-21; -- zepto - amol : constant Amount_Of_Substance := 1.0E-18; -- atto - fmol : constant Amount_Of_Substance := 1.0E-15; -- femto - pmol : constant Amount_Of_Substance := 1.0E-12; -- pico - nmol : constant Amount_Of_Substance := 1.0E-09; -- nano - umol : constant Amount_Of_Substance := 1.0E-06; -- micro (u) - mmol : constant Amount_Of_Substance := 1.0E-03; -- milli - cmol : constant Amount_Of_Substance := 1.0E-02; -- centi - dmol : constant Amount_Of_Substance := 1.0E-01; -- deci - damol : constant Amount_Of_Substance := 1.0E+01; -- deka - hmol : constant Amount_Of_Substance := 1.0E+02; -- hecto - kmol : constant Amount_Of_Substance := 1.0E+03; -- kilo - Memol : constant Amount_Of_Substance := 1.0E+06; -- mega - Gmol : constant Amount_Of_Substance := 1.0E+09; -- giga - Tmol : constant Amount_Of_Substance := 1.0E+12; -- tera - Pemol : constant Amount_Of_Substance := 1.0E+15; -- peta - Emol : constant Amount_Of_Substance := 1.0E+18; -- exa - Zemol : constant Amount_Of_Substance := 1.0E+21; -- zetta - Yomol : constant Amount_Of_Substance := 1.0E+24; -- yotta - - -- SI prefixes for Candela - - ycd : constant Luminous_Intensity := 1.0E-24; -- yocto - zcd : constant Luminous_Intensity := 1.0E-21; -- zepto - acd : constant Luminous_Intensity := 1.0E-18; -- atto - fcd : constant Luminous_Intensity := 1.0E-15; -- femto - pcd : constant Luminous_Intensity := 1.0E-12; -- pico - ncd : constant Luminous_Intensity := 1.0E-09; -- nano - ucd : constant Luminous_Intensity := 1.0E-06; -- micro (u) - mcd : constant Luminous_Intensity := 1.0E-03; -- milli - ccd : constant Luminous_Intensity := 1.0E-02; -- centi - dcd : constant Luminous_Intensity := 1.0E-01; -- deci - dacd : constant Luminous_Intensity := 1.0E+01; -- deka - hcd : constant Luminous_Intensity := 1.0E+02; -- hecto - kcd : constant Luminous_Intensity := 1.0E+03; -- kilo - Mecd : constant Luminous_Intensity := 1.0E+06; -- mega - Gcd : constant Luminous_Intensity := 1.0E+09; -- giga - Tcd : constant Luminous_Intensity := 1.0E+12; -- tera - Pecd : constant Luminous_Intensity := 1.0E+15; -- peta - Ecd : constant Luminous_Intensity := 1.0E+18; -- exa - Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta - Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta - - pragma Warnings (On); -end System.Dim.Mks.Other_Prefixes; + new System.Dim.Mks.Generic_Other_Prefixes; -- cgit v1.1 From 2e5df2955f9ec8deafeb2978fcb38fb99f2660fd Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:46:34 +0000 Subject: [Ada] Spurious "Duplicated symbol" error with discriminated tasks This patch fixes a spurious error in a program that contains a discriminated task type and several of its subtype in the same declarative part, when the corresponding discriminant constraints are expressions. 2018-08-21 Ed Schonberg gcc/ada/ * sem_util.ads, sem_util.adb (New_External_Entity): Type of Suffix_Index must be Int, not Nat, so that a negative value can be used to generate a unique name for an external object, as specified in Tbuild.New_External_Name. (Scope_Within): Handle private type whose completion is a synchronized type (For unnesting). * itypes.ads, itypes.adb (Create_Itype): Ditto * sem_ch3.adb (Constrain_Corresponding_Record): Generate a unique name for the created subtype, because there may be several discriminated tasks present in the same scope, and each needs its distinct corresponding record subtype. gcc/testsuite/ * gnat.dg/task1.adb, gnat.dg/task1.ads, gnat.dg/task1_pkg.adb, gnat.dg/task1_pkg.ads: New testcase. From-SVN: r263716 --- gcc/ada/ChangeLog | 14 ++++++++++++++ gcc/ada/itypes.adb | 2 +- gcc/ada/itypes.ads | 2 +- gcc/ada/sem_ch3.adb | 4 +++- gcc/ada/sem_util.adb | 11 ++++++++++- gcc/ada/sem_util.ads | 2 +- 6 files changed, 30 insertions(+), 5 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2b17d4a..df4a9db 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2018-08-21 Ed Schonberg + + * sem_util.ads, sem_util.adb (New_External_Entity): Type of + Suffix_Index must be Int, not Nat, so that a negative value can + be used to generate a unique name for an external object, as + specified in Tbuild.New_External_Name. + (Scope_Within): Handle private type whose completion is a + synchronized type (For unnesting). + * itypes.ads, itypes.adb (Create_Itype): Ditto + * sem_ch3.adb (Constrain_Corresponding_Record): Generate a + unique name for the created subtype, because there may be + several discriminated tasks present in the same scope, and each + needs its distinct corresponding record subtype. + 2018-08-21 Yannick Moy * doc/gnat_ugn/gnat_and_program_execution.rst: Update diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index fa88ef7..6640c57 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -42,7 +42,7 @@ package body Itypes is Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; Suffix : Character := ' '; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Scope_Id : Entity_Id := Current_Scope) return Entity_Id is Typ : Entity_Id; diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads index e59cbe8..1513c8a 100644 --- a/gcc/ada/itypes.ads +++ b/gcc/ada/itypes.ads @@ -110,7 +110,7 @@ package Itypes is Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; Suffix : Character := ' '; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Scope_Id : Entity_Id := Current_Scope) return Entity_Id; -- Used to create a new Itype -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 349ece7..d12ccc9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9453,6 +9453,7 @@ package body Sem_Ch3 is (Derived_Type, Save_Discr_Constr); Set_Stored_Constraint (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); + Replace_Components (Derived_Type, New_Decl); end if; @@ -13692,7 +13693,8 @@ package body Sem_Ch3 is Related_Nod : Node_Id) return Entity_Id is T_Sub : constant Entity_Id := - Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); + Create_Itype (E_Record_Subtype, + Related_Nod, Corr_Rec, 'C', Suffix_Index => -1); begin Set_Etype (T_Sub, Corr_Rec); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index bfa2b4f..a8ea805 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20997,7 +20997,7 @@ package body Sem_Util is Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Character; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Prefix : Character := ' ') return Entity_Id is N : constant Entity_Id := @@ -24039,6 +24039,15 @@ package body Sem_Util is and then Outer = Protected_Body_Subprogram (Curr) then return True; + + -- OUtside of its scope, a synchronized type may just be + -- private. + + elsif Is_Private_Type (Curr) + and then Present (Full_View (Curr)) + and then Is_Concurrent_Type (Full_View (Curr)) + then + return Scope_Within (Full_View (Curr), Outer); end if; end loop; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index aec3644..74d670d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2326,7 +2326,7 @@ package Sem_Util is Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Character; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Prefix : Character := ' ') return Entity_Id; -- This function creates an N_Defining_Identifier node for an internal -- created entity, such as an implicit type or subtype, or a record -- cgit v1.1 From 294e7bbb9eb0b1f8d0484e9ddb562a08f7505cab Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 21 Aug 2018 14:46:40 +0000 Subject: [Ada] Fix internal error on extension of record with representation clause This fixes a long-standing issue present for extensions of tagged record types with a representation clause: the clause is correctly inherited for components inherited in the extension but the position and size are not, which fools the logic of Is_Possibly_Unaligned_Object. This can result in an attempt to take the address of a component not aligned on a byte boundary, which is then flagged as an internal error. 2018-08-21 Eric Botcazou gcc/ada/ * exp_util.adb (Is_Possibly_Unaligned_Object): For the case of a selected component inherited in a record extension and subject to a representation clause, retrieve the position and size from the original record component. gcc/testsuite/ * gnat.dg/rep_clause7.adb: New testcase. From-SVN: r263717 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/exp_util.adb | 21 +++++++++++++++++++-- 2 files changed, 26 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index df4a9db..27bb79d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-08-21 Eric Botcazou + + * exp_util.adb (Is_Possibly_Unaligned_Object): For the case of a + selected component inherited in a record extension and subject + to a representation clause, retrieve the position and size from + the original record component. + 2018-08-21 Ed Schonberg * sem_util.ads, sem_util.adb (New_External_Entity): Type of diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 3bed508..632c879 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8402,9 +8402,26 @@ package body Exp_Util is declare Align_In_Bits : constant Nat := M * System_Storage_Unit; + Off : Uint; + Siz : Uint; begin - if Component_Bit_Offset (C) mod Align_In_Bits /= 0 - or else Esize (C) mod Align_In_Bits /= 0 + -- For a component inherited in a record extension, the + -- clause is inherited but position and size are not set. + + if Is_Base_Type (Etype (P)) + and then Is_Tagged_Type (Etype (P)) + and then Present (Original_Record_Component (C)) + then + Off := + Component_Bit_Offset (Original_Record_Component (C)); + Siz := Esize (Original_Record_Component (C)); + else + Off := Component_Bit_Offset (C); + Siz := Esize (C); + end if; + + if Off mod Align_In_Bits /= 0 + or else Siz mod Align_In_Bits /= 0 then return True; end if; -- cgit v1.1 From 1ab1c4ee18d7866249fb99bcc9d073fcb475dc9d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 21 Aug 2018 14:46:45 +0000 Subject: [Ada] Fix spurious error on unchecked conversion on VFA record type 2018-08-21 Eric Botcazou gcc/ada/ * gcc-interface/trans.c (Call_to_gnu): Always suppress an unchecked conversion around the actual for an In parameter passed by copy. From-SVN: r263718 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/gcc-interface/trans.c | 1 + 2 files changed, 7 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 27bb79d..e882e39 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,11 @@ 2018-08-21 Eric Botcazou + * gcc-interface/trans.c (Call_to_gnu): Always suppress an + unchecked conversion around the actual for an In parameter + passed by copy. + +2018-08-21 Eric Botcazou + * exp_util.adb (Is_Possibly_Unaligned_Object): For the case of a selected component inherited in a record extension and subject to a representation clause, retrieve the position and size from diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 0371d00..940bf5f 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -4450,6 +4450,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, const bool suppress_type_conversion = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion && (!in_param + || !is_by_ref_formal_parm || (Is_Composite_Type (Underlying_Type (gnat_formal_type)) && !Is_Constrained (Underlying_Type (gnat_formal_type))))) || (Nkind (gnat_actual) == N_Type_Conversion -- cgit v1.1 From d2a60e59111707eb51430cd741eefccc77e1653b Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:46:49 +0000 Subject: [Ada] Improper copying of limited arrays with default initialization This patch fixes an improper expansion of aggregates for limited array types in an object declaration. Prior to this patch, The presence of the aggregate (which can only consist of box initializations) would create a temporary that was then assigned to the object in the declaration. Apart from a violation of the semantics of build-in-place limited objects, this can also lead to out-of-scope access in LLVM. Executing the following; gcc -c -gnatDG nocopy.adb grep quintet nocopy.adb.dg | wc -l must yield: 5 ---- procedure NoCopy is -- Task used in this example to test that the limited component -- is properly initialized. task type T_Task (Disc : Natural); task body T_Task is begin null; end T_Task; type My_Rec (D : Natural := 9999) is record -- Components initialized by means of the current value -- of the record discriminant T : T_Task (D); end record; type TR is array (1 .. 5) of My_Rec; Quintet : TR := (others => (others => <>)); begin null; end NoCopy; 2018-08-21 Ed Schonberg gcc/ada/ * exp_aggr.adb (Expand_Array_Aggregate): If the component type is limited, the array must be constructed in place, so set flag In_Place_Assign_OK_For_Declaration accordingly. This prevents improper copying of an array of tasks during initialization. From-SVN: r263719 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/exp_aggr.adb | 33 ++++++++++++++++++++++++++------- 2 files changed, 33 insertions(+), 7 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e882e39..d0ad28d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-08-21 Ed Schonberg + + * exp_aggr.adb (Expand_Array_Aggregate): If the component type + is limited, the array must be constructed in place, so set flag + In_Place_Assign_OK_For_Declaration accordingly. This prevents + improper copying of an array of tasks during initialization. + 2018-08-21 Eric Botcazou * gcc-interface/trans.c (Call_to_gnu): Always suppress an diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9d9ab6a..d1d9c12 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6195,10 +6195,11 @@ package body Exp_Aggr is -- Look if in place aggregate expansion is possible -- For object declarations we build the aggregate in place, unless - -- the array is bit-packed or the component is controlled. + -- the array is bit-packed. -- For assignments we do the assignment in place if all the component - -- associations have compile-time known values. For other cases we + -- associations have compile-time known values, or are default- + -- initialized limited components, e.g. tasks. For other cases we -- create a temporary. The analysis for safety of on-line assignment -- is delicate, i.e. we don't know how to do it fully yet ??? @@ -6211,7 +6212,12 @@ package body Exp_Aggr is Establish_Transient_Scope (N, Manage_Sec_Stack => False); end if; - if Has_Default_Init_Comps (N) then + -- An array of limited components is built in place. + + if Is_Limited_Type (Typ) then + Maybe_In_Place_OK := True; + + elsif Has_Default_Init_Comps (N) then Maybe_In_Place_OK := False; elsif Is_Bit_Packed_Array (Typ) @@ -6247,15 +6253,17 @@ package body Exp_Aggr is -- expected to appear in qualified form. In-place expansion eliminates -- the qualification and eventually violates this SPARK 05 restiction. - -- Should document the rest of the guards ??? + -- Arrays of limited components must be built in place. The code + -- previously excluded controlled components but this is an old + -- oversight: the rules in 7.6 (17) are clear. - if not Has_Default_Init_Comps (N) + if (not Has_Default_Init_Comps (N) + or else Is_Limited_Type (Etype (N))) and then Comes_From_Source (Parent_Node) and then Parent_Kind = N_Object_Declaration and then Present (Expression (Parent_Node)) and then not Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ) - and then not Has_Controlled_Component (Typ) and then not Is_Bit_Packed_Array (Typ) and then not Restriction_Check_Required (SPARK_05) then @@ -6292,6 +6300,15 @@ package body Exp_Aggr is Set_Expansion_Delayed (N); return; + -- Limited arrays in return statements are expanded when + -- enclosing construct is expanded. + + elsif Maybe_In_Place_OK + and then Nkind (Parent (N)) = N_Simple_Return_Statement + then + Set_Expansion_Delayed (N); + return; + -- In the remaining cases the aggregate is the RHS of an assignment elsif Maybe_In_Place_OK @@ -6365,7 +6382,9 @@ package body Exp_Aggr is Target := New_Occurrence_Of (Tmp, Loc); else - if Has_Default_Init_Comps (N) then + if Has_Default_Init_Comps (N) + and then not Maybe_In_Place_OK + then -- Ada 2005 (AI-287): This case has not been analyzed??? -- cgit v1.1 From c7fafef9742fac01de19c1422d769eeb9b368109 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:46:54 +0000 Subject: [Ada] Unnesting: do not emit warnings for access to subprograms 2018-08-21 Ed Schonberg gcc/ada/ * freeze.adb: Remove warnings for access to subprograms when unnesting is active. From-SVN: r263720 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/freeze.adb | 6 +++++- 2 files changed, 10 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d0ad28d..9737c07 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,10 @@ 2018-08-21 Ed Schonberg + * freeze.adb: Remove warnings for access to subprograms when + unnesting is active. + +2018-08-21 Ed Schonberg + * exp_aggr.adb (Expand_Array_Aggregate): If the component type is limited, the array must be constructed in place, so set flag In_Place_Assign_OK_For_Declaration accordingly. This prevents diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 9979cbf..ea9454a 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3611,10 +3611,14 @@ package body Freeze is Error_Msg_Qual_Level := 1; - -- Check suspicious use of fat C pointer + -- Check suspicious use of fat C pointer, but do not emit + -- a warning on an access to subprogram when unnesting is + -- active. if Is_Access_Type (F_Type) and then Esize (F_Type) > Ttypes.System_Address_Size + and then (not Unnest_Subprogram_Mode + or else not Is_Access_Subprogram_Type (F_Type)) then Error_Msg_N ("?x?type of & does not correspond to C pointer!", Formal); -- cgit v1.1 From 5c0972ba85975672ae89ce70a562133a506689d1 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:46:59 +0000 Subject: [Ada] Unnesting: do not set size of access subprograms 2018-08-21 Ed Schonberg gcc/ada/ * layout.adb: Do not set size of access subprogram if unnesting. From-SVN: r263721 --- gcc/ada/ChangeLog | 4 ++++ gcc/ada/layout.adb | 11 +++++++++++ 2 files changed, 15 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9737c07..dee7064 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,9 @@ 2018-08-21 Ed Schonberg + * layout.adb: Do not set size of access subprogram if unnesting. + +2018-08-21 Ed Schonberg + * freeze.adb: Remove warnings for access to subprograms when unnesting is active. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 6b77757..23436c8 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -325,6 +325,17 @@ package body Layout is then Init_Size (E, 2 * System_Address_Size); + -- If unnesting subprograms, subprogram access types contain the + -- address of both the subprogram and an activation record. But + -- if we set that, we'll get a warning on different unchecked + -- conversion sizes in the RTS. So leave unset ub that case. + + elsif Unnest_Subprogram_Mode + and then Is_Access_Subprogram_Type (E) + then + -- Init_Size (E, 2 * System_Address_Size); + null; + -- Normal case of thin pointer else -- cgit v1.1 From dc88759c874104bbf96cb56e44f2ea319541324a Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 21 Aug 2018 14:47:05 +0000 Subject: [Ada] Crash compiling SPARK ghost functions with callgraph info The compiler blows up generating the callgraph output of SPARK ghost subprograms whose contracts invoke ghost functions. 2018-08-21 Javier Miranda gcc/ada/ * exp_cg.adb (Generate_CG_Output): Handle calls removed by the expander. From-SVN: r263722 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/exp_cg.adb | 9 ++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dee7064..e9e674b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-08-21 Javier Miranda + + * exp_cg.adb (Generate_CG_Output): Handle calls removed by the + expander. + 2018-08-21 Ed Schonberg * layout.adb: Do not set size of access subprogram if unnesting. diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 00f029b..f40dc7e 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -121,7 +121,14 @@ package body Exp_CG is for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop N := Call_Graph_Nodes.Table (J); - if Nkind (N) in N_Subprogram_Call then + -- No action needed for subprogram calls removed by the expander + -- (for example, calls to ignored ghost entities). + + if Nkind (N) = N_Null_Statement then + pragma Assert (Nkind (Original_Node (N)) in N_Subprogram_Call); + null; + + elsif Nkind (N) in N_Subprogram_Call then Write_Call_Info (N); else pragma Assert (Nkind (N) = N_Defining_Identifier); -- cgit v1.1 From 1bd9b6a5766c03bc6741d5599076476bd1c9d2b0 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:47:12 +0000 Subject: [Ada] Sprint: add guard on printing aspects 2018-08-21 Ed Schonberg gcc/ada/ * sprint.adb: Add guard on printing aspects. From-SVN: r263723 --- gcc/ada/ChangeLog | 4 ++++ gcc/ada/sprint.adb | 6 ++++-- 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e9e674b..4afe997 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2018-08-21 Ed Schonberg + + * sprint.adb: Add guard on printing aspects. + 2018-08-21 Javier Miranda * exp_cg.adb (Generate_CG_Output): Handle calls removed by the diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index f19629c..7978823 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3540,8 +3540,10 @@ package body Sprint is -- where the aspects are printed inside the package specification. if Has_Aspects (Node) - and then not Nkind_In (Node, N_Package_Declaration, - N_Generic_Package_Declaration) + and then not Nkind_In (Node, N_Package_Declaration, + N_Generic_Package_Declaration) + and then not Is_Empty_List (Aspect_Specifications (Node)) + and then not Is_Empty_List (Aspect_Specifications (Node)) then Sprint_Aspect_Specifications (Node, Semicolon => True); end if; -- cgit v1.1 From 78645ad8c7bfaa223ab35595773a4af56660403b Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:47:18 +0000 Subject: [Ada] Set scope of elaboration flag for 'Access 2018-08-21 Ed Schonberg gcc/ada/ * sem_attr.adb: Set scope of elaboration flag for 'Access. From-SVN: r263724 --- gcc/ada/ChangeLog | 4 ++++ gcc/ada/sem_attr.adb | 9 +++++++++ 2 files changed, 13 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4afe997..312d891 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,9 @@ 2018-08-21 Ed Schonberg + * sem_attr.adb: Set scope of elaboration flag for 'Access. + +2018-08-21 Ed Schonberg + * sprint.adb: Add guard on printing aspects. 2018-08-21 Javier Miranda diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cb1b2d5d..96eb488 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11245,6 +11245,15 @@ package body Sem_Attr is New_Occurrence_Of (Standard_Short_Integer, Loc), Expression => Make_Integer_Literal (Loc, Uint_0))); + + -- The above sets the Scope of the flag entity to the + -- current scope, in which the attribute appears, but + -- the flag declaration has been inserted after that + -- of Subp_Id, so the scope of the flag the same as + -- that of Subp_Id. This is relevant when unnesting, + -- whereh processing depends on correct scope settingl + + Set_Scope (Flag_Id, Scop); end if; -- Taking the 'Access of an expression function freezes its -- cgit v1.1 From 298e0c6bf77b2e218bd5f8a386ecfdd4e7c9ab52 Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Tue, 21 Aug 2018 14:47:25 +0000 Subject: [Ada] Document entries of the target parametrization file 2018-08-21 Yannick Moy gcc/ada/ * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Document entries of the target parametrization file. * gnat_ugn.texi: Regenerate. From-SVN: r263725 --- gcc/ada/ChangeLog | 6 ++++ .../building_executable_programs_with_gnat.rst | 33 +++++++++++++++++++++- gcc/ada/gnat_ugn.texi | 30 ++++++++++++++++++-- 3 files changed, 66 insertions(+), 3 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 312d891..0c558c0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-08-21 Yannick Moy + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Document entries of the target parametrization file. + * gnat_ugn.texi: Regenerate. + 2018-08-21 Ed Schonberg * sem_attr.adb: Set scope of elaboration flag for 'Access. diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index e79f630..1455087 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -1692,13 +1692,44 @@ Alphabetical List of All Switches Maximum_Alignment : Pos; -- Maximum permitted alignment Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field Pointer_Size : Pos; -- System.Address'Size - Short_Enums : Nat; -- Short foreign convention enums? + Short_Enums : Nat; -- Foreign enums use short size? Short_Size : Pos; -- Standard.Short_Integer'Size Strict_Alignment : Nat; -- Strict alignment? System_Allocator_Alignment : Nat; -- Alignment for malloc calls Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size Words_BE : Nat; -- Words stored big-endian? + ``Bits_Per_Unit`` is the number of bits in a storage unit, the equivalent of + GCC macro ``BITS_PER_UNIT`` documented as follows: `Define this macro to be + the number of bits in an addressable storage unit (byte); normally 8.` + + ``Bits_Per_Word`` is the number of bits in a machine word, the equivalent of + GCC macro ``BITS_PER_WORD`` documented as follows: `Number of bits in a word; + normally 32.` + + ``Double_Scalar_Alignment`` is the alignment for a scalar whose size is two + machine words. It should be the same as the alignment for C ``long_long`` on + most targets. + + ``Maximum_Alignment`` is the maximum alignment that the compiler might choose + by default for a type or object, which is also the maximum alignment that can + be specified in GNAT. It is computed for GCC backends as ``BIGGEST_ALIGNMENT + / BITS_PER_UNIT`` where GCC macro ``BIGGEST_ALIGNMENT`` is documented as + follows: `Biggest alignment that any data type can require on this machine, + in bits.` + + ``Max_Unaligned_Field`` is the maximum size for unaligned bit field, which is + 64 for the majority of GCC targets (but can be different on some targets like + AAMP). + + ``Strict_Alignment`` is the equivalent of GCC macro ``STRICT_ALIGNMENT`` + documented as follows: `Define this macro to be the value 1 if instructions + will fail to work if given data not on the nominal alignment. If instructions + will merely go slower in that case, define this macro as 0.` + + ``System_Allocator_Alignment`` is the guaranteed alignment of data returned + by calls to ``malloc``. + The format of the input file is as follows. First come the values of the variables defined above, with one line per value: diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index dfff37d..aeaa146 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Aug 17, 2018 +GNAT User's Guide for Native Platforms , Aug 20, 2018 AdaCore @@ -9429,7 +9429,7 @@ Long_Size : Pos; -- Standard.Long_Integer'Size Maximum_Alignment : Pos; -- Maximum permitted alignment Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field Pointer_Size : Pos; -- System.Address'Size -Short_Enums : Nat; -- Short foreign convention enums? +Short_Enums : Nat; -- Foreign enums use short size? Short_Size : Pos; -- Standard.Short_Integer'Size Strict_Alignment : Nat; -- Strict alignment? System_Allocator_Alignment : Nat; -- Alignment for malloc calls @@ -9437,6 +9437,32 @@ Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size Words_BE : Nat; -- Words stored big-endian? @end example +@code{Bits_Per_Unit} is the number of bits in a storage unit, the equivalent of +GCC macro @code{BITS_PER_UNIT} documented as follows: @cite{Define this macro to be the number of bits in an addressable storage unit (byte); normally 8.} + +@code{Bits_Per_Word} is the number of bits in a machine word, the equivalent of +GCC macro @code{BITS_PER_WORD} documented as follows: @cite{Number of bits in a word; normally 32.} + +@code{Double_Scalar_Alignment} is the alignment for a scalar whose size is two +machine words. It should be the same as the alignment for C @code{long_long} on +most targets. + +@code{Maximum_Alignment} is the maximum alignment that the compiler might choose +by default for a type or object, which is also the maximum alignment that can +be specified in GNAT. It is computed for GCC backends as @code{BIGGEST_ALIGNMENT +/ BITS_PER_UNIT} where GCC macro @code{BIGGEST_ALIGNMENT} is documented as +follows: @cite{Biggest alignment that any data type can require on this machine@comma{} in bits.} + +@code{Max_Unaligned_Field} is the maximum size for unaligned bit field, which is +64 for the majority of GCC targets (but can be different on some targets like +AAMP). + +@code{Strict_Alignment} is the equivalent of GCC macro @code{STRICT_ALIGNMENT} +documented as follows: @cite{Define this macro to be the value 1 if instructions will fail to work if given data not on the nominal alignment. If instructions will merely go slower in that case@comma{} define this macro as 0.} + +@code{System_Allocator_Alignment} is the guaranteed alignment of data returned +by calls to @code{malloc}. + The format of the input file is as follows. First come the values of the variables defined above, with one line per value: -- cgit v1.1 From 41306c0a89a539c97e8eee0867816ea3ae5ab5b7 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:47:32 +0000 Subject: [Ada] Spurious ambiguity error on call returning an access type If F is a function with a single defaulted parameter that returns an access_to_array type, then F (I) may designate either the return type or an indexing of the result of the call, after implicit dereferencing. If the component type C of the array type AR is accces AR this is ambiguous in a context whose expected type is C. If F is parameterless the call is not ambiguous. 2018-08-21 Ed Schonberg gcc/ada/ * sem_res.adb (Resolve_Call): Resolve correctly a parameterless call that returns an access type whose designated type is the component type of an array, when the function has no defaulted parameters. gcc/testsuite/ * gnat.dg/access5.adb, gnat.dg/access5.ads: New testcase. From-SVN: r263726 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/sem_res.adb | 13 ++++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0c558c0..5ac1463 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-08-21 Ed Schonberg + + * sem_res.adb (Resolve_Call): Resolve correctly a parameterless + call that returns an access type whose designated type is the + component type of an array, when the function has no defaulted + parameters. + 2018-08-21 Yannick Moy * doc/gnat_ugn/building_executable_programs_with_gnat.rst: diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 13612aa..5a1a9f7 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6128,7 +6128,18 @@ package body Sem_Res is Ret_Type : constant Entity_Id := Etype (Nam); begin - if Is_Access_Type (Ret_Type) + -- If this is a parameterless call there is no ambiguity + -- and the call has the type of the function. + + if No (First_Actual (N)) then + Set_Etype (N, Etype (Nam)); + if Present (First_Formal (Nam)) then + Resolve_Actuals (N, Nam); + end if; + Build_Call_Marker (N); + + elsif Is_Access_Type (Ret_Type) + and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) then Error_Msg_N -- cgit v1.1 From 7d8cc2b6d17fa3fa2c0683286926556da6d3bb6f Mon Sep 17 00:00:00 2001 From: Maroua Maalej Date: Tue, 21 Aug 2018 14:47:38 +0000 Subject: [Ada] Update for Ownership rules for access types according to AI12-0240 The implementation of these Ownership rules for safe pointers and automatic memory management is still a prototype at an experimental stage. To activate the checks, the code should be compiled with the debug flag -gnatdF and the flag -gnatd.F for setting the context for formal verification of SPARK. These changes do not affect compilation. 2018-08-21 Maroua Maalej gcc/ada/ * sem_spark.adb (Check_Call_Statement): Check global and formal parameter permissions at call sites. (Check_Callable_Body): Assume permissions on globals and parameters depending on their modes then analyse the body operations. (Check_Declaration): Consider both deep (including elementary access) object declarations and normal variables. First check whether the deep object is of Ownership Aspec True or not, then, depending on its initialization, assign the appropriate state. Check related to non access type variables deal with initialization value permissions. (Check_Expression): Check nodes used in the expression being analyzed. (Check_Globals): Call by Check_Call_Statement to perform the check on globals. (Check_List): Call Check_Node on each element of the list. (Check_Loop_Statement): Check the Iteration_Scheme and loop statements. (Check_Node): Main traversal procedure to check safe pointer usage. (Check_Package_Body): Check subprogram's body. (Check_Param_In): Take a formal and an actual parameter and Check the permission of every in-mode parameter. (Check_Param_Out): Take a formal and an actual parameter and check the state of out-mode and in out-mode parameters. (Check_Statement): Check statements other than procedure call. (Get_Perm, Get_Perm_Or_Tree, Get_Perm_Tree): Find out the state related to the given name. (Is_Deep): Return True if an object is of access type or has subfields of access type. (Perm_Error, Perm_Error_Subprogram_End): Add an error message whenever the found state on the given name is different from the one expected (in the statement being analyzed). (Process_Path): Given an operation and a current state, call Perm_Error if there is any mismatch. (Return_Declarations, Return_Globals, Return_The_Global): Check the state of a given name at the end of the subprogram. These procedures may change depending on how we shall finally deal with globals and the rhs state in a move operation. (Set_Perm_Extensions, Set_Perm_Prefixes_Borrow, Set_Perm_Prefixes, Setup_Globals, Setup_Parameter_Or_Global, Setup_Parameters): Set up the new states to the given node and up and down the tree after an operation. (Has_Ownership_Aspect_True): This function may disappear later when the Ownership Aspect will be implemented in the FE. From-SVN: r263727 --- gcc/ada/ChangeLog | 47 + gcc/ada/sem_spark.adb | 4394 ++++++++++++++++--------------------------------- 2 files changed, 1437 insertions(+), 3004 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ac1463..f34ebbd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2018-08-21 Maroua Maalej + + * sem_spark.adb (Check_Call_Statement): Check global and formal + parameter permissions at call sites. + (Check_Callable_Body): Assume permissions on globals and + parameters depending on their modes then analyse the body + operations. + (Check_Declaration): Consider both deep (including elementary + access) object declarations and normal variables. First check + whether the deep object is of Ownership Aspec True or not, then, + depending on its initialization, assign the appropriate state. + Check related to non access type variables deal with + initialization value permissions. + (Check_Expression): Check nodes used in the expression being + analyzed. + (Check_Globals): Call by Check_Call_Statement to perform the + check on globals. + (Check_List): Call Check_Node on each element of the list. + (Check_Loop_Statement): Check the Iteration_Scheme and loop + statements. + (Check_Node): Main traversal procedure to check safe pointer usage. + (Check_Package_Body): Check subprogram's body. + (Check_Param_In): Take a formal and an actual parameter and + Check the permission of every in-mode parameter. + (Check_Param_Out): Take a formal and an actual parameter and + check the state of out-mode and in out-mode parameters. + (Check_Statement): Check statements other than procedure call. + (Get_Perm, Get_Perm_Or_Tree, Get_Perm_Tree): Find out the state + related to the given name. + (Is_Deep): Return True if an object is of access type or has + subfields of access type. + (Perm_Error, Perm_Error_Subprogram_End): Add an error message + whenever the found state on the given name is different from the + one expected (in the statement being analyzed). + (Process_Path): Given an operation and a current state, call + Perm_Error if there is any mismatch. + (Return_Declarations, Return_Globals, Return_The_Global): Check + the state of a given name at the end of the subprogram. These + procedures may change depending on how we shall finally deal + with globals and the rhs state in a move operation. + (Set_Perm_Extensions, Set_Perm_Prefixes_Borrow, + Set_Perm_Prefixes, Setup_Globals, Setup_Parameter_Or_Global, + Setup_Parameters): Set up the new states to the given node and + up and down the tree after an operation. + (Has_Ownership_Aspect_True): This function may disappear later + when the Ownership Aspect will be implemented in the FE. + 2018-08-21 Ed Schonberg * sem_res.adb (Resolve_Call): Resolve correctly a parameterless diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index 3abfd99..e522620 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -52,15 +52,16 @@ package body Sem_SPARK is type Elaboration_Context_Index is range 0 .. Elaboration_Context_Max - 1; - function Elaboration_Context_Hash - (Key : Entity_Id) return Elaboration_Context_Index; + function Elaboration_Context_Hash (Key : Entity_Id) + return Elaboration_Context_Index; -- Function to hash any node of the AST - type Perm_Kind is (No_Access, Read_Only, Read_Write, Write_Only); - -- Permission type associated with paths - - subtype Read_Perm is Perm_Kind range Read_Only .. Read_Write; - subtype Write_Perm is Perm_Kind range Read_Write .. Write_Only; + type Perm_Kind is (Borrowed, Observed, Unrestricted, Moved); + -- Permission type associated with paths. The Moved permission is + -- equivalent to the Unrestricted one (same permissions). The Moved is + -- however used to mark the RHS after a move (which still unrestricted). + -- This way, we may generate warnings when manipulating the RHS + -- afterwads since it is set to Null after the assignment. type Perm_Tree_Wrapper; @@ -94,6 +95,7 @@ package body Sem_SPARK is -- The definition of permission trees. This is a tree, which has a -- permission at each node, and depending on the type of the node, -- can have zero, one, or more children pointed to by an access to tree. + type Perm_Tree (Kind : Path_Kind := Entire_Object) is record Permission : Perm_Kind; -- Permission at this level in the path @@ -103,7 +105,6 @@ package body Sem_SPARK is -- path. case Kind is - -- An entire object is either a leaf (an object which cannot be -- extended further in a path) or a subtree in folded form (which -- could later be unfolded further in another kind of node). The @@ -111,19 +112,19 @@ package body Sem_SPARK is -- extension of that node if that permission is different from -- the node's permission. - when Entire_Object => + when Entire_Object => Children_Permission : Perm_Kind; -- Unfolded path of access type. The permission of the object -- pointed to is given in Get_All. - when Reference => + when Reference => Get_All : Perm_Tree_Access; -- Unfolded path of array type. The permission of the elements is -- given in Get_Elem. - when Array_Component => + when Array_Component => Get_Elem : Perm_Tree_Access; -- Unfolded path of record type. The permission of the regular @@ -229,7 +230,7 @@ package body Sem_SPARK is -------------------- procedure Perm_Mismatch - (Exp_Perm, Act_Perm : Perm_Kind; + (Exp_Perm, Act_Perm : Perm_Kind; N : Node_Id); -- Issues a continuation error message about a mismatch between a -- desired permission Exp_Perm and a permission obtained Act_Perm. N @@ -243,10 +244,7 @@ package body Sem_SPARK is -- Children_Permission -- ------------------------- - function Children_Permission - (T : Perm_Tree_Access) - return Perm_Kind - is + function Children_Permission (T : Perm_Tree_Access) return Perm_Kind is begin return T.all.Tree.Children_Permission; end Children_Permission; @@ -257,7 +255,7 @@ package body Sem_SPARK is function Component (T : Perm_Tree_Access) - return Perm_Tree_Maps.Instance + return Perm_Tree_Maps.Instance is begin return T.all.Tree.Component; @@ -267,13 +265,10 @@ package body Sem_SPARK is -- Copy_Env -- -------------- - procedure Copy_Env - (From : Perm_Env; - To : in out Perm_Env) - is + procedure Copy_Env (From : Perm_Env; To : in out Perm_Env) is Comp_From : Perm_Tree_Access; - Key_From : Perm_Tree_Maps.Key_Option; - Son : Perm_Tree_Access; + Key_From : Perm_Tree_Maps.Key_Option; + Son : Perm_Tree_Access; begin Reset (To); @@ -296,7 +291,7 @@ package body Sem_SPARK is procedure Copy_Init_Map (From : Initialization_Map; - To : in out Initialization_Map) + To : in out Initialization_Map) is Comp_From : Boolean; Key_From : Boolean_Variables_Maps.Key_Option; @@ -315,25 +310,19 @@ package body Sem_SPARK is -- Copy_Tree -- --------------- - procedure Copy_Tree - (From : Perm_Tree_Access; - To : Perm_Tree_Access) - is + procedure Copy_Tree (From : Perm_Tree_Access; To : Perm_Tree_Access) is begin To.all := From.all; - case Kind (From) is when Entire_Object => null; when Reference => To.all.Tree.Get_All := new Perm_Tree_Wrapper; - Copy_Tree (Get_All (From), Get_All (To)); when Array_Component => To.all.Tree.Get_Elem := new Perm_Tree_Wrapper; - Copy_Tree (Get_Elem (From), Get_Elem (To)); when Record_Component => @@ -346,31 +335,26 @@ package body Sem_SPARK is -- We put a new hash table, so that it gets dealiased from the -- Component (From) hash table. To.all.Tree.Component := Hash_Table; - To.all.Tree.Other_Components := new Perm_Tree_Wrapper'(Other_Components (From).all); - Copy_Tree (Other_Components (From), Other_Components (To)); - Key_From := Perm_Tree_Maps.Get_First_Key (Component (From)); + while Key_From.Present loop Comp_From := Perm_Tree_Maps.Get (Component (From), Key_From.K); - pragma Assert (Comp_From /= null); Son := new Perm_Tree_Wrapper; - Copy_Tree (Comp_From, Son); - Perm_Tree_Maps.Set (To.all.Tree.Component, Key_From.K, Son); - Key_From := Perm_Tree_Maps.Get_Next_Key (Component (From)); end loop; end; end case; + end Copy_Tree; ------------------------------ @@ -402,9 +386,7 @@ package body Sem_SPARK is -- Free_Perm_Tree -- -------------------- - procedure Free_Perm_Tree - (PT : in out Perm_Tree_Access) - is + procedure Free_Perm_Tree (PT : in out Perm_Tree_Access) is procedure Free_Perm_Tree_Dealloc is new Ada.Unchecked_Deallocation (Perm_Tree_Wrapper, Perm_Tree_Access); @@ -430,6 +412,7 @@ package body Sem_SPARK is Free_Perm_Tree (PT.all.Tree.Other_Components); Comp := Perm_Tree_Maps.Get_First (Component (PT)); while Comp /= null loop + -- Free every Component subtree Free_Perm_Tree (Comp); @@ -444,10 +427,7 @@ package body Sem_SPARK is -- Get_All -- ------------- - function Get_All - (T : Perm_Tree_Access) - return Perm_Tree_Access - is + function Get_All (T : Perm_Tree_Access) return Perm_Tree_Access is begin return T.all.Tree.Get_All; end Get_All; @@ -456,10 +436,7 @@ package body Sem_SPARK is -- Get_Elem -- -------------- - function Get_Elem - (T : Perm_Tree_Access) - return Perm_Tree_Access - is + function Get_Elem (T : Perm_Tree_Access) return Perm_Tree_Access is begin return T.all.Tree.Get_Elem; end Get_Elem; @@ -468,10 +445,7 @@ package body Sem_SPARK is -- Is_Node_Deep -- ------------------ - function Is_Node_Deep - (T : Perm_Tree_Access) - return Boolean - is + function Is_Node_Deep (T : Perm_Tree_Access) return Boolean is begin return T.all.Tree.Is_Node_Deep; end Is_Node_Deep; @@ -480,10 +454,7 @@ package body Sem_SPARK is -- Kind -- ---------- - function Kind - (T : Perm_Tree_Access) - return Path_Kind - is + function Kind (T : Perm_Tree_Access) return Path_Kind is begin return T.all.Tree.Kind; end Kind; @@ -494,7 +465,7 @@ package body Sem_SPARK is function Other_Components (T : Perm_Tree_Access) - return Perm_Tree_Access + return Perm_Tree_Access is begin return T.all.Tree.Other_Components; @@ -504,10 +475,7 @@ package body Sem_SPARK is -- Permission -- ---------------- - function Permission - (T : Perm_Tree_Access) - return Perm_Kind - is + function Permission (T : Perm_Tree_Access) return Perm_Kind is begin return T.all.Tree.Permission; end Permission; @@ -516,13 +484,10 @@ package body Sem_SPARK is -- Perm_Mismatch -- ------------------- - procedure Perm_Mismatch - (Exp_Perm, Act_Perm : Perm_Kind; - N : Node_Id) - is + procedure Perm_Mismatch (Exp_Perm, Act_Perm : Perm_Kind; N : Node_Id) is begin - Error_Msg_N ("\expected at least `" - & Perm_Kind'Image (Exp_Perm) & "`, got `" + Error_Msg_N ("\expected state `" + & Perm_Kind'Image (Exp_Perm) & "` at least, got `" & Perm_Kind'Image (Act_Perm) & "`", N); end Perm_Mismatch; @@ -543,34 +508,29 @@ package body Sem_SPARK is -- Default mode. Checks that paths have Read_Perm permission. Move, - -- Regular moving semantics (not under 'Access). Checks that paths have - -- Read_Write permission. After moving a path, its permission is set to - -- Write_Only and the permission of its extensions is set to No_Access. + -- Regular moving semantics. Checks that paths have + -- Unrestricted permission. After moving a path, its permission is set + -- to Unrestricted and the permission of its extensions is set + -- to Unrestricted. Assign, -- Used for the target of an assignment, or an actual parameter with - -- mode OUT. Checks that paths have Write_Perm permission. After - -- assigning to a path, its permission is set to Read_Write. - - Super_Move, - -- Enhanced moving semantics (under 'Access). Checks that paths have - -- Read_Write permission (shallow types may have only Write permission). - -- After moving a path, its permission is set to No_Access, as well as - -- the permission of its extensions and the permission of its prefixes - -- up to the first Reference node. - - Borrow_Out, - -- Used for actual OUT parameters. Checks that paths have Write_Perm - -- permission. After checking a path, its permission is set to Read_Only - -- when of a by-copy type, to No_Access otherwise. After the call, its - -- permission is set to Read_Write. + -- mode OUT. Checks that paths have Unrestricted permission. After + -- assigning to a path, its permission is set to Unrestricted. + + Borrow, + -- Used for the source of an assignement when initializes a stand alone + -- object of anonymous type, constant, or IN parameter and also OUT + -- or IN OUT composite object. + -- In the borrowed state, the access object is completely "dead". Observe -- Used for actual IN parameters of a scalar type. Checks that paths -- have Read_Perm permission. After checking a path, its permission - -- is set to Read_Only. + -- is set to Observed. -- -- Also used for formal IN parameters + ); type Result_Kind is (Folded, Unfolded, Function_Call); @@ -593,11 +553,6 @@ package body Sem_SPARK is -- Local subprograms -- ----------------------- - function "<=" (P1, P2 : Perm_Kind) return Boolean; - function ">=" (P1, P2 : Perm_Kind) return Boolean; - function Glb (P1, P2 : Perm_Kind) return Perm_Kind; - function Lub (P1, P2 : Perm_Kind) return Perm_Kind; - -- Checking proceduress for safe pointer usage. These procedures traverse -- the AST, check nodes for correct permissions according to SPARK RM -- 6.4.2, and update permissions depending on the node kind. @@ -608,24 +563,15 @@ package body Sem_SPARK is -- We are not in End_Of_Callee mode, hence we will save the environment -- and start from a new one. We will add in the environment all formal -- parameters as well as global used during the subprogram, with the - -- appropriate permissions (write-only for out, read-only for observed, - -- read-write for others). - -- - -- After that we analyze the body of the function, and finaly, we check - -- that each borrowed parameter and global has read-write permission. We - -- then clean up the environment and put back the saved environment. + -- appropriate permissions (unrestricted for borrowed and moved, observed + -- for observed names). procedure Check_Declaration (Decl : Node_Id); procedure Check_Expression (Expr : Node_Id); - procedure Check_Globals (N : Node_Id; Check_Mode : Checking_Mode); - -- This procedure takes a global pragma and checks depending on mode: - -- Mode Read: every in global is readable - -- Mode Observe: same as Check_Param_Observes but on globals - -- Mode Borrow_Out: Check_Param_Outs for globals - -- Mode Move: Check_Param for globals with mode Read - -- Mode Assign: Check_Param for globals with mode Assign + procedure Check_Globals (N : Node_Id); + -- This procedure takes a global pragma and checks it procedure Check_List (L : List_Id); -- Calls Check_Node on each element of the list @@ -638,25 +584,15 @@ package body Sem_SPARK is procedure Check_Package_Body (Pack : Node_Id); - procedure Check_Param (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and calls the - -- analyze node if the parameter is borrowed with mode in out, with the - -- appropriate Checking_Mode (Move). - - procedure Check_Param_Observes (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and calls - -- the analyze node if the parameter is observed, with the appropriate - -- Checking_Mode. - - procedure Check_Param_Outs (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and calls the - -- analyze node if the parameter is of mode out, with the appropriate - -- Checking_Mode. + procedure Check_Param_In (Formal : Entity_Id; Actual : Node_Id); + -- This procedure takes a formal and an actual parameter and checks the + -- permission of every in-mode parameter. This includes Observing and + -- Borrowing. - procedure Check_Param_Read (Formal : Entity_Id; Actual : Node_Id); + procedure Check_Param_Out (Formal : Entity_Id; Actual : Node_Id); -- This procedure takes a formal and an actual parameter and checks the - -- readability of every in-mode parameter. This includes observed in, and - -- also borrowed in, that are then checked afterwards. + -- state of every out-mode and in out-mode parameter. This includes + -- Moving and Borrowing. procedure Check_Statement (Stmt : Node_Id); @@ -674,20 +610,6 @@ package body Sem_SPARK is -- appropriate subtree for that Node_Id. If the tree is folded, then -- it unrolls the tree up to the appropriate level. - function Has_Alias - (N : Node_Id) - return Boolean; - -- Function that returns whether the path given as parameter contains an - -- extension that is declared as aliased. - - function Has_Array_Component (N : Node_Id) return Boolean; - -- This function gets a Node_Id and looks recursively to find if the given - -- path has any array component. - - function Has_Function_Component (N : Node_Id) return Boolean; - -- This function gets a Node_Id and looks recursively to find if the given - -- path has any function component. - procedure Hp (P : Perm_Env); -- A procedure that outputs the hash table. This function is used only in -- the debugger to look into a hash table. @@ -698,28 +620,13 @@ package body Sem_SPARK is -- A procedure that is called when deep globals or aliased globals are used -- without any global aspect. - function Is_Borrowed_In (E : Entity_Id) return Boolean; - -- Function that tells if the given entity is a borrowed in a formal - -- parameter, that is, if it is an access-to-variable type. - function Is_Deep (E : Entity_Id) return Boolean; -- A function that can tell if a type is deep or not. Returns true if the -- type passed as argument is deep. - function Is_Shallow (E : Entity_Id) return Boolean; - -- A function that can tell if a type is shallow or not. Returns true if - -- the type passed as argument is shallow. - - function Loop_Of_Exit (N : Node_Id) return Entity_Id; - -- A function that takes an exit statement node and returns the entity of - -- the loop that this statement is exiting from. - - procedure Merge_Envs (Target : in out Perm_Env; Source : in out Perm_Env); - -- Merge Target and Source into Target, and then deallocate the Source - procedure Perm_Error - (N : Node_Id; - Perm : Perm_Kind; + (N : Node_Id; + Perm : Perm_Kind; Found_Perm : Perm_Kind); -- A procedure that is called when the permissions found contradict the -- rules established by the RM. This function is called with the node, its @@ -742,7 +649,7 @@ package body Sem_SPARK is procedure Return_Declarations (L : List_Id); -- Check correct permissions on every declared object at the end of a -- callee. Used at the end of the body of a callable entity. Checks that - -- paths of all borrowed formal parameters and global have Read_Write + -- paths of all borrowed formal parameters and global have Unrestricted -- permission. procedure Return_Globals (Subp : Entity_Id); @@ -750,65 +657,32 @@ package body Sem_SPARK is -- of the subprogram indeed have RW permission at the end of the subprogram -- execution. - procedure Return_Parameter_Or_Global - (Id : Entity_Id; - Mode : Formal_Kind; - Subp : Entity_Id; - Global_Var : Boolean); - -- Auxiliary procedure to Return_Parameters and Return_Globals - - procedure Return_Parameters (Subp : Entity_Id); - -- Takes a subprogram as input, and checks that all borrowed parameters of - -- the subprogram indeed have RW permission at the end of the subprogram - -- execution. + procedure Return_The_Global + (Id : Entity_Id; + Mode : Formal_Kind; + Subp : Entity_Id); + -- Auxiliary procedure to Return_Globals + -- There is no need to return parameters because they will be reassigned + -- their state once the subprogram returns. Local variables that have + -- borrowed, observed, or moved an actual parameter go out of the scope. procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind); -- This procedure takes an access to a permission tree and modifies the -- tree so that any strict extensions of the given tree become of the -- access specified by parameter P. - procedure Set_Perm_Extensions_Move (T : Perm_Tree_Access; E : Entity_Id); - -- Set permissions to - -- No for any extension with more .all - -- W for any deep extension with same number of .all - -- RW for any shallow extension with same number of .all - - function Set_Perm_Prefixes_Assign (N : Node_Id) return Perm_Tree_Access; - -- This function takes a name as an input and sets in the permission - -- tree the given permission to the given name. The general rule here is - -- that everybody updates the permission of the subtree it is returning. - -- The permission of the assigned path has been set to RW by the caller. - -- - -- Case where we have to normalize a tree after the correct permissions - -- have been assigned already. We look for the right subtree at the given - -- path, actualize its permissions, and then call the normalization on its - -- parent. - -- - -- Example: We assign x.y and x.z then during Set_Perm_Prefixes_Move will - -- change the permission of x to RW because all of its components have - -- permission have permission RW. - - function Set_Perm_Prefixes_Borrow_Out (N : Node_Id) return Perm_Tree_Access; + function Set_Perm_Prefixes_Borrow (N : Node_Id) return Perm_Tree_Access; -- This function modifies the permissions of a given node_id in the -- permission environment as well as in all the prefixes of the path, -- given that the path is borrowed with mode out. - function Set_Perm_Prefixes_Move - (N : Node_Id; Mode : Checking_Mode) + function Set_Perm_Prefixes + (N : Node_Id; + New_Perm : Perm_Kind) return Perm_Tree_Access; - pragma Precondition (Mode = Move or Mode = Super_Move); - -- Given a node and a mode (that can be either Move or Super_Move), this - -- function modifies the permissions of a given node_id in the permission - -- environment as well as all the prefixes of the path, given that the path - -- is moved with or without 'Access. The general rule here is everybody - -- updates the permission of the subtree they are returning. - -- - -- This case describes a move either under 'Access or without 'Access. - - function Set_Perm_Prefixes_Observe (N : Node_Id) return Perm_Tree_Access; - -- This function modifies the permissions of a given node_id in the - -- permission environment as well as all the prefixes of the path, - -- given that the path is observed. + -- This function sets the permissions of a given node_id in the + -- permission environment as well as in all the prefixes of the path + -- to the one given in parameter (P). procedure Setup_Globals (Subp : Entity_Id); -- Takes a subprogram as input, and sets up the environment by adding @@ -824,6 +698,15 @@ package body Sem_SPARK is -- Takes a subprogram as input, and sets up the environment by adding -- formal parameters with appropriate permissions. + function Has_Ownership_Aspect_True + (N : Node_Id; + Msg : String) + return Boolean; + -- Takes a node as an input, and finds out whether it has ownership aspect + -- True or False. This function is recursive whenever the node has a + -- composite type. Access-to-objects have ownership aspect False if they + -- have a general access type. + ---------------------- -- Global Variables -- ---------------------- @@ -861,31 +744,6 @@ package body Sem_SPARK is -- after declaration. Hence we can exclude from analysis variables that -- are just declared and never accessed, typically at package declaration. - ---------- - -- "<=" -- - ---------- - - function "<=" (P1, P2 : Perm_Kind) return Boolean - is - begin - return P2 >= P1; - end "<="; - - ---------- - -- ">=" -- - ---------- - - function ">=" (P1, P2 : Perm_Kind) return Boolean - is - begin - case P2 is - when No_Access => return True; - when Read_Only => return P1 in Read_Perm; - when Write_Only => return P1 in Write_Perm; - when Read_Write => return P1 = Read_Write; - end case; - end ">="; - -------------------------- -- Check_Call_Statement -- -------------------------- @@ -893,64 +751,40 @@ package body Sem_SPARK is procedure Check_Call_Statement (Call : Node_Id) is Saved_Env : Perm_Env; - procedure Iterate_Call is new - Iterate_Call_Parameters (Check_Param); - procedure Iterate_Call_Observes is new - Iterate_Call_Parameters (Check_Param_Observes); - procedure Iterate_Call_Outs is new - Iterate_Call_Parameters (Check_Param_Outs); - procedure Iterate_Call_Read is new - Iterate_Call_Parameters (Check_Param_Read); + procedure Iterate_Call_In is new + Iterate_Call_Parameters (Check_Param_In); + procedure Iterate_Call_Out is new + Iterate_Call_Parameters (Check_Param_Out); begin -- Save environment, so that the modifications done by analyzing the -- parameters are not kept at the end of the call. - Copy_Env (Current_Perm_Env, - Saved_Env); - - -- We first check the Read access on every in parameter - Current_Checking_Mode := Read; - Iterate_Call_Read (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), Read); - - -- We first observe, then borrow with mode out, and then with other - -- modes. This ensures that we do not have to check for by-copy types - -- specially, because we read them before borrowing them. - - Iterate_Call_Observes (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), - Observe); + Copy_Env (Current_Perm_Env, Saved_Env); - Iterate_Call_Outs (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), - Borrow_Out); + -- We first check the globals then parameters to handle the + -- No_Parameter_Aliasing Restriction. An out or in-out global is + -- considered as borrowing while a parameter with the same mode is + -- a move. This order disallow passing a part of a variable to a + -- subprogram if it is referenced as a global by the callable (when + -- writable). + -- For paremeters, we fisrt check in parameters and then the out ones. + -- This is to avoid Observing or Borrowing objects that are already + -- moved. This order is not mandatory but allows to catch runtime + -- errors like null pointer dereferencement at the analysis time. - Iterate_Call (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), Move); + Current_Checking_Mode := Read; + Check_Globals (Get_Pragma (Get_Called_Entity (Call), Pragma_Global)); + Iterate_Call_In (Call); + Iterate_Call_Out (Call); -- Restore environment, because after borrowing/observing actual -- parameters, they get their permission reverted to the ones before -- the call. Free_Env (Current_Perm_Env); - - Copy_Env (Saved_Env, - Current_Perm_Env); - + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (Saved_Env); - - -- We assign the out parameters (necessarily borrowed per RM) - Current_Checking_Mode := Assign; - Iterate_Call (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), - Assign); - end Check_Call_Statement; ------------------------- @@ -959,15 +793,12 @@ package body Sem_SPARK is procedure Check_Callable_Body (Body_N : Node_Id) is - Mode_Before : constant Checking_Mode := Current_Checking_Mode; - - Saved_Env : Perm_Env; + Mode_Before : constant Checking_Mode := Current_Checking_Mode; + Saved_Env : Perm_Env; Saved_Init_Map : Initialization_Map; - - New_Env : Perm_Env; - - Body_Id : constant Entity_Id := Defining_Entity (Body_N); - Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); + New_Env : Perm_Env; + Body_Id : constant Entity_Id := Defining_Entity (Body_N); + Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); begin -- Check if SPARK pragma is not set to Off @@ -989,9 +820,8 @@ package body Sem_SPARK is -- Save initialization map Copy_Init_Map (Current_Initialization_Map, Saved_Init_Map); - Current_Checking_Mode := Read; - Current_Perm_Env := New_Env; + Current_Perm_Env := New_Env; -- Add formals and globals to the environment with adequate permissions @@ -1010,23 +840,18 @@ package body Sem_SPARK is if Ekind_In (Spec_Id, E_Procedure, E_Entry) and then not No_Return (Spec_Id) then - Return_Parameters (Spec_Id); Return_Globals (Spec_Id); end if; -- Free the environments Free_Env (Current_Perm_Env); - - Copy_Env (Saved_Env, - Current_Perm_Env); - + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (Saved_Env); -- Restore initialization map Copy_Init_Map (Saved_Init_Map, Current_Initialization_Map); - Reset (Saved_Init_Map); -- The assignment of all out parameters will be done by caller @@ -1039,51 +864,248 @@ package body Sem_SPARK is ----------------------- procedure Check_Declaration (Decl : Node_Id) is + + Target_Ent : constant Entity_Id := Defining_Identifier (Decl); + Target_Typ : Node_Id renames Etype (Target_Ent); + Check : Boolean := True; begin case N_Declaration'(Nkind (Decl)) is when N_Full_Type_Declaration => + if not Has_Ownership_Aspect_True (Target_Ent, "type declaration") + then + Check := False; + end if; - -- Nothing to do here ??? NOT TRUE IF CONSTRAINT ON TYPE - - null; + -- ??? What about component declarations with defaults. when N_Object_Declaration => + if (Is_Access_Type (Target_Typ) + or else Is_Deep (Target_Typ)) + and then not Has_Ownership_Aspect_True + (Target_Ent, "Object declaration ") + then + Check := False; + end if; + + if Is_Anonymous_Access_Type (Target_Typ) + and then not Present (Expression (Decl)) + then + + -- ??? Check the case of default value (AI) + -- ??? How an anonymous access type can be with default exp? + + Error_Msg_NE ("? object declaration & has OAF (Anonymous " + & "access-to-object with no initialization)", + Decl, Target_Ent); + + -- If it it an initialization + + elsif Present (Expression (Decl)) and Check then + + -- Find out the operation to be done on the right-hand side + + -- Initializing object, access type + + if Is_Access_Type (Target_Typ) then + + -- Initializing object, constant access type + + if Is_Constant_Object (Target_Ent) then + + -- Initializing object, constant access to variable type + + if not Is_Access_Constant (Target_Typ) then + Current_Checking_Mode := Borrow; + + -- Initializing object, constant access to constant type + + -- Initializing object, + -- constant access to constant anonymous type. + + elsif Is_Anonymous_Access_Type (Target_Typ) then + + -- This is an object declaration so the target + -- of the assignement is a stand-alone object. + + Current_Checking_Mode := Observe; + + -- Initializing object, constant access to constant + -- named type. + + else + -- If named then it is a general access type + -- Hence, Has_Ownership_Aspec_True is False. + + raise Program_Error; + end if; + + -- Initializing object, variable access type + + else + -- Initializing object, variable access to variable type - -- First move the right-hand side + if not Is_Access_Constant (Target_Typ) then - Current_Checking_Mode := Move; - Check_Node (Expression (Decl)); + -- Initializing object, variable named access to + -- variable type. + + if not Is_Anonymous_Access_Type (Target_Typ) then + Current_Checking_Mode := Move; + + -- Initializing object, variable anonymous access to + -- variable type. + + else + -- This is an object declaration so the target + -- object of the assignement is a stand-alone + -- object. + + Current_Checking_Mode := Borrow; + end if; + + -- Initializing object, variable access to constant type + + else + -- Initializing object, + -- variable named access to constant type. + + if not Is_Anonymous_Access_Type (Target_Typ) then + Error_Msg_N ("assignment not allowed, Ownership " + & "Aspect False (Anonymous Access " + & "Object)", Decl); + Check := False; + + -- Initializing object, + -- variable anonymous access to constant type. + + else + -- This is an object declaration so the target + -- of the assignement is a stand-alone object. + + Current_Checking_Mode := Observe; + end if; + end if; + end if; + + -- Initializing object, composite (deep) type + + elsif Is_Deep (Target_Typ) then + + -- Initializing object, constant composite type + + if Is_Constant_Object (Target_Ent) then + Current_Checking_Mode := Observe; + + -- Initializing object, variable composite type + + else + + -- Initializing object, variable anonymous composite type + + if Nkind (Object_Definition (Decl)) = + N_Constrained_Array_Definition + + -- An N_Constrained_Array_Definition is an anonymous + -- array (to be checked). Record types are always + -- named and are considered in the else part. + + then + declare + Com_Ty : constant Node_Id := + Component_Type (Etype (Target_Typ)); + begin + + if Is_Access_Type (Com_Ty) then + + -- If components are of anonymous type + + if Is_Anonymous_Access_Type (Com_Ty) then + if Is_Access_Constant (Com_Ty) then + Current_Checking_Mode := Observe; + + else + Current_Checking_Mode := Borrow; + end if; + + else + Current_Checking_Mode := Move; + end if; + + elsif Is_Deep (Com_Ty) then + + -- This is certainly named so it is a move + + Current_Checking_Mode := Move; + end if; + end; + + else + Current_Checking_Mode := Move; + end if; + end if; + + elsif Nkind_In (Expression (Decl), + N_Attribute_Reference, + N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice) + then + if Is_Access_Type (Etype (Prefix (Expression (Decl)))) + or else Is_Deep (Etype (Prefix (Expression (Decl)))) + then + Current_Checking_Mode := Observe; + Check := True; + end if; + end if; + end if; + + if Check then + Check_Node (Expression (Decl)); + end if; + + -- If lhs is not a pointer, we still give it the appropriate + -- state which is useless but not harmful. declare - Deep : constant Boolean := - Is_Deep (Etype (Defining_Identifier (Decl))); Elem : Perm_Tree_Access; + Deep : constant Boolean := Is_Deep (Target_Typ); begin - Elem := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Deep, - Permission => Read_Write, - Children_Permission => Read_Write)); - - -- If unitialized declaration, then set to Write_Only. If a - -- pointer declaration, it has a null default initialization. - - if No (Expression (Decl)) - and then not Has_Full_Default_Initialization - (Etype (Defining_Identifier (Decl))) - and then not Is_Access_Type - (Etype (Defining_Identifier (Decl))) - - -- Objects of shallow types are considered as always - -- initialized, leaving the checking of initialization to - -- flow analysis. - - and then Deep - then - Elem.all.Tree.Permission := Write_Only; - Elem.all.Tree.Children_Permission := Write_Only; + -- Note that all declared variables are set to the unrestricted + -- state. + -- + -- If variables are not initialized: + -- unrestricted to every declared object. + -- Exp: + -- R : Rec + -- S : Rec := (...) + -- R := S + -- The assignement R := S is not allowed in the new rules + -- if R is not unrestricted. + -- + -- If variables are initialized: + -- If it is a move, then the target is unrestricted + -- If it is a borrow, then the target is unrestricted + -- If it is an observe, then the target should be observed + + if Current_Checking_Mode = Observe then + Elem := new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Deep, + Permission => Observed, + Children_Permission => Observed)); + else + Elem := new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Deep, + Permission => Unrestricted, + Children_Permission => Unrestricted)); end if; -- Create new tree for defining identifier @@ -1091,7 +1113,6 @@ package body Sem_SPARK is Set (Current_Perm_Env, Unique_Entity (Defining_Identifier (Decl)), Elem); - pragma Assert (Get_First (Current_Perm_Env) /= null); end; @@ -1099,19 +1120,17 @@ package body Sem_SPARK is Check_Node (Subtype_Indication (Decl)); when N_Iterator_Specification => - pragma Assert (Is_Shallow (Etype (Defining_Identifier (Decl)))); null; when N_Loop_Parameter_Specification => - pragma Assert (Is_Shallow (Etype (Defining_Identifier (Decl)))); null; -- Checking should not be called directly on these nodes - when N_Component_Declaration - | N_Function_Specification + when N_Function_Specification | N_Entry_Declaration | N_Procedure_Specification + | N_Component_Declaration => raise Program_Error; @@ -1141,29 +1160,33 @@ package body Sem_SPARK is Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin case N_Subexpr'(Nkind (Expr)) is - when N_Procedure_Call_Statement => + when N_Procedure_Call_Statement + | N_Function_Call + => Check_Call_Statement (Expr); when N_Identifier | N_Expanded_Name => -- Check if identifier is pointing to nothing (On/Off/...) + if not Present (Entity (Expr)) then return; end if; -- Do not analyze things that are not of object Kind + if Ekind (Entity (Expr)) not in Object_Kind then return; end if; -- Consider as ident + Process_Path (Expr); -- Switch to read mode and then check the readability of each operand when N_Binary_Op => - Current_Checking_Mode := Read; Check_Node (Left_Opnd (Expr)); Check_Node (Right_Opnd (Expr)); @@ -1175,7 +1198,6 @@ package body Sem_SPARK is | N_Op_Not | N_Op_Plus => - pragma Assert (Is_Shallow (Etype (Expr))); Current_Checking_Mode := Read; Check_Node (Right_Opnd (Expr)); @@ -1184,32 +1206,7 @@ package body Sem_SPARK is when N_Attribute_Reference => case Attribute_Name (Expr) is when Name_Access => - case Current_Checking_Mode is - when Read => - Check_Node (Prefix (Expr)); - - when Move => - Current_Checking_Mode := Super_Move; - Check_Node (Prefix (Expr)); - - -- Only assign names, not expressions - - when Assign => - raise Program_Error; - - -- Prefix in Super_Move should be a name, error here - - when Super_Move => - raise Program_Error; - - -- Could only borrow names of mode out, not n'Access - - when Borrow_Out => - raise Program_Error; - - when Observe => - Check_Node (Prefix (Expr)); - end case; + Error_Msg_N ("access attribute not allowed in SPARK", Expr); when Name_Last | Name_First @@ -1239,7 +1236,7 @@ package body Sem_SPARK is Check_Node (Prefix (Expr)); when Name_Pred - | Name_Succ + | Name_Succ => Check_List (Expressions (Expr)); Check_Node (Prefix (Expr)); @@ -1254,12 +1251,12 @@ package body Sem_SPARK is -- analysis. when Name_Address - | Name_Alignment - | Name_Component_Size - | Name_First_Bit - | Name_Last_Bit - | Name_Size - | Name_Position + | Name_Alignment + | Name_Component_Size + | Name_First_Bit + | Name_Last_Bit + | Name_Size + | Name_Position => null; @@ -1270,7 +1267,6 @@ package body Sem_SPARK is | Name_Val => null; - -- Other attributes that fall out of the scope of the analysis when others => @@ -1292,17 +1288,12 @@ package body Sem_SPARK is when N_And_Then | N_Or_Else => - pragma Assert (Is_Shallow (Etype (Expr))); Current_Checking_Mode := Read; Check_Node (Left_Opnd (Expr)); Check_Node (Right_Opnd (Expr)); -- Check the arguments of the call - when N_Function_Call => - Current_Checking_Mode := Read; - Check_List (Parameter_Associations (Expr)); - when N_Explicit_Dereference => Process_Path (Expr); @@ -1315,20 +1306,16 @@ package body Sem_SPARK is -- Accumulator for the different branches New_Env : Perm_Env; - - Elmt : Node_Id := First (Expressions (Expr)); + Elmt : Node_Id := First (Expressions (Expr)); begin Current_Checking_Mode := Read; - Check_Node (Elmt); - Current_Checking_Mode := Mode_Before; -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy, and new aliased. @@ -1341,15 +1328,10 @@ package body Sem_SPARK is -- Here the new_environment contains curr env after then block -- ELSE part - -- Restore environment before if - Copy_Env (Current_Perm_Env, - New_Env); - + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); - - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); -- Here new environment contains the environment after then and -- current the fresh copy of old one. @@ -1357,14 +1339,9 @@ package body Sem_SPARK is Next (Elmt); Check_Node (Elmt); - Merge_Envs (New_Env, - Current_Perm_Env); - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); - + Copy_Env (New_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); end; @@ -1380,6 +1357,7 @@ package body Sem_SPARK is when N_Quantified_Expression => declare Saved_Env : Perm_Env; + begin Copy_Env (Current_Perm_Env, Saved_Env); Current_Checking_Mode := Read; @@ -1391,7 +1369,6 @@ package body Sem_SPARK is Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (Saved_Env); end; - -- Analyze the list of associations in the aggregate when N_Aggregate => @@ -1408,19 +1385,16 @@ package body Sem_SPARK is -- Accumulator for the different branches New_Env : Perm_Env; - Elmt : Node_Id := First (Alternatives (Expr)); begin Current_Checking_Mode := Read; Check_Node (Expression (Expr)); - Current_Checking_Mode := Mode_Before; -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy, and new aliased. @@ -1429,43 +1403,29 @@ package body Sem_SPARK is Check_Node (Elmt); Next (Elmt); - - Copy_Env (Current_Perm_Env, - New_Env); - + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); -- Other alternatives while Present (Elmt) loop - -- Restore environment - Copy_Env (Saved_Env, - Current_Perm_Env); + -- Restore environment + Copy_Env (Saved_Env, Current_Perm_Env); Check_Node (Elmt); - - -- Merge Current_Perm_Env into New_Env - - Merge_Envs (New_Env, - Current_Perm_Env); - Next (Elmt); end loop; - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); end; - -- Analyze the list of associates in the aggregate as well as the -- ancestor part. when N_Extension_Aggregate => - Check_Node (Ancestor_Part (Expr)); Check_List (Expressions (Expr)); @@ -1507,7 +1467,6 @@ package body Sem_SPARK is | N_Raise_xxx_Error => null; - -- The following nodes are never generated in GNATprove mode when N_Expression_With_Actions @@ -1515,7 +1474,6 @@ package body Sem_SPARK is | N_Unchecked_Expression => raise Program_Error; - end case; end Check_Expression; @@ -1523,150 +1481,63 @@ package body Sem_SPARK is -- Check_Globals -- ------------------- - procedure Check_Globals (N : Node_Id; Check_Mode : Checking_Mode) is + procedure Check_Globals (N : Node_Id) is begin if Nkind (N) = N_Empty then return; end if; declare - pragma Assert - (List_Length (Pragma_Argument_Associations (N)) = 1); - - PAA : constant Node_Id := - First (Pragma_Argument_Associations (N)); + pragma Assert (List_Length (Pragma_Argument_Associations (N)) = 1); + PAA : constant Node_Id := First (Pragma_Argument_Associations (N)); pragma Assert (Nkind (PAA) = N_Pragma_Argument_Association); - Row : Node_Id; The_Mode : Name_Id; RHS : Node_Id; - procedure Process (Mode : Name_Id; - The_Global : Entity_Id); - - procedure Process (Mode : Name_Id; - The_Global : Node_Id) - is - Ident_Elt : constant Entity_Id := + procedure Process (Mode : Name_Id; The_Global : Entity_Id); + procedure Process (Mode : Name_Id; The_Global : Node_Id) is + Ident_Elt : constant Entity_Id := Unique_Entity (Entity (The_Global)); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin if Ekind (Ident_Elt) = E_Abstract_State then return; end if; + case Mode is + when Name_Input + | Name_Proof_In + => + Current_Checking_Mode := Observe; + Check_Node (The_Global); - case Check_Mode is - when Read => - case Mode is - when Name_Input - | Name_Proof_In - => - Check_Node (The_Global); + when Name_Output + | Name_In_Out + => + -- ??? Borrow not Move? + Current_Checking_Mode := Borrow; + Check_Node (The_Global); - when Name_Output - | Name_In_Out - => - null; + when others => + raise Program_Error; + end case; + Current_Checking_Mode := Mode_Before; + end Process; - when others => - raise Program_Error; + begin + if Nkind (Expression (PAA)) = N_Null then - end case; - - when Observe => - case Mode is - when Name_Input - | Name_Proof_In - => - if not Is_Borrowed_In (Ident_Elt) then - -- Observed in - - Current_Checking_Mode := Observe; - Check_Node (The_Global); - end if; - - when others => - null; - - end case; - - when Borrow_Out => - - case Mode is - when Name_Output => - -- Borrowed out - Current_Checking_Mode := Borrow_Out; - Check_Node (The_Global); - - when others => - null; - - end case; - - when Move => - case Mode is - when Name_Input - | Name_Proof_In - => - if Is_Borrowed_In (Ident_Elt) then - -- Borrowed in - - Current_Checking_Mode := Move; - else - -- Observed - - return; - end if; - - when Name_Output => - return; - - when Name_In_Out => - -- Borrowed in out - - Current_Checking_Mode := Move; - - when others => - raise Program_Error; - end case; - - Check_Node (The_Global); - when Assign => - case Mode is - when Name_Input - | Name_Proof_In - => - null; - - when Name_Output - | Name_In_Out - => - -- Borrowed out or in out - - Process_Path (The_Global); - - when others => - raise Program_Error; - end case; - - when others => - raise Program_Error; - end case; - - Current_Checking_Mode := Mode_Before; - end Process; - - begin - if Nkind (Expression (PAA)) = N_Null then -- global => null -- No globals, nothing to do + return; elsif Nkind_In (Expression (PAA), N_Identifier, N_Expanded_Name) then + -- global => foo -- A single input + Process (Name_Input, Expression (PAA)); elsif Nkind (Expression (PAA)) = N_Aggregate @@ -1674,6 +1545,7 @@ package body Sem_SPARK is then -- global => (foo, bar) -- Inputs + RHS := First (Expressions (Expression (PAA))); while Present (RHS) loop case Nkind (RHS) is @@ -1687,7 +1559,6 @@ package body Sem_SPARK is when others => raise Program_Error; - end case; RHS := Next (RHS); end loop; @@ -1707,8 +1578,8 @@ package body Sem_SPARK is while Present (Row) loop pragma Assert (List_Length (Choices (Row)) = 1); The_Mode := Chars (First (Choices (Row))); - RHS := Expression (Row); + case Nkind (RHS) is when N_Aggregate => RHS := First (Expressions (RHS)); @@ -1719,7 +1590,6 @@ package body Sem_SPARK is when others => Process (The_Mode, RHS); - end case; RHS := Next (RHS); end loop; @@ -1737,9 +1607,7 @@ package body Sem_SPARK is when others => raise Program_Error; - end case; - Row := Next (Row); end loop; end; @@ -1770,339 +1638,6 @@ package body Sem_SPARK is procedure Check_Loop_Statement (Loop_N : Node_Id) is - -- Local Subprograms - - procedure Check_Is_Less_Restrictive_Env - (Exiting_Env : Perm_Env; - Entry_Env : Perm_Env); - -- This procedure checks that the Exiting_Env environment is less - -- restrictive than the Entry_Env environment. - - procedure Check_Is_Less_Restrictive_Tree - (New_Tree : Perm_Tree_Access; - Orig_Tree : Perm_Tree_Access; - E : Entity_Id); - -- Auxiliary procedure to check that the tree New_Tree is less - -- restrictive than the tree Orig_Tree for the entity E. - - procedure Perm_Error_Loop_Exit - (E : Entity_Id; - Loop_Id : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind); - -- A procedure that is called when the permissions found contradict - -- the rules established by the RM at the exit of loops. This function - -- is called with the entity, the node of the enclosing loop, the - -- permission that was expected and the permission found, and issues - -- an appropriate error message. - - ----------------------------------- - -- Check_Is_Less_Restrictive_Env -- - ----------------------------------- - - procedure Check_Is_Less_Restrictive_Env - (Exiting_Env : Perm_Env; - Entry_Env : Perm_Env) - is - Comp_Entry : Perm_Tree_Maps.Key_Option; - Iter_Entry, Iter_Exit : Perm_Tree_Access; - - begin - Comp_Entry := Get_First_Key (Entry_Env); - while Comp_Entry.Present loop - Iter_Entry := Get (Entry_Env, Comp_Entry.K); - pragma Assert (Iter_Entry /= null); - Iter_Exit := Get (Exiting_Env, Comp_Entry.K); - pragma Assert (Iter_Exit /= null); - Check_Is_Less_Restrictive_Tree - (New_Tree => Iter_Exit, - Orig_Tree => Iter_Entry, - E => Comp_Entry.K); - Comp_Entry := Get_Next_Key (Entry_Env); - end loop; - end Check_Is_Less_Restrictive_Env; - - ------------------------------------ - -- Check_Is_Less_Restrictive_Tree -- - ------------------------------------ - - procedure Check_Is_Less_Restrictive_Tree - (New_Tree : Perm_Tree_Access; - Orig_Tree : Perm_Tree_Access; - E : Entity_Id) - is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Is_Less_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id); - -- Auxiliary procedure to check that the tree N is less restrictive - -- than the given permission P. - - procedure Check_Is_More_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id); - -- Auxiliary procedure to check that the tree N is more restrictive - -- than the given permission P. - - ----------------------------------------- - -- Check_Is_Less_Restrictive_Tree_Than -- - ----------------------------------------- - - procedure Check_Is_Less_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id) - is - begin - if not (Permission (Tree) >= Perm) then - Perm_Error_Loop_Exit - (E, Loop_N, Permission (Tree), Perm); - end if; - - case Kind (Tree) is - when Entire_Object => - if not (Children_Permission (Tree) >= Perm) then - Perm_Error_Loop_Exit - (E, Loop_N, Children_Permission (Tree), Perm); - - end if; - - when Reference => - Check_Is_Less_Restrictive_Tree_Than - (Get_All (Tree), Perm, E); - - when Array_Component => - Check_Is_Less_Restrictive_Tree_Than - (Get_Elem (Tree), Perm, E); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First (Component (Tree)); - while Comp /= null loop - Check_Is_Less_Restrictive_Tree_Than (Comp, Perm, E); - Comp := - Perm_Tree_Maps.Get_Next (Component (Tree)); - end loop; - - Check_Is_Less_Restrictive_Tree_Than - (Other_Components (Tree), Perm, E); - end; - end case; - end Check_Is_Less_Restrictive_Tree_Than; - - ----------------------------------------- - -- Check_Is_More_Restrictive_Tree_Than -- - ----------------------------------------- - - procedure Check_Is_More_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id) - is - begin - if not (Perm >= Permission (Tree)) then - Perm_Error_Loop_Exit - (E, Loop_N, Permission (Tree), Perm); - end if; - - case Kind (Tree) is - when Entire_Object => - if not (Perm >= Children_Permission (Tree)) then - Perm_Error_Loop_Exit - (E, Loop_N, Children_Permission (Tree), Perm); - end if; - - when Reference => - Check_Is_More_Restrictive_Tree_Than - (Get_All (Tree), Perm, E); - - when Array_Component => - Check_Is_More_Restrictive_Tree_Than - (Get_Elem (Tree), Perm, E); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First (Component (Tree)); - while Comp /= null loop - Check_Is_More_Restrictive_Tree_Than (Comp, Perm, E); - Comp := - Perm_Tree_Maps.Get_Next (Component (Tree)); - end loop; - - Check_Is_More_Restrictive_Tree_Than - (Other_Components (Tree), Perm, E); - end; - end case; - end Check_Is_More_Restrictive_Tree_Than; - - -- Start of processing for Check_Is_Less_Restrictive_Tree - - begin - if not (Permission (New_Tree) <= Permission (Orig_Tree)) then - Perm_Error_Loop_Exit - (E => E, - Loop_Id => Loop_N, - Perm => Permission (New_Tree), - Found_Perm => Permission (Orig_Tree)); - end if; - - case Kind (New_Tree) is - - -- Potentially folded tree. We check the other tree Orig_Tree to - -- check whether it is folded or not. If folded we just compare - -- their Permission and Children_Permission, if not, then we - -- look at the Children_Permission of the folded tree against - -- the unfolded tree Orig_Tree. - - when Entire_Object => - case Kind (Orig_Tree) is - when Entire_Object => - if not (Children_Permission (New_Tree) <= - Children_Permission (Orig_Tree)) - then - Perm_Error_Loop_Exit - (E, Loop_N, - Children_Permission (New_Tree), - Children_Permission (Orig_Tree)); - end if; - - when Reference => - Check_Is_More_Restrictive_Tree_Than - (Get_All (Orig_Tree), Children_Permission (New_Tree), E); - - when Array_Component => - Check_Is_More_Restrictive_Tree_Than - (Get_Elem (Orig_Tree), Children_Permission (New_Tree), E); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First - (Component (Orig_Tree)); - while Comp /= null loop - Check_Is_More_Restrictive_Tree_Than - (Comp, Children_Permission (New_Tree), E); - Comp := Perm_Tree_Maps.Get_Next - (Component (Orig_Tree)); - end loop; - - Check_Is_More_Restrictive_Tree_Than - (Other_Components (Orig_Tree), - Children_Permission (New_Tree), E); - end; - end case; - - when Reference => - case Kind (Orig_Tree) is - when Entire_Object => - Check_Is_Less_Restrictive_Tree_Than - (Get_All (New_Tree), Children_Permission (Orig_Tree), E); - - when Reference => - Check_Is_Less_Restrictive_Tree - (Get_All (New_Tree), Get_All (Orig_Tree), E); - - when others => - raise Program_Error; - end case; - - when Array_Component => - case Kind (Orig_Tree) is - when Entire_Object => - Check_Is_Less_Restrictive_Tree_Than - (Get_Elem (New_Tree), Children_Permission (Orig_Tree), E); - - when Array_Component => - Check_Is_Less_Restrictive_Tree - (Get_Elem (New_Tree), Get_Elem (Orig_Tree), E); - - when others => - raise Program_Error; - end case; - - when Record_Component => - declare - CompN : Perm_Tree_Access; - begin - CompN := - Perm_Tree_Maps.Get_First (Component (New_Tree)); - case Kind (Orig_Tree) is - when Entire_Object => - while CompN /= null loop - Check_Is_Less_Restrictive_Tree_Than - (CompN, Children_Permission (Orig_Tree), E); - - CompN := - Perm_Tree_Maps.Get_Next (Component (New_Tree)); - end loop; - - Check_Is_Less_Restrictive_Tree_Than - (Other_Components (New_Tree), - Children_Permission (Orig_Tree), - E); - - when Record_Component => - declare - - KeyO : Perm_Tree_Maps.Key_Option; - CompO : Perm_Tree_Access; - begin - KeyO := Perm_Tree_Maps.Get_First_Key - (Component (Orig_Tree)); - while KeyO.Present loop - pragma Assert (CompO /= null); - - Check_Is_Less_Restrictive_Tree (CompN, CompO, E); - - KeyO := Perm_Tree_Maps.Get_Next_Key - (Component (Orig_Tree)); - CompN := Perm_Tree_Maps.Get - (Component (New_Tree), KeyO.K); - CompO := Perm_Tree_Maps.Get - (Component (Orig_Tree), KeyO.K); - end loop; - - Check_Is_Less_Restrictive_Tree - (Other_Components (New_Tree), - Other_Components (Orig_Tree), - E); - end; - - when others => - raise Program_Error; - end case; - end; - end case; - end Check_Is_Less_Restrictive_Tree; - - -------------------------- - -- Perm_Error_Loop_Exit -- - -------------------------- - - procedure Perm_Error_Loop_Exit - (E : Entity_Id; - Loop_Id : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind) - is - begin - Error_Msg_Node_2 := Loop_Id; - Error_Msg_N ("insufficient permission for & when exiting loop &", E); - Perm_Mismatch (Exp_Perm => Perm, - Act_Perm => Found_Perm, - N => Loop_Id); - end Perm_Error_Loop_Exit; - -- Local variables Loop_Name : constant Entity_Id := Entity (Identifier (Loop_N)); @@ -2126,6 +1661,7 @@ package body Sem_SPARK is if Present (Iteration_Scheme (Loop_N)) then declare Exit_Env : constant Perm_Env_Access := new Perm_Env; + begin Copy_Env (From => Current_Perm_Env, To => Exit_Env.all); Set (Current_Loops_Accumulators, Loop_Name, Exit_Env); @@ -2137,12 +1673,6 @@ package body Sem_SPARK is Check_Node (Iteration_Scheme (Loop_N)); Check_List (Statements (Loop_N)); - -- Check that environment gets less restrictive at end of loop - - Check_Is_Less_Restrictive_Env - (Exiting_Env => Current_Perm_Env, - Entry_Env => Loop_Env.all); - -- Set environment to the one for exiting the loop declare @@ -2208,6 +1738,7 @@ package body Sem_SPARK is when N_Package_Declaration => declare Spec : constant Node_Id := Specification (N); + begin Current_Checking_Mode := Read; Check_List (Visible_Declarations (Spec)); @@ -2274,7 +1805,6 @@ package body Sem_SPARK is | N_Delay_Alternative | N_Derived_Type_Definition | N_Designator - | N_Discriminant_Association | N_Discriminant_Specification | N_Elsif_Part | N_Entry_Body_Formal_Part @@ -2366,9 +1896,12 @@ package body Sem_SPARK is | N_Use_Type_Clause | N_Validate_Unchecked_Conversion | N_Variable_Reference_Marker + | N_Discriminant_Association + + -- ??? check whether we should do sth special for + -- N_Discriminant_Association, or maybe raise a program error. => null; - -- The following nodes are rewritten by semantic analysis when N_Single_Protected_Declaration @@ -2408,15 +1941,12 @@ package body Sem_SPARK is -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); - + Copy_Env (Current_Perm_Env, Saved_Env); Check_List (Private_Declarations (CorSp)); -- Set mode to Read, and then analyze declarations and statements Current_Checking_Mode := Read; - Check_List (Declarations (Pack)); Check_Node (Handled_Statement_Sequence (Pack)); @@ -2430,137 +1960,129 @@ package body Sem_SPARK is -- declaration) from environment. Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); end Check_Package_Body; - ----------------- - -- Check_Param -- - ----------------- + -------------------- + -- Check_Param_In -- + -------------------- - procedure Check_Param (Formal : Entity_Id; Actual : Node_Id) is + procedure Check_Param_In (Formal : Entity_Id; Actual : Node_Id) is Mode : constant Entity_Kind := Ekind (Formal); Mode_Before : constant Checking_Mode := Current_Checking_Mode; - begin - case Current_Checking_Mode is - when Read => - case Formal_Kind'(Mode) is - when E_In_Parameter => - if Is_Borrowed_In (Formal) then - -- Borrowed in - - Current_Checking_Mode := Move; - else - -- Observed + case Formal_Kind'(Mode) is - return; - end if; + -- Formal IN parameter - when E_Out_Parameter => - return; + when E_In_Parameter => - when E_In_Out_Parameter => - -- Borrowed in out + -- Formal IN parameter, access type - Current_Checking_Mode := Move; + if Is_Access_Type (Etype (Formal)) then - end case; + -- Formal IN parameter, access to variable type - Check_Node (Actual); + if not Is_Access_Constant (Etype (Formal)) then - when Assign => - case Formal_Kind'(Mode) is - when E_In_Parameter => - null; + -- Formal IN parameter, named/anonymous access to variable + -- type. - when E_Out_Parameter - | E_In_Out_Parameter - => - -- Borrowed out or in out + Current_Checking_Mode := Borrow; + Check_Node (Actual); - Process_Path (Actual); + -- Formal IN parameter, access to constant type + -- Formal IN parameter, access to named constant type - end case; + elsif not Is_Anonymous_Access_Type (Etype (Formal)) then + Error_Msg_N ("assignment not allowed, Ownership Aspect" + & " False (Named general access type)", + Formal); - when others => - raise Program_Error; + -- Formal IN parameter, access to anonymous constant type - end case; - Current_Checking_Mode := Mode_Before; - end Check_Param; + else + Current_Checking_Mode := Observe; + Check_Node (Actual); + end if; - -------------------------- - -- Check_Param_Observes -- - -------------------------- + -- Formal IN parameter, composite type - procedure Check_Param_Observes (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; + elsif Is_Deep (Etype (Formal)) then - begin - case Mode is - when E_In_Parameter => - if not Is_Borrowed_In (Formal) then - -- Observed in + -- Composite formal types should be named + -- Formal IN parameter, composite named type Current_Checking_Mode := Observe; Check_Node (Actual); end if; - when others => + when E_Out_Parameter + | E_In_Out_Parameter + => null; - end case; Current_Checking_Mode := Mode_Before; - end Check_Param_Observes; + end Check_Param_In; ---------------------- - -- Check_Param_Outs -- + -- Check_Param_Out -- ---------------------- - procedure Check_Param_Outs (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); + procedure Check_Param_Out (Formal : Entity_Id; Actual : Node_Id) is + Mode : constant Entity_Kind := Ekind (Formal); Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin + case Formal_Kind'(Mode) is - case Mode is - when E_Out_Parameter => - -- Borrowed out - Current_Checking_Mode := Borrow_Out; - Check_Node (Actual); + -- Formal OUT/IN OUT parameter - when others => - null; + when E_Out_Parameter + | E_In_Out_Parameter + => - end case; + -- Formal OUT/IN OUT parameter, access type - Current_Checking_Mode := Mode_Before; - end Check_Param_Outs; + if Is_Access_Type (Etype (Formal)) then - ---------------------- - -- Check_Param_Read -- - ---------------------- + -- Formal OUT/IN OUT parameter, access to variable type - procedure Check_Param_Read (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); + if not Is_Access_Constant (Etype (Formal)) then - begin - pragma Assert (Current_Checking_Mode = Read); + -- Cannot have anonymous out access parameter + -- Formal out/in out parameter, access to named variable + -- type. - case Formal_Kind'(Mode) is - when E_In_Parameter => - Check_Node (Actual); + Current_Checking_Mode := Move; + Check_Node (Actual); - when E_Out_Parameter - | E_In_Out_Parameter - => - null; + -- Formal out/in out parameter, access to constant type + + else + Error_Msg_N ("assignment not allowed, Ownership Aspect False" + & " (Named general access type)", Formal); + + end if; + + -- Formal out/in out parameter, composite type + + elsif Is_Deep (Etype (Formal)) then + + -- Composite formal types should be named + -- Formal out/in out Parameter, Composite Named type. + Current_Checking_Mode := Borrow; + Check_Node (Actual); + end if; + + when E_In_Parameter => + null; end case; - end Check_Param_Read; + + Current_Checking_Mode := Mode_Before; + end Check_Param_Out; ------------------------- -- Check_Safe_Pointers -- @@ -2605,13 +2127,13 @@ package body Sem_SPARK is -- Local variables Prag : Node_Id; + -- SPARK_Mode pragma in application -- Start of processing for Check_Safe_Pointers begin Initialize; - case Nkind (N) is when N_Compilation_Unit => Check_Safe_Pointers (Unit (N)); @@ -2647,33 +2169,233 @@ package body Sem_SPARK is procedure Check_Statement (Stmt : Node_Id) is Mode_Before : constant Checking_Mode := Current_Checking_Mode; - begin - case N_Statement_Other_Than_Procedure_Call'(Nkind (Stmt)) is - when N_Entry_Call_Statement => - Check_Call_Statement (Stmt); - - -- Move right-hand side first, and then assign left-hand side + State_N : Perm_Kind; + Check : Boolean := True; + St_Name : Node_Id; + Ty_St_Name : Node_Id; - when N_Assignment_Statement => - if Is_Deep (Etype (Expression (Stmt))) then - Current_Checking_Mode := Move; - else - Current_Checking_Mode := Read; - end if; + function Get_Root (Comp_Stmt : Node_Id) return Node_Id; + -- Return the root of the name given as input - Check_Node (Expression (Stmt)); - Current_Checking_Mode := Assign; - Check_Node (Name (Stmt)); + function Get_Root (Comp_Stmt : Node_Id) return Node_Id is + begin + case Nkind (Comp_Stmt) is + when N_Identifier + | N_Expanded_Name + => return Comp_Stmt; - when N_Block_Statement => + when N_Type_Conversion + | N_Unchecked_Type_Conversion + | N_Qualified_Expression + => + return Get_Root (Expression (Comp_Stmt)); + + when N_Parameter_Specification => + return Get_Root (Defining_Identifier (Comp_Stmt)); + + when N_Selected_Component + | N_Indexed_Component + | N_Slice + | N_Explicit_Dereference + => + return Get_Root (Prefix (Comp_Stmt)); + + when others => + raise Program_Error; + end case; + end Get_Root; + + begin + case N_Statement_Other_Than_Procedure_Call'(Nkind (Stmt)) is + when N_Entry_Call_Statement => + Check_Call_Statement (Stmt); + + -- Move right-hand side first, and then assign left-hand side + + when N_Assignment_Statement => + + St_Name := Name (Stmt); + Ty_St_Name := Etype (Name (Stmt)); + + -- Check that is not a *general* access type + + if Has_Ownership_Aspect_True (St_Name, "assigning to") then + + -- Assigning to access type + + if Is_Access_Type (Ty_St_Name) then + + -- Assigning to access to variable type + + if not Is_Access_Constant (Ty_St_Name) then + + -- Assigning to named access to variable type + + if not Is_Anonymous_Access_Type (Ty_St_Name) then + Current_Checking_Mode := Move; + + -- Assigning to anonymous access to variable type + + else + -- Target /= source root + + if Nkind_In (Expression (Stmt), N_Allocator, N_Null) + or else St_Name /= Get_Root (Expression (Stmt)) + then + Error_Msg_N ("assignment not allowed, anonymous " + & "access Object with Different Root", + Stmt); + Check := False; + + -- Target = source root + + else + -- Here we do nothing on the source nor on the + -- target. However, we check the the legality rule: + -- "The source shall be an owning access object + -- denoted by a name that is not in the observed + -- state". + + State_N := Get_Perm (Expression (Stmt)); + if State_N = Observed then + Error_Msg_N ("assignment not allowed, Anonymous " + & "access object with the same root" + & " but source Observed", Stmt); + Check := False; + end if; + end if; + end if; + + -- else access-to-constant + + -- Assigning to anonymous access-to-constant type + + elsif Is_Anonymous_Access_Type (Ty_St_Name) then + + -- ??? Check the follwing condition. We may have to + -- add that the root is in the observed state too. + + State_N := Get_Perm (Expression (Stmt)); + if State_N /= Observed then + Error_Msg_N ("assignment not allowed, anonymous " + & "access-to-constant object not in " + & "the observed state)", Stmt); + Check := False; + + else + Error_Msg_N ("?here check accessibility level cited in" + & " the second legality rule of assign", + Stmt); + Check := False; + end if; + + -- Assigning to named access-to-constant type: + -- This case should have been detected when checking + -- Has_Onwership_Aspect_True (Name (Stmt), "msg"). + + else + raise Program_Error; + end if; + + -- Assigning to composite (deep) type. + + elsif Is_Deep (Ty_St_Name) then + if Ekind (Ty_St_Name) = E_Record_Type then + declare + Elmt : Entity_Id := + First_Component_Or_Discriminant (Ty_St_Name); + + begin + while Present (Elmt) loop + if Is_Anonymous_Access_Type (Etype (Elmt)) or + Ekind (Elmt) = E_General_Access_Type + then + Error_Msg_N ("assignment not allowed, Ownership " + & "Aspect False (Components have " + & "Ownership Aspect False)", Stmt); + Check := False; + exit; + end if; + + Next_Component_Or_Discriminant (Elmt); + end loop; + end; + + -- Record types are always named so this is a move + + if Check then + Current_Checking_Mode := Move; + end if; + end if; + + -- Now handle legality rules of using a borrowed, observed, + -- or moved name as a prefix in an assignment. + + else + if Nkind_In (St_Name, + N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice) + then + + if Is_Access_Type (Etype (Prefix (St_Name))) or + Is_Deep (Etype (Prefix (St_Name))) + then + + -- We set the Check variable to True so that we can + -- Check_Node of the expression and the name first + -- under the assumption of Current_Checking_Mode = + -- Read => nothing to be done for the RHS if the + -- following check on the expression fails, and + -- Current_Checking_Mode := Assign => the name should + -- not be borrowed or observed so that we can use it + -- as a prefix in the target of an assignement. + -- + -- Note that we do not need to check the OA here + -- because we are allowed to read and write "through" + -- an object of OAF (example: traversing a DS). + + Check := True; + end if; + end if; + + if Nkind_In (Expression (Stmt), + N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice) + then + + if Is_Access_Type (Etype (Prefix (Expression (Stmt)))) + or else Is_Deep (Etype (Prefix (Expression (Stmt)))) + then + Current_Checking_Mode := Observe; + Check := True; + end if; + end if; + end if; + + if Check then + Check_Node (Expression (Stmt)); + Current_Checking_Mode := Assign; + Check_Node (St_Name); + end if; + end if; + + when N_Block_Statement => declare Saved_Env : Perm_Env; - begin -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Analyze declarations and Handled_Statement_Sequences @@ -2684,8 +2406,7 @@ package body Sem_SPARK is -- Restore environment Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); end; when N_Case_Statement => @@ -2695,7 +2416,6 @@ package body Sem_SPARK is -- Accumulator for the different branches New_Env : Perm_Env; - Elmt : Node_Id := First (Alternatives (Stmt)); begin @@ -2705,8 +2425,7 @@ package body Sem_SPARK is -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy, and new aliased. @@ -2715,33 +2434,21 @@ package body Sem_SPARK is Check_Node (Elmt); Next (Elmt); - - Copy_Env (Current_Perm_Env, - New_Env); + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); -- Other alternatives while Present (Elmt) loop - -- Restore environment - Copy_Env (Saved_Env, - Current_Perm_Env); + -- Restore environment + Copy_Env (Saved_Env, Current_Perm_Env); Check_Node (Elmt); - - -- Merge Current_Perm_Env into New_Env - - Merge_Envs (New_Env, - Current_Perm_Env); - Next (Elmt); end loop; - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); - + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); end; @@ -2755,7 +2462,7 @@ package body Sem_SPARK is when N_Loop_Statement => Check_Loop_Statement (Stmt); - -- If deep type expression, then move, else read + -- If deep type expression, then move, else read when N_Simple_Return_Statement => case Nkind (Expression (Stmt)) is @@ -2767,65 +2474,42 @@ package body Sem_SPARK is Subp : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (Stmt)); begin - Return_Parameters (Subp); Return_Globals (Subp); end; when others => if Is_Deep (Etype (Expression (Stmt))) then Current_Checking_Mode := Move; - elsif Is_Shallow (Etype (Expression (Stmt))) then - Current_Checking_Mode := Read; else - raise Program_Error; + Check := False; end if; - Check_Node (Expression (Stmt)); + if Check then + Check_Node (Expression (Stmt)); + end if; end case; when N_Extended_Return_Statement => Check_List (Return_Object_Declarations (Stmt)); Check_Node (Handled_Statement_Sequence (Stmt)); - Return_Declarations (Return_Object_Declarations (Stmt)); - declare -- ??? This does not take into account the fact that a simple -- return inside an extended return statement applies to the -- extended return statement. Subp : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (Stmt)); + begin - Return_Parameters (Subp); Return_Globals (Subp); end; - -- Merge the current_Perm_Env with the accumulator for the given loop + -- Nothing to do when exiting a loop. No merge needed when N_Exit_Statement => - declare - Loop_Name : constant Entity_Id := Loop_Of_Exit (Stmt); - - Saved_Accumulator : constant Perm_Env_Access := - Get (Current_Loops_Accumulators, Loop_Name); - - Environment_Copy : constant Perm_Env_Access := - new Perm_Env; - begin - - Copy_Env (Current_Perm_Env, - Environment_Copy.all); - - if Saved_Accumulator = null then - Set (Current_Loops_Accumulators, - Loop_Name, Environment_Copy); - else - Merge_Envs (Saved_Accumulator.all, - Environment_Copy.all); - end if; - end; + null; - -- Copy environment, run on each branch, and then merge + -- Copy environment, run on each branch when N_If_Statement => declare @@ -2836,13 +2520,11 @@ package body Sem_SPARK is New_Env : Perm_Env; begin - Check_Node (Condition (Stmt)); -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy. @@ -2850,34 +2532,25 @@ package body Sem_SPARK is -- THEN PART Check_List (Then_Statements (Stmt)); - - Copy_Env (Current_Perm_Env, - New_Env); - + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); -- Here the new_environment contains curr env after then block -- ELSIF part + declare Elmt : Node_Id; begin Elmt := First (Elsif_Parts (Stmt)); while Present (Elmt) loop - -- Transfer into accumulator, and restore from save - Copy_Env (Saved_Env, - Current_Perm_Env); + -- Transfer into accumulator, and restore from save + Copy_Env (Saved_Env, Current_Perm_Env); Check_Node (Condition (Elmt)); Check_List (Then_Statements (Stmt)); - - -- Merge Current_Perm_Env into New_Env - - Merge_Envs (New_Env, - Current_Perm_Env); - Next (Elmt); end loop; end; @@ -2886,21 +2559,16 @@ package body Sem_SPARK is -- Restore environment before if - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); -- Here new environment contains the environment after then and -- current the fresh copy of old one. Check_List (Else_Statements (Stmt)); - Merge_Envs (New_Env, - Current_Perm_Env); - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); @@ -2956,8 +2624,7 @@ package body Sem_SPARK is -- which means that the association permission is RW. when Function_Call => - return Read_Write; - + return Unrestricted; end case; end Get_Perm; @@ -2980,7 +2647,6 @@ package body Sem_SPARK is => declare P : constant Entity_Id := Entity (N); - C : constant Perm_Tree_Access := Get (Current_Perm_Env, Unique_Entity (P)); @@ -2990,13 +2656,13 @@ package body Sem_SPARK is -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); - if C = null then -- No null possible here, there are no parents for the path. -- This means we are using a global variable without adding -- it in environment with a global aspect. Illegal_Global_Usage (N); + else return (R => Unfolded, Tree_Access => C); end if; @@ -3023,8 +2689,7 @@ package body Sem_SPARK is when N_Selected_Component => declare - C : constant Perm_Or_Tree := - Get_Perm_Or_Tree (Prefix (N)); + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin case C.R is @@ -3035,7 +2700,6 @@ package body Sem_SPARK is when Unfolded => pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object or else Kind (C.Tree_Access) = Record_Component); @@ -3044,30 +2708,32 @@ package body Sem_SPARK is declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - Selected_C : constant Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C.Tree_Access), Selected_Component); begin if Selected_C = null then - return (R => Unfolded, + return (R => Unfolded, Tree_Access => Other_Components (C.Tree_Access)); + else - return (R => Unfolded, + return (R => Unfolded, Tree_Access => Selected_C); end if; end; + elsif Kind (C.Tree_Access) = Entire_Object then - return (R => Folded, Found_Permission => + return (R => Folded, + Found_Permission => Children_Permission (C.Tree_Access)); + else raise Program_Error; end if; end case; end; - -- We get the permission tree of its prefix, and then get either the -- subtree associated with that specific selection, or if we have a -- leaf that folds its children, we take the children's permission @@ -3077,8 +2743,7 @@ package body Sem_SPARK is | N_Slice => declare - C : constant Perm_Or_Tree := - Get_Perm_Or_Tree (Prefix (N)); + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin case C.R is @@ -3089,25 +2754,24 @@ package body Sem_SPARK is when Unfolded => pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object or else Kind (C.Tree_Access) = Array_Component); if Kind (C.Tree_Access) = Array_Component then pragma Assert (Get_Elem (C.Tree_Access) /= null); - return (R => Unfolded, Tree_Access => Get_Elem (C.Tree_Access)); + elsif Kind (C.Tree_Access) = Entire_Object then return (R => Folded, Found_Permission => Children_Permission (C.Tree_Access)); + else raise Program_Error; end if; end case; end; - -- We get the permission tree of its prefix, and then get either the -- subtree associated with that specific selection, or if we have a -- leaf that folds its children, we take the children's permission @@ -3115,8 +2779,7 @@ package body Sem_SPARK is when N_Explicit_Dereference => declare - C : constant Perm_Or_Tree := - Get_Perm_Or_Tree (Prefix (N)); + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin case C.R is @@ -3127,29 +2790,32 @@ package body Sem_SPARK is when Unfolded => pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object or else Kind (C.Tree_Access) = Reference); if Kind (C.Tree_Access) = Reference then if Get_All (C.Tree_Access) = null then + -- Hash_Table_Error + raise Program_Error; + else return (R => Unfolded, Tree_Access => Get_All (C.Tree_Access)); end if; + elsif Kind (C.Tree_Access) = Entire_Object then return (R => Folded, Found_Permission => Children_Permission (C.Tree_Access)); + else raise Program_Error; end if; end case; end; - -- The name contains a function call, hence the given path is always -- new. We do not have to check for anything. @@ -3165,10 +2831,7 @@ package body Sem_SPARK is -- Get_Perm_Tree -- ------------------- - function Get_Perm_Tree - (N : Node_Id) - return Perm_Tree_Access - is + function Get_Perm_Tree (N : Node_Id) return Perm_Tree_Access is begin case Nkind (N) is @@ -3183,7 +2846,6 @@ package body Sem_SPARK is => declare P : constant Node_Id := Entity (N); - C : constant Perm_Tree_Access := Get (Current_Perm_Env, Unique_Entity (P)); @@ -3193,13 +2855,13 @@ package body Sem_SPARK is -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); - if C = null then -- No null possible here, there are no parents for the path. -- This means we are using a global variable without adding -- it in environment with a global aspect. Illegal_Global_Usage (N); + else return C; end if; @@ -3220,11 +2882,11 @@ package body Sem_SPARK is when N_Selected_Component => declare - C : constant Perm_Tree_Access := - Get_Perm_Tree (Prefix (N)); + C : constant Perm_Tree_Access := Get_Perm_Tree (Prefix (N)); begin if C = null then + -- If null then it means we went through a function call return null; @@ -3234,6 +2896,7 @@ package body Sem_SPARK is or else Kind (C) = Record_Component); if Kind (C) = Record_Component then + -- The tree is unfolded. We just return the subtree. declare @@ -3247,9 +2910,9 @@ package body Sem_SPARK is if Selected_C = null then return Other_Components (C); end if; - return Selected_C; end; + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with @@ -3265,7 +2928,6 @@ package body Sem_SPARK is Children_Permission (C); begin - -- We change the current node from Entire_Object to -- Record_Component with same permission and an empty -- hash table as component list. @@ -3288,6 +2950,7 @@ package body Sem_SPARK is -- We fill the hash table with all sons of the record, -- with basic Entire_Objects nodes. + Elem := First_Component_Or_Discriminant (Etype (Prefix (N))); @@ -3301,10 +2964,8 @@ package body Sem_SPARK is Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); - Next_Component_Or_Discriminant (Elem); end loop; - -- we return the tree to the sons, so that the recursion -- can continue. @@ -3318,16 +2979,13 @@ package body Sem_SPARK is begin pragma Assert (Selected_C /= null); - return Selected_C; end; - end; else raise Program_Error; end if; end; - -- We set the permission tree of its prefix, and then we extract from -- the returned pointer the subtree. If folded, we unroll the tree at -- one step. @@ -3336,8 +2994,7 @@ package body Sem_SPARK is | N_Slice => declare - C : constant Perm_Tree_Access := - Get_Perm_Tree (Prefix (N)); + C : constant Perm_Tree_Access := Get_Perm_Tree (Prefix (N)); begin if C = null then @@ -3345,16 +3002,16 @@ package body Sem_SPARK is return null; end if; - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); if Kind (C) = Array_Component then + -- The tree is unfolded. We just return the elem subtree pragma Assert (Get_Elem (C) = null); - return Get_Elem (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace node with Array_Component. @@ -3377,14 +3034,12 @@ package body Sem_SPARK is Is_Node_Deep => Is_Node_Deep (C), Permission => Permission (C), Get_Elem => Son); - return Get_Elem (C); end; else raise Program_Error; end if; end; - -- We get the permission tree of its prefix, and then get either the -- subtree associated with that specific selection, or if we have a -- leaf that folds its children, we unroll the tree. @@ -3397,6 +3052,7 @@ package body Sem_SPARK is C := Get_Perm_Tree (Prefix (N)); if C = null then + -- If null, we went through a function call return null; @@ -3406,14 +3062,17 @@ package body Sem_SPARK is or else Kind (C) = Reference); if Kind (C) = Reference then + -- The tree is unfolded. We return the elem subtree if Get_All (C) = null then + -- Hash_Table_Error + raise Program_Error; end if; - return Get_All (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with Reference. @@ -3432,19 +3091,16 @@ package body Sem_SPARK is -- Reference with same permission and the previous son. pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), Permission => Permission (C), Get_All => Son); - return Get_All (C); end; else raise Program_Error; end if; end; - -- No permission tree for function calls when N_Function_Call => @@ -3455,316 +3111,65 @@ package body Sem_SPARK is end case; end Get_Perm_Tree; - --------- - -- Glb -- - --------- + -------- + -- Hp -- + -------- - function Glb (P1, P2 : Perm_Kind) return Perm_Kind - is - begin - case P1 is - when No_Access => - return No_Access; - - when Read_Only => - case P2 is - when No_Access - | Write_Only - => - return No_Access; + procedure Hp (P : Perm_Env) is + Elem : Perm_Tree_Maps.Key_Option; - when Read_Perm => - return Read_Only; - end case; + begin + Elem := Get_First_Key (P); + while Elem.Present loop + Print_Node_Briefly (Elem.K); + Elem := Get_Next_Key (P); + end loop; + end Hp; - when Write_Only => - case P2 is - when No_Access - | Read_Only - => - return No_Access; + -------------------------- + -- Illegal_Global_Usage -- + -------------------------- - when Write_Perm => - return Write_Only; - end case; + procedure Illegal_Global_Usage (N : Node_Or_Entity_Id) is + begin + Error_Msg_NE ("cannot use global variable & of deep type", N, N); + Error_Msg_N ("\without prior declaration in a Global aspect", N); + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Exit_Program (E_Errors); + end Illegal_Global_Usage; - when Read_Write => - return P2; - end case; - end Glb; + ------------- + -- Is_Deep -- + ------------- - --------------- - -- Has_Alias -- - --------------- + function Is_Deep (E : Entity_Id) return Boolean is + function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean; + function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean is + Decl : Node_Id; + Pack_Decl : Node_Id; - function Has_Alias - (N : Node_Id) - return Boolean - is - function Has_Alias_Deep (Typ : Entity_Id) return Boolean; - function Has_Alias_Deep (Typ : Entity_Id) return Boolean - is - Comp : Node_Id; begin + if Is_Itype (E) then + Decl := Associated_Node_For_Itype (E); + else + Decl := Parent (E); + end if; - if Is_Array_Type (Typ) - and then Has_Aliased_Components (Typ) - then - return True; - - -- Note: Has_Aliased_Components applies only to arrays - - elsif Is_Record_Type (Typ) then - -- It is possible to have an aliased discriminant, so they must be - -- checked along with normal components. - - Comp := First_Component_Or_Discriminant (Typ); - while Present (Comp) loop - if Is_Aliased (Comp) - or else Is_Aliased (Etype (Comp)) - then - return True; - end if; - - if Has_Alias_Deep (Etype (Comp)) then - return True; - end if; + Pack_Decl := Parent (Parent (Decl)); - Next_Component_Or_Discriminant (Comp); - end loop; + if Nkind (Pack_Decl) /= N_Package_Declaration then return False; - else - return Is_Aliased (Typ); end if; - end Has_Alias_Deep; - begin - case Nkind (N) is + return + Present (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) + and then Get_SPARK_Mode_From_Annotation + (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) = Off; + end Is_Private_Entity_Mode_Off; - when N_Identifier - | N_Expanded_Name - => - return Is_Aliased (Entity (N)) or else Has_Alias_Deep (Etype (N)); - - when N_Defining_Identifier => - return Is_Aliased (N) or else Has_Alias_Deep (Etype (N)); - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Has_Alias (Expression (N)); - - when N_Parameter_Specification => - return Has_Alias (Defining_Identifier (N)); - - when N_Selected_Component => - case Nkind (Selector_Name (N)) is - when N_Identifier => - if Is_Aliased (Entity (Selector_Name (N))) then - return True; - end if; - - when others => null; - - end case; - - return Has_Alias (Prefix (N)); - - when N_Indexed_Component - | N_Slice - => - return Has_Alias (Prefix (N)); - - when N_Explicit_Dereference => - return True; - - when N_Function_Call => - return False; - - when N_Attribute_Reference => - if Is_Deep (Etype (Prefix (N))) then - raise Program_Error; - end if; - return False; - - when others => - return False; - end case; - end Has_Alias; - - ------------------------- - -- Has_Array_Component -- - ------------------------- - - function Has_Array_Component (N : Node_Id) return Boolean is - begin - case Nkind (N) is - -- Base identifier. There is no array component here. - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - return False; - - -- We check if the expression inside the conversion has an array - -- component. - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Has_Array_Component (Expression (N)); - - -- We check if the prefix has an array component - - when N_Selected_Component => - return Has_Array_Component (Prefix (N)); - - -- We found the array component, return True - - when N_Indexed_Component - | N_Slice - => - return True; - - -- We check if the prefix has an array component - - when N_Explicit_Dereference => - return Has_Array_Component (Prefix (N)); - - when N_Function_Call => - return False; - - when others => - raise Program_Error; - end case; - end Has_Array_Component; - - ---------------------------- - -- Has_Function_Component -- - ---------------------------- - - function Has_Function_Component (N : Node_Id) return Boolean is - begin - case Nkind (N) is - -- Base identifier. There is no function component here. - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - return False; - - -- We check if the expression inside the conversion has a function - -- component. - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Has_Function_Component (Expression (N)); - - -- We check if the prefix has a function component - - when N_Selected_Component => - return Has_Function_Component (Prefix (N)); - - -- We check if the prefix has a function component - - when N_Indexed_Component - | N_Slice - => - return Has_Function_Component (Prefix (N)); - - -- We check if the prefix has a function component - - when N_Explicit_Dereference => - return Has_Function_Component (Prefix (N)); - - -- We found the function component, return True - - when N_Function_Call => - return True; - - when others => - raise Program_Error; - - end case; - end Has_Function_Component; - - -------- - -- Hp -- - -------- - - procedure Hp (P : Perm_Env) is - Elem : Perm_Tree_Maps.Key_Option; - - begin - Elem := Get_First_Key (P); - while Elem.Present loop - Print_Node_Briefly (Elem.K); - Elem := Get_Next_Key (P); - end loop; - end Hp; - - -------------------------- - -- Illegal_Global_Usage -- - -------------------------- - - procedure Illegal_Global_Usage (N : Node_Or_Entity_Id) is - begin - Error_Msg_NE ("cannot use global variable & of deep type", N, N); - Error_Msg_N ("\without prior declaration in a Global aspect", N); - - Errout.Finalize (Last_Call => True); - Errout.Output_Messages; - Exit_Program (E_Errors); - end Illegal_Global_Usage; - - -------------------- - -- Is_Borrowed_In -- - -------------------- - - function Is_Borrowed_In (E : Entity_Id) return Boolean is - begin - return Is_Access_Type (Etype (E)) - and then not Is_Access_Constant (Etype (E)); - end Is_Borrowed_In; - - ------------- - -- Is_Deep -- - ------------- - - function Is_Deep (E : Entity_Id) return Boolean is - function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean; - - function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean is - Decl : Node_Id; - Pack_Decl : Node_Id; - - begin - if Is_Itype (E) then - Decl := Associated_Node_For_Itype (E); - else - Decl := Parent (E); - end if; - - Pack_Decl := Parent (Parent (Decl)); - - if Nkind (Pack_Decl) /= N_Package_Declaration then - return False; - end if; - - return - Present (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) - and then Get_SPARK_Mode_From_Annotation - (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) = Off; - end Is_Private_Entity_Mode_Off; begin pragma Assert (Is_Type (E)); - case Ekind (E) is when Scalar_Kind => return False; @@ -3793,7 +3198,7 @@ package body Sem_SPARK is when E_Record_Type | E_Record_Subtype - => + => declare Elmt : Entity_Id; @@ -3806,7 +3211,6 @@ package body Sem_SPARK is Next_Component_Or_Discriminant (Elmt); end if; end loop; - return False; end; @@ -3821,10 +3225,9 @@ package body Sem_SPARK is end if; end if; - when E_Incomplete_Type => - return True; - - when E_Incomplete_Subtype => + when E_Incomplete_Type + | E_Incomplete_Subtype + => return True; -- No problem with synchronized types @@ -3845,373 +3248,67 @@ package body Sem_SPARK is end Is_Deep; ---------------- - -- Is_Shallow -- + -- Perm_Error -- ---------------- - function Is_Shallow (E : Entity_Id) return Boolean is - begin - pragma Assert (Is_Type (E)); - return not Is_Deep (E); - end Is_Shallow; - - ------------------ - -- Loop_Of_Exit -- - ------------------ - - function Loop_Of_Exit (N : Node_Id) return Entity_Id is - Nam : Node_Id := Name (N); - Stmt : Node_Id := N; - begin - if No (Nam) then - while Present (Stmt) loop - Stmt := Parent (Stmt); - if Nkind (Stmt) = N_Loop_Statement then - Nam := Identifier (Stmt); - exit; - end if; - end loop; - end if; - return Entity (Nam); - end Loop_Of_Exit; - --------- - -- Lub -- - --------- - - function Lub (P1, P2 : Perm_Kind) return Perm_Kind + procedure Perm_Error + (N : Node_Id; + Perm : Perm_Kind; + Found_Perm : Perm_Kind) is - begin - case P1 is - when No_Access => - return P2; - - when Read_Only => - case P2 is - when No_Access - | Read_Only - => - return Read_Only; - - when Write_Perm => - return Read_Write; - end case; - - when Write_Only => - case P2 is - when No_Access - | Write_Only - => - return Write_Only; + procedure Set_Root_Object + (Path : Node_Id; + Obj : out Entity_Id; + Deref : out Boolean); + -- Set the root object Obj, and whether the path contains a dereference, + -- from a path Path. - when Read_Perm => - return Read_Write; - end case; + --------------------- + -- Set_Root_Object -- + --------------------- - when Read_Write => - return Read_Write; - end case; - end Lub; + procedure Set_Root_Object + (Path : Node_Id; + Obj : out Entity_Id; + Deref : out Boolean) + is + begin + case Nkind (Path) is + when N_Identifier + | N_Expanded_Name + => + Obj := Entity (Path); + Deref := False; - ---------------- - -- Merge_Envs -- - ---------------- + when N_Type_Conversion + | N_Unchecked_Type_Conversion + | N_Qualified_Expression + => + Set_Root_Object (Expression (Path), Obj, Deref); - procedure Merge_Envs - (Target : in out Perm_Env; - Source : in out Perm_Env) - is - procedure Merge_Trees - (Target : Perm_Tree_Access; - Source : Perm_Tree_Access); + when N_Indexed_Component + | N_Selected_Component + | N_Slice + => + Set_Root_Object (Prefix (Path), Obj, Deref); - procedure Merge_Trees - (Target : Perm_Tree_Access; - Source : Perm_Tree_Access) - is - procedure Apply_Glb_Tree - (A : Perm_Tree_Access; - P : Perm_Kind); - - procedure Apply_Glb_Tree - (A : Perm_Tree_Access; - P : Perm_Kind) - is - begin - A.all.Tree.Permission := Glb (Permission (A), P); + when N_Explicit_Dereference => + Set_Root_Object (Prefix (Path), Obj, Deref); + Deref := True; - case Kind (A) is - when Entire_Object => - A.all.Tree.Children_Permission := - Glb (Children_Permission (A), P); + when others => + raise Program_Error; + end case; + end Set_Root_Object; + -- Local variables - when Reference => - Apply_Glb_Tree (Get_All (A), P); + Root : Entity_Id; + Is_Deref : Boolean; - when Array_Component => - Apply_Glb_Tree (Get_Elem (A), P); + -- Start of processing for Perm_Error - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First (Component (A)); - while Comp /= null loop - Apply_Glb_Tree (Comp, P); - Comp := Perm_Tree_Maps.Get_Next (Component (A)); - end loop; - - Apply_Glb_Tree (Other_Components (A), P); - end; - end case; - end Apply_Glb_Tree; - - Perm : constant Perm_Kind := - Glb (Permission (Target), Permission (Source)); - - begin - pragma Assert (Is_Node_Deep (Target) = Is_Node_Deep (Source)); - Target.all.Tree.Permission := Perm; - - case Kind (Target) is - when Entire_Object => - declare - Child_Perm : constant Perm_Kind := - Children_Permission (Target); - - begin - case Kind (Source) is - when Entire_Object => - Target.all.Tree.Children_Permission := - Glb (Child_Perm, Children_Permission (Source)); - - when Reference => - Copy_Tree (Source, Target); - Target.all.Tree.Permission := Perm; - Apply_Glb_Tree (Get_All (Target), Child_Perm); - - when Array_Component => - Copy_Tree (Source, Target); - Target.all.Tree.Permission := Perm; - Apply_Glb_Tree (Get_Elem (Target), Child_Perm); - - when Record_Component => - Copy_Tree (Source, Target); - Target.all.Tree.Permission := Perm; - declare - Comp : Perm_Tree_Access; - - begin - Comp := - Perm_Tree_Maps.Get_First (Component (Target)); - while Comp /= null loop - -- Apply glb tree on every component subtree - - Apply_Glb_Tree (Comp, Child_Perm); - Comp := Perm_Tree_Maps.Get_Next - (Component (Target)); - end loop; - end; - Apply_Glb_Tree (Other_Components (Target), Child_Perm); - - end case; - end; - when Reference => - case Kind (Source) is - when Entire_Object => - Apply_Glb_Tree (Get_All (Target), - Children_Permission (Source)); - - when Reference => - Merge_Trees (Get_All (Target), Get_All (Source)); - - when others => - raise Program_Error; - - end case; - - when Array_Component => - case Kind (Source) is - when Entire_Object => - Apply_Glb_Tree (Get_Elem (Target), - Children_Permission (Source)); - - when Array_Component => - Merge_Trees (Get_Elem (Target), Get_Elem (Source)); - - when others => - raise Program_Error; - - end case; - - when Record_Component => - case Kind (Source) is - when Entire_Object => - declare - Child_Perm : constant Perm_Kind := - Children_Permission (Source); - - Comp : Perm_Tree_Access; - - begin - Comp := Perm_Tree_Maps.Get_First - (Component (Target)); - while Comp /= null loop - -- Apply glb tree on every component subtree - - Apply_Glb_Tree (Comp, Child_Perm); - Comp := - Perm_Tree_Maps.Get_Next (Component (Target)); - end loop; - Apply_Glb_Tree (Other_Components (Target), Child_Perm); - end; - - when Record_Component => - declare - Key_Source : Perm_Tree_Maps.Key_Option; - CompTarget : Perm_Tree_Access; - CompSource : Perm_Tree_Access; - - begin - Key_Source := Perm_Tree_Maps.Get_First_Key - (Component (Source)); - - while Key_Source.Present loop - CompSource := Perm_Tree_Maps.Get - (Component (Source), Key_Source.K); - CompTarget := Perm_Tree_Maps.Get - (Component (Target), Key_Source.K); - - pragma Assert (CompSource /= null); - Merge_Trees (CompTarget, CompSource); - - Key_Source := Perm_Tree_Maps.Get_Next_Key - (Component (Source)); - end loop; - - Merge_Trees (Other_Components (Target), - Other_Components (Source)); - end; - - when others => - raise Program_Error; - - end case; - end case; - end Merge_Trees; - - CompTarget : Perm_Tree_Access; - CompSource : Perm_Tree_Access; - KeyTarget : Perm_Tree_Maps.Key_Option; - - begin - KeyTarget := Get_First_Key (Target); - -- Iterate over every tree of the environment in the target, and merge - -- it with the source if there is such a similar one that exists. If - -- there is none, then skip. - while KeyTarget.Present loop - - CompSource := Get (Source, KeyTarget.K); - CompTarget := Get (Target, KeyTarget.K); - - pragma Assert (CompTarget /= null); - - if CompSource /= null then - Merge_Trees (CompTarget, CompSource); - Remove (Source, KeyTarget.K); - end if; - - KeyTarget := Get_Next_Key (Target); - end loop; - - -- Iterate over every tree of the environment of the source. And merge - -- again. If there is not any tree of the target then just copy the tree - -- from source to target. - declare - KeySource : Perm_Tree_Maps.Key_Option; - begin - KeySource := Get_First_Key (Source); - while KeySource.Present loop - - CompSource := Get (Source, KeySource.K); - CompTarget := Get (Target, KeySource.K); - - if CompTarget = null then - CompTarget := new Perm_Tree_Wrapper'(CompSource.all); - Copy_Tree (CompSource, CompTarget); - Set (Target, KeySource.K, CompTarget); - else - Merge_Trees (CompTarget, CompSource); - end if; - - KeySource := Get_Next_Key (Source); - end loop; - end; - - Free_Env (Source); - end Merge_Envs; - - ---------------- - -- Perm_Error -- - ---------------- - - procedure Perm_Error - (N : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind) - is - procedure Set_Root_Object - (Path : Node_Id; - Obj : out Entity_Id; - Deref : out Boolean); - -- Set the root object Obj, and whether the path contains a dereference, - -- from a path Path. - - --------------------- - -- Set_Root_Object -- - --------------------- - - procedure Set_Root_Object - (Path : Node_Id; - Obj : out Entity_Id; - Deref : out Boolean) - is - begin - case Nkind (Path) is - when N_Identifier - | N_Expanded_Name - => - Obj := Entity (Path); - Deref := False; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - Set_Root_Object (Expression (Path), Obj, Deref); - - when N_Indexed_Component - | N_Selected_Component - | N_Slice - => - Set_Root_Object (Prefix (Path), Obj, Deref); - - when N_Explicit_Dereference => - Set_Root_Object (Prefix (Path), Obj, Deref); - Deref := True; - - when others => - raise Program_Error; - end case; - end Set_Root_Object; - - -- Local variables - - Root : Entity_Id; - Is_Deref : Boolean; - - -- Start of processing for Perm_Error - - begin - Set_Root_Object (N, Root, Is_Deref); + begin + Set_Root_Object (N, Root, Is_Deref); if Is_Deref then Error_Msg_NE @@ -4245,8 +3342,8 @@ package body Sem_SPARK is ------------------ procedure Process_Path (N : Node_Id) is - Root : constant Entity_Id := Get_Enclosing_Object (N); - + Root : constant Entity_Id := Get_Enclosing_Object (N); + State_N : Perm_Kind; begin -- We ignore if yielding to synchronized @@ -4256,200 +3353,153 @@ package body Sem_SPARK is return; end if; - -- We ignore shallow unaliased. They are checked in flow analysis, - -- allowing backward compatibility. + State_N := Get_Perm (N); - if Current_Checking_Mode /= Super_Move - and then not Has_Alias (N) - and then Is_Shallow (Etype (N)) - then - return; - end if; - - declare - Perm_N : constant Perm_Kind := Get_Perm (N); - - begin + case Current_Checking_Mode is - case Current_Checking_Mode is - -- Check permission R, do nothing + -- Check permission R, do nothing - when Read => - if Perm_N not in Read_Perm then - Perm_Error (N, Read_Only, Perm_N); - return; - end if; + when Read => - -- If shallow type no need for RW, only R + -- This condition should be removed when removing the read + -- checking mode. - when Move => - if Is_Shallow (Etype (N)) then - if Perm_N not in Read_Perm then - Perm_Error (N, Read_Only, Perm_N); - return; - end if; - else - -- Check permission RW if deep + return; - if Perm_N /= Read_Write then - Perm_Error (N, Read_Write, Perm_N); - return; - end if; + when Move => - declare - -- Set permission to W to the path and any of its prefix + -- The rhs object in an assignment statement (including copy in + -- and copy back) should be in the Unrestricted or Moved state. + -- Otherwise the move is not allowed. + -- This applies to both stand-alone and composite objects. + -- If the state of the source is Moved, then a warning message + -- is prompt to make the user aware of reading a nullified + -- object. - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (N, Move); + if State_N /= Unrestricted and State_N /= Moved then + Perm_Error (N, Unrestricted, State_N); + return; + end if; - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. + -- In the AI, after moving a path nothing to do since the rhs + -- object was in the Unrestricted state and it shall be + -- refreshed to Unrestricted. The object should be nullified + -- however. To avoid moving again a name that has already been + -- moved, in this implementation we set the state of the moved + -- object to "Moved". This shall be used to prompt a warning + -- when manipulating a null pointer and also to implement + -- the no aliasing parameter restriction. + + if State_N = Moved then + Error_Msg_N ("?the source or one of its extensions has" + & " already been moved", N); + end if; - return; - end if; + declare + -- Set state to Borrowed to the path and any of its prefixes - -- Set permissions to - -- No for any extension with more .all - -- W for any deep extension with same number of .all - -- RW for any shallow extension with same number of .all + Tree : constant Perm_Tree_Access := + Set_Perm_Prefixes (N, Moved); - Set_Perm_Extensions_Move (Tree, Etype (N)); - end; - end if; + begin + if Tree = null then - -- Check permission RW + -- We went through a function call, no permission to + -- modify. - when Super_Move => - if Perm_N /= Read_Write then - Perm_Error (N, Read_Write, Perm_N); return; end if; - declare - -- Set permission to No to the path and any of its prefix up - -- to the first .all and then W. - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (N, Super_Move); - - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. - - return; - end if; + -- Set state to Borrowed on any strict extension of the path - -- Set permissions to No on any strict extension of the path + Set_Perm_Extensions (Tree, Moved); + end; - Set_Perm_Extensions (Tree, No_Access); - end; + when Assign => - -- Check permission W + -- The lhs object in an assignment statement (including copy in + -- and copy back) should be in the Unrestricted state. + -- Otherwise the move is not allowed. + -- This applies to both stand-alone and composite objects. - when Assign => - if Perm_N not in Write_Perm then - Perm_Error (N, Write_Only, Perm_N); - return; - end if; + if State_N /= Unrestricted and State_N /= Moved then + Perm_Error (N, Unrestricted, State_N); + return; + end if; - -- If the tree has an array component, then the permissions do - -- not get modified by the assignment. + -- After assigning to a path nothing to do since it was in the + -- Unrestricted state and it would be refreshed to + -- Unrestricted. - if Has_Array_Component (N) then - return; - end if; + when Borrow => - -- Same if has function component + -- Borrowing is only allowed on Unrestricted objects. - if Has_Function_Component (N) then -- Dead code? - return; - end if; + if State_N /= Unrestricted and State_N /= Moved then + Perm_Error (N, Unrestricted, State_N); + end if; - declare - -- Get the permission tree for the path + if State_N = Moved then + Error_Msg_N ("?the source or one of its extensions has" + & " already been moved", N); + end if; - Tree : constant Perm_Tree_Access := - Get_Perm_Tree (N); + declare + -- Set state to Borrowed to the path and any of its prefixes - Dummy : Perm_Tree_Access; + Tree : constant Perm_Tree_Access := + Set_Perm_Prefixes (N, Borrowed); - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. + begin + if Tree = null then - return; - end if; + -- We went through a function call, no permission to + -- modify. - -- Set permission RW for it and all of its extensions + return; + end if; - Tree.all.Tree.Permission := Read_Write; + -- Set state to Borrowed on any strict extension of the path - Set_Perm_Extensions (Tree, Read_Write); + Set_Perm_Extensions (Tree, Borrowed); + end; - -- Normalize the permission tree + when Observe => + if State_N /= Unrestricted + and then State_N /= Observed + then + Perm_Error (N, Observed, State_N); + end if; - Dummy := Set_Perm_Prefixes_Assign (N); - end; + declare + -- Set permission to Observed on the path and any of its + -- prefixes if it is of a deep type. Actually, some operation + -- like reading from an object of access type is considered as + -- observe while it should not affect the permissions of + -- the considered tree. - -- Check permission W + Tree : Perm_Tree_Access; - when Borrow_Out => - if Perm_N not in Write_Perm then - Perm_Error (N, Write_Only, Perm_N); + begin + if Is_Deep (Etype (N)) then + Tree := Set_Perm_Prefixes (N, Observed); + else + Tree := null; end if; - declare - -- Set permission to No to the path and any of its prefixes - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (N); - - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. - - return; - end if; - - -- Set permissions to No on any strict extension of the path - - Set_Perm_Extensions (Tree, No_Access); - end; + if Tree = null then - when Observe => - if Perm_N not in Read_Perm then - Perm_Error (N, Read_Only, Perm_N); - end if; + -- We went through a function call, no permission to + -- modify. - if Is_By_Copy_Type (Etype (N)) then return; end if; - declare - -- Set permission to No on the path and any of its prefixes - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (N); - - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. - - return; - end if; - - -- Set permissions to No on any strict extension of the path + -- Set permissions to No on any strict extension of the path - Set_Perm_Extensions (Tree, Read_Only); - end; - end case; - end; + Set_Perm_Extensions (Tree, Observed); + end; + end case; end Process_Path; ------------------------- @@ -4457,7 +3507,6 @@ package body Sem_SPARK is ------------------------- procedure Return_Declarations (L : List_Id) is - procedure Return_Declaration (Decl : Node_Id); -- Check correct permissions for every declared object @@ -4468,6 +3517,7 @@ package body Sem_SPARK is procedure Return_Declaration (Decl : Node_Id) is begin if Nkind (Decl) = N_Object_Declaration then + -- Check RW for object declared, unless the object has never been -- initialized. @@ -4477,15 +3527,6 @@ package body Sem_SPARK is return; end if; - -- We ignore shallow unaliased. They are checked in flow analysis, - -- allowing backward compatibility. - - if not Has_Alias (Defining_Identifier (Decl)) - and then Is_Shallow (Etype (Defining_Identifier (Decl))) - then - return; - end if; - declare Elem : constant Perm_Tree_Access := Get (Current_Perm_Env, @@ -4493,22 +3534,23 @@ package body Sem_SPARK is begin if Elem = null then + -- Here we are on a declaration. Hence it should have been -- added in the environment when analyzing this node with -- mode Read. Hence it is not possible to find a null -- pointer here. -- Hash_Table_Error + raise Program_Error; end if; - if Permission (Elem) /= Read_Write then - Perm_Error (Decl, Read_Write, Permission (Elem)); + if Permission (Elem) /= Unrestricted then + Perm_Error (Decl, Unrestricted, Permission (Elem)); end if; end; end if; end Return_Declaration; - -- Local Variables N : Node_Id; @@ -4517,831 +3559,227 @@ package body Sem_SPARK is begin N := First (L); - while Present (N) loop - Return_Declaration (N); - Next (N); - end loop; - end Return_Declarations; - - -------------------- - -- Return_Globals -- - -------------------- - - procedure Return_Globals (Subp : Entity_Id) is - - procedure Return_Globals_From_List - (First_Item : Node_Id; - Kind : Formal_Kind); - -- Return global items from the list starting at Item - - procedure Return_Globals_Of_Mode (Global_Mode : Name_Id); - -- Return global items for the mode Global_Mode - - ------------------------------ - -- Return_Globals_From_List -- - ------------------------------ - - procedure Return_Globals_From_List - (First_Item : Node_Id; - Kind : Formal_Kind) - is - Item : Node_Id := First_Item; - E : Entity_Id; - - begin - while Present (Item) loop - E := Entity (Item); - - -- Ignore abstract states, which play no role in pointer aliasing - - if Ekind (E) = E_Abstract_State then - null; - else - Return_Parameter_Or_Global (E, Kind, Subp, Global_Var => True); - end if; - Next_Global (Item); - end loop; - end Return_Globals_From_List; - - ---------------------------- - -- Return_Globals_Of_Mode -- - ---------------------------- - - procedure Return_Globals_Of_Mode (Global_Mode : Name_Id) is - Kind : Formal_Kind; - - begin - case Global_Mode is - when Name_Input | Name_Proof_In => - Kind := E_In_Parameter; - when Name_Output => - Kind := E_Out_Parameter; - when Name_In_Out => - Kind := E_In_Out_Parameter; - when others => - raise Program_Error; - end case; - - -- Return both global items from Global and Refined_Global pragmas - - Return_Globals_From_List (First_Global (Subp, Global_Mode), Kind); - Return_Globals_From_List - (First_Global (Subp, Global_Mode, Refined => True), Kind); - end Return_Globals_Of_Mode; - - -- Start of processing for Return_Globals - - begin - Return_Globals_Of_Mode (Name_Proof_In); - Return_Globals_Of_Mode (Name_Input); - Return_Globals_Of_Mode (Name_Output); - Return_Globals_Of_Mode (Name_In_Out); - end Return_Globals; - - -------------------------------- - -- Return_Parameter_Or_Global -- - -------------------------------- - - procedure Return_Parameter_Or_Global - (Id : Entity_Id; - Mode : Formal_Kind; - Subp : Entity_Id; - Global_Var : Boolean) - is - Elem : constant Perm_Tree_Access := Get (Current_Perm_Env, Id); - pragma Assert (Elem /= null); - - begin - -- Shallow unaliased parameters and globals cannot introduce pointer - -- aliasing. - - if not Has_Alias (Id) and then Is_Shallow (Etype (Id)) then - null; - - -- Observed IN parameters and globals need not return a permission to - -- the caller. - - elsif Mode = E_In_Parameter - and then (not Is_Borrowed_In (Id) or else Global_Var) - then - null; - - -- All other parameters and globals should return with mode RW to the - -- caller. - - else - if Permission (Elem) /= Read_Write then - Perm_Error_Subprogram_End - (E => Id, - Subp => Subp, - Perm => Read_Write, - Found_Perm => Permission (Elem)); - end if; - end if; - end Return_Parameter_Or_Global; - - ----------------------- - -- Return_Parameters -- - ----------------------- - - procedure Return_Parameters (Subp : Entity_Id) is - Formal : Entity_Id; - - begin - Formal := First_Formal (Subp); - while Present (Formal) loop - Return_Parameter_Or_Global (Formal, Ekind (Formal), Subp, False); - Next_Formal (Formal); - end loop; - end Return_Parameters; - - ------------------------- - -- Set_Perm_Extensions -- - ------------------------- - - procedure Set_Perm_Extensions - (T : Perm_Tree_Access; - P : Perm_Kind) - is - procedure Free_Perm_Tree_Children (T : Perm_Tree_Access); - - procedure Free_Perm_Tree_Children (T : Perm_Tree_Access) - is - begin - case Kind (T) is - when Entire_Object => - null; - - when Reference => - Free_Perm_Tree (T.all.Tree.Get_All); - - when Array_Component => - Free_Perm_Tree (T.all.Tree.Get_Elem); - - -- Free every Component subtree - - when Record_Component => - declare - Comp : Perm_Tree_Access; - - begin - Comp := Perm_Tree_Maps.Get_First (Component (T)); - while Comp /= null loop - Free_Perm_Tree (Comp); - Comp := Perm_Tree_Maps.Get_Next (Component (T)); - end loop; - - Free_Perm_Tree (T.all.Tree.Other_Components); - end; - end case; - end Free_Perm_Tree_Children; - - Son : constant Perm_Tree := - Perm_Tree' - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Permission (T), - Children_Permission => P); - - begin - Free_Perm_Tree_Children (T); - T.all.Tree := Son; - end Set_Perm_Extensions; - - ------------------------------ - -- Set_Perm_Extensions_Move -- - ------------------------------ - - procedure Set_Perm_Extensions_Move - (T : Perm_Tree_Access; - E : Entity_Id) - is - begin - if not Is_Node_Deep (T) then - -- We are a shallow extension with same number of .all - - Set_Perm_Extensions (T, Read_Write); - return; - end if; - - -- We are a deep extension here (or the moved deep path) - - T.all.Tree.Permission := Write_Only; - - case T.all.Tree.Kind is - -- Unroll the tree depending on the type - - when Entire_Object => - case Ekind (E) is - when Scalar_Kind - | E_String_Literal_Subtype - => - Set_Perm_Extensions (T, No_Access); - - -- No need to unroll here, directly put sons to No_Access - - when Access_Kind => - if Ekind (E) in Access_Subprogram_Kind then - null; - else - Set_Perm_Extensions (T, No_Access); - end if; - - -- No unrolling done, too complicated - - when E_Class_Wide_Subtype - | E_Class_Wide_Type - | E_Incomplete_Type - | E_Incomplete_Subtype - | E_Exception_Type - | E_Task_Type - | E_Task_Subtype - => - Set_Perm_Extensions (T, No_Access); - - -- Expand the tree. Replace the node with Array component. - - when E_Array_Type - | E_Array_Subtype => - declare - Son : Perm_Tree_Access; - - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Read_Write, - Children_Permission => Read_Write)); - - Set_Perm_Extensions_Move (Son, Component_Type (E)); - - -- We change the current node from Entire_Object to - -- Reference with Write_Only and the previous son. - - pragma Assert (Is_Node_Deep (T)); - - T.all.Tree := (Kind => Array_Component, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Write_Only, - Get_Elem => Son); - end; - - -- Unroll, and set permission extensions with component type - - when E_Record_Type - | E_Record_Subtype - | E_Record_Type_With_Private - | E_Record_Subtype_With_Private - | E_Protected_Type - | E_Protected_Subtype - => - declare - -- Expand the tree. Replace the node with - -- Record_Component. - - Elem : Node_Id; - - Son : Perm_Tree_Access; - - begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. - - pragma Assert (Is_Node_Deep (T)); - - T.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Write_Only, - Component => Perm_Tree_Maps.Nil, - Other_Components => - new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => True, - Permission => Read_Write, - Children_Permission => Read_Write) - ) - ); - - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. - Elem := First_Component_Or_Discriminant (E); - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Read_Write, - Children_Permission => Read_Write)); - - Set_Perm_Extensions_Move (Son, Etype (Elem)); - - Perm_Tree_Maps.Set - (T.all.Tree.Component, Elem, Son); - - Next_Component_Or_Discriminant (Elem); - end loop; - end; - - when E_Private_Type - | E_Private_Subtype - | E_Limited_Private_Type - | E_Limited_Private_Subtype - => - Set_Perm_Extensions_Move (T, Underlying_Type (E)); - - when others => - raise Program_Error; - end case; - - when Reference => - -- Now the son does not have the same number of .all - Set_Perm_Extensions (T, No_Access); - - when Array_Component => - Set_Perm_Extensions_Move (Get_Elem (T), Component_Type (E)); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - It : Node_Id; - - begin - It := First_Component_Or_Discriminant (E); - while It /= Empty loop - Comp := Perm_Tree_Maps.Get (Component (T), It); - pragma Assert (Comp /= null); - Set_Perm_Extensions_Move (Comp, It); - It := Next_Component_Or_Discriminant (E); - end loop; - - Set_Perm_Extensions (Other_Components (T), No_Access); - end; - end case; - end Set_Perm_Extensions_Move; - - ------------------------------ - -- Set_Perm_Prefixes_Assign -- - ------------------------------ - - function Set_Perm_Prefixes_Assign (N : Node_Id) return Perm_Tree_Access is - C : constant Perm_Tree_Access := Get_Perm_Tree (N); - - begin - pragma Assert (Current_Checking_Mode = Assign); - - -- The function should not be called if has_function_component - - pragma Assert (C /= null); - - case Kind (C) is - when Entire_Object => - pragma Assert (Children_Permission (C) = Read_Write); - - -- Maroua: Children could have read_only perm. Why Read_Write? - - C.all.Tree.Permission := Read_Write; - - when Reference => - pragma Assert (Get_All (C) /= null); - - C.all.Tree.Permission := - Lub (Permission (C), Permission (Get_All (C))); - - when Array_Component => - pragma Assert (C.all.Tree.Get_Elem /= null); - - -- Given that it is not possible to know which element has been - -- assigned, then the permissions do not get changed in case of - -- Array_Component. - - null; - - when Record_Component => - declare - Comp : Perm_Tree_Access; - Perm : Perm_Kind := Read_Write; - - begin - -- We take the Glb of all the descendants, and then update the - -- permission of the node with it. - - Comp := Perm_Tree_Maps.Get_First (Component (C)); - while Comp /= null loop - Perm := Glb (Perm, Permission (Comp)); - Comp := Perm_Tree_Maps.Get_Next (Component (C)); - end loop; - - Perm := Glb (Perm, Permission (Other_Components (C))); - - C.all.Tree.Permission := Lub (Permission (C), Perm); - end; - end case; - - case Nkind (N) is - - -- Base identifier. End recursion here. - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - return null; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Set_Perm_Prefixes_Assign (Expression (N)); - - when N_Parameter_Specification => - raise Program_Error; - - -- Continue recursion on prefix - - when N_Selected_Component => - return Set_Perm_Prefixes_Assign (Prefix (N)); - - -- Continue recursion on prefix - - when N_Indexed_Component - | N_Slice - => - return Set_Perm_Prefixes_Assign (Prefix (N)); - - -- Continue recursion on prefix - - when N_Explicit_Dereference => - return Set_Perm_Prefixes_Assign (Prefix (N)); - - when N_Function_Call => - raise Program_Error; - - when others => - raise Program_Error; - - end case; - end Set_Perm_Prefixes_Assign; - - ---------------------------------- - -- Set_Perm_Prefixes_Borrow_Out -- - ---------------------------------- - - function Set_Perm_Prefixes_Borrow_Out - (N : Node_Id) - return Perm_Tree_Access - is - begin - pragma Assert (Current_Checking_Mode = Borrow_Out); - - case Nkind (N) is - -- Base identifier. Set permission to No. - - when N_Identifier - | N_Expanded_Name - => - declare - P : constant Node_Id := Entity (N); - - C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); - - pragma Assert (C /= null); - - begin - -- Setting the initialization map to True, so that this - -- variable cannot be ignored anymore when looking at end - -- of elaboration of package. - - Set (Current_Initialization_Map, Unique_Entity (P), True); - - C.all.Tree.Permission := No_Access; - return C; - end; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Set_Perm_Prefixes_Borrow_Out (Expression (N)); - - when N_Parameter_Specification - | N_Defining_Identifier - => - raise Program_Error; - - -- We set the permission tree of its prefix, and then we extract - -- our subtree from the returned pointer and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- in one step. - - when N_Selected_Component => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (Prefix (N)); - - begin - if C = null then - -- We went through a function call, do nothing - - return null; - end if; - - -- The permission of the returned node should be No - - pragma Assert (Permission (C) = No_Access); - - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Record_Component); - - if Kind (C) = Record_Component then - -- The tree is unfolded. We just modify the permission and - -- return the record subtree. - - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); - - begin - if Selected_C = null then - Selected_C := Other_Components (C); - end if; - - pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := No_Access; - - return Selected_C; - end; - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with - -- Record_Component. - - Elem : Node_Id; - - -- Create an empty hash table - - Hashtbl : Perm_Tree_Maps.Instance; - - -- We create the unrolled nodes, that will all have same - -- permission than parent. - - Son : Perm_Tree_Access; - - ChildrenPerm : constant Perm_Kind := - Children_Permission (C); - - begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. - - C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, - Other_Components => - new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => True, - Permission => ChildrenPerm, - Children_Permission => ChildrenPerm) - )); - - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. - Elem := First_Component_Or_Discriminant - (Etype (Prefix (N))); - - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => ChildrenPerm, - Children_Permission => ChildrenPerm)); - - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); - - Next_Component_Or_Discriminant (Elem); - end loop; - - -- Now we set the right field to No_Access, and then we - -- return the tree to the sons, so that the recursion can - -- continue. - - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); - - begin - if Selected_C = null then - Selected_C := Other_Components (C); - end if; - - pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := No_Access; - - return Selected_C; - end; - end; - else - raise Program_Error; - end if; - end; - - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree in - -- one step. + while Present (N) loop + Return_Declaration (N); + Next (N); + end loop; + end Return_Declarations; - when N_Indexed_Component - | N_Slice - => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (Prefix (N)); + -------------------- + -- Return_Globals -- + -------------------- - begin - if C = null then - -- We went through a function call, do nothing + procedure Return_Globals (Subp : Entity_Id) is + procedure Return_Globals_From_List + (First_Item : Node_Id; + Kind : Formal_Kind); + -- Return global items from the list starting at Item - return null; - end if; + procedure Return_Globals_Of_Mode (Global_Mode : Name_Id); + -- Return global items for the mode Global_Mode - -- The permission of the returned node should be either W - -- (because the recursive call sets <= Write_Only) or No - -- (if another path has been moved with 'Access). + ------------------------------ + -- Return_Globals_From_List -- + ------------------------------ - pragma Assert (Permission (C) = No_Access); + procedure Return_Globals_From_List + (First_Item : Node_Id; + Kind : Formal_Kind) + is + Item : Node_Id := First_Item; + E : Entity_Id; - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Array_Component); + begin + while Present (Item) loop + E := Entity (Item); - if Kind (C) = Array_Component then - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. + -- Ignore abstract states, which play no role in pointer aliasing - pragma Assert (Get_Elem (C) /= null); + if Ekind (E) = E_Abstract_State then + null; + else + Return_The_Global (E, Kind, Subp); + end if; + Next_Global (Item); + end loop; + end Return_Globals_From_List; - C.all.Tree.Get_Elem.all.Tree.Permission := No_Access; + ---------------------------- + -- Return_Globals_Of_Mode -- + ---------------------------- - return Get_Elem (C); - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace node with Array_Component. + procedure Return_Globals_Of_Mode (Global_Mode : Name_Id) is + Kind : Formal_Kind; - Son : Perm_Tree_Access; + begin + case Global_Mode is + when Name_Input + | Name_Proof_In + => + Kind := E_In_Parameter; + when Name_Output => + Kind := E_Out_Parameter; + when Name_In_Out => + Kind := E_In_Out_Parameter; + when others => + raise Program_Error; + end case; - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (C), - Permission => No_Access, - Children_Permission => Children_Permission (C))); + -- Return both global items from Global and Refined_Global pragmas - -- We change the current node from Entire_Object - -- to Array_Component with same permission and the - -- previously defined son. + Return_Globals_From_List (First_Global (Subp, Global_Mode), Kind); + Return_Globals_From_List + (First_Global (Subp, Global_Mode, Refined => True), Kind); + end Return_Globals_Of_Mode; - C.all.Tree := (Kind => Array_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => No_Access, - Get_Elem => Son); + -- Start of processing for Return_Globals - return Get_Elem (C); - end; - else - raise Program_Error; - end if; - end; + begin + Return_Globals_Of_Mode (Name_Proof_In); + Return_Globals_Of_Mode (Name_Input); + Return_Globals_Of_Mode (Name_Output); + Return_Globals_Of_Mode (Name_In_Out); + end Return_Globals; - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -------------------------------- + -- Return_Parameter_Or_Global -- + -------------------------------- - when N_Explicit_Dereference => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (Prefix (N)); + procedure Return_The_Global + (Id : Entity_Id; + Mode : Formal_Kind; + Subp : Entity_Id) + is + Elem : constant Perm_Tree_Access := Get (Current_Perm_Env, Id); + pragma Assert (Elem /= null); - begin - if C = null then - -- We went through a function call. Do nothing. + begin + -- Observed IN parameters and globals need not return a permission to + -- the caller. - return null; - end if; + if Mode = E_In_Parameter - -- The permission of the returned node should be No + -- Check this for read-only globals. - pragma Assert (Permission (C) = No_Access); - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Reference); + then + if Permission (Elem) /= Unrestricted + and then Permission (Elem) /= Observed + then + Perm_Error_Subprogram_End + (E => Id, + Subp => Subp, + Perm => Observed, + Found_Perm => Permission (Elem)); + end if; - if Kind (C) = Reference then - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. + -- All globals of mode out or in/out should return with mode + -- Unrestricted. - pragma Assert (Get_All (C) /= null); + else + if Permission (Elem) /= Unrestricted then + Perm_Error_Subprogram_End + (E => Id, + Subp => Subp, + Perm => Unrestricted, + Found_Perm => Permission (Elem)); + end if; + end if; + end Return_The_Global; - C.all.Tree.Get_All.all.Tree.Permission := No_Access; + ------------------------- + -- Set_Perm_Extensions -- + ------------------------- - return Get_All (C); - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with Reference. + procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind) is + procedure Free_Perm_Tree_Children (T : Perm_Tree_Access); + procedure Free_Perm_Tree_Children (T : Perm_Tree_Access) is + begin + case Kind (T) is + when Entire_Object => + null; - Son : Perm_Tree_Access; + when Reference => + Free_Perm_Tree (T.all.Tree.Get_All); - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (N)), - Permission => No_Access, - Children_Permission => Children_Permission (C))); + when Array_Component => + Free_Perm_Tree (T.all.Tree.Get_Elem); - -- We change the current node from Entire_Object to - -- Reference with No_Access and the previous son. + -- Free every Component subtree - pragma Assert (Is_Node_Deep (C)); + when Record_Component => + declare + Comp : Perm_Tree_Access; - C.all.Tree := (Kind => Reference, - Is_Node_Deep => Is_Node_Deep (C), - Permission => No_Access, - Get_All => Son); + begin + Comp := Perm_Tree_Maps.Get_First (Component (T)); + while Comp /= null loop + Free_Perm_Tree (Comp); + Comp := Perm_Tree_Maps.Get_Next (Component (T)); + end loop; - return Get_All (C); - end; - else - raise Program_Error; - end if; - end; + Free_Perm_Tree (T.all.Tree.Other_Components); + end; + end case; + end Free_Perm_Tree_Children; - when N_Function_Call => - return null; + Son : constant Perm_Tree := + Perm_Tree' + (Kind => Entire_Object, + Is_Node_Deep => Is_Node_Deep (T), + Permission => Permission (T), + Children_Permission => P); - when others => - raise Program_Error; - end case; - end Set_Perm_Prefixes_Borrow_Out; + begin + Free_Perm_Tree_Children (T); + T.all.Tree := Son; + end Set_Perm_Extensions; - ---------------------------- - -- Set_Perm_Prefixes_Move -- - ---------------------------- + ------------------------------ + -- Set_Perm_Prefixes -- + ------------------------------ - function Set_Perm_Prefixes_Move - (N : Node_Id; Mode : Checking_Mode) - return Perm_Tree_Access + function Set_Perm_Prefixes + (N : Node_Id; + New_Perm : Perm_Kind) + return Perm_Tree_Access is begin - case Nkind (N) is - -- Base identifier. Set permission to W or No depending on Mode. + case Nkind (N) is when N_Identifier | N_Expanded_Name + | N_Defining_Identifier => + if Nkind (N) = N_Defining_Identifier + and then New_Perm = Borrowed + then + raise Program_Error; + end if; + declare - P : constant Node_Id := Entity (N); - C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); + P : Node_Id; + C : Perm_Tree_Access; begin - -- The base tree can be RW (first move from this base path) or - -- W (already some extensions values moved), or even No_Access - -- (extensions moved with 'Access). But it cannot be Read_Only - -- (we get an error). - - if Permission (C) = Read_Only then - raise Unrecoverable_Error; + if Nkind (N) = N_Defining_Identifier then + P := N; + else + P := Entity (N); end if; + C := Get (Current_Perm_Env, Unique_Entity (P)); + pragma Assert (C /= null); + -- Setting the initialization map to True, so that this -- variable cannot be ignored anymore when looking at end -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); + if New_Perm = Observed + and then C = null + then - if C = null then -- No null possible here, there are no parents for the path. -- This means we are using a global variable without adding -- it in environment with a global aspect. @@ -5349,12 +3787,7 @@ package body Sem_SPARK is Illegal_Global_Usage (N); end if; - if Mode = Super_Move then - C.all.Tree.Permission := No_Access; - else - C.all.Tree.Permission := Glb (Write_Only, Permission (C)); - end if; - + C.all.Tree.Permission := New_Perm; return C; end; @@ -5362,45 +3795,29 @@ package body Sem_SPARK is | N_Unchecked_Type_Conversion | N_Qualified_Expression => - return Set_Perm_Prefixes_Move (Expression (N), Mode); + return Set_Perm_Prefixes (Expression (N), New_Perm); - when N_Parameter_Specification - | N_Defining_Identifier - => + when N_Parameter_Specification => raise Program_Error; -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer our subtree and assign an adequate + -- our subtree from the returned pointer and assign an adequate -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -- in one step. when N_Selected_Component => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (Prefix (N), Mode); + Set_Perm_Prefixes (Prefix (N), New_Perm); begin if C = null then + -- We went through a function call, do nothing return null; end if; - -- The permission of the returned node should be either W - -- (because the recursive call sets <= Write_Only) or No - -- (if another path has been moved with 'Access). - - pragma Assert (Permission (C) = No_Access - or else Permission (C) = Write_Only); - - if Mode = Super_Move then - -- The permission of the returned node should be No (thanks - -- to the recursion). - - pragma Assert (Permission (C) = No_Access); - null; - end if; - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Record_Component); @@ -5418,31 +3835,14 @@ package body Sem_SPARK is begin if Selected_C = null then - -- If the hash table returns no element, then we fall - -- into the part of Other_Components. - pragma Assert (Is_Tagged_Type (Etype (Prefix (N)))); - - Selected_C := Other_Components (C); - end if; - - pragma Assert (Selected_C /= null); - - -- The Selected_C can have permissions: - -- RW : first move in this path - -- W : Already other moves in this path - -- No : Already other moves with 'Access - - pragma Assert (Permission (Selected_C) /= Read_Only); - if Mode = Super_Move then - Selected_C.all.Tree.Permission := No_Access; - else - Selected_C.all.Tree.Permission := - Glb (Write_Only, Permission (Selected_C)); - + Selected_C := Other_Components (C); end if; + pragma Assert (Selected_C /= null); + Selected_C.all.Tree.Permission := New_Perm; return Selected_C; end; + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with @@ -5454,17 +3854,12 @@ package body Sem_SPARK is Hashtbl : Perm_Tree_Maps.Instance; - -- We are in Move or Super_Move mode, hence we can assume - -- that the Children_permission is RW, given that there - -- are no other paths that could have been moved. - - pragma Assert (Children_Permission (C) = Read_Write); - - -- We create the unrolled nodes, that will all have RW - -- permission given that we are in move mode. We will - -- then set the right node to W. + -- We create the unrolled nodes, that will all have same + -- permission than parent. - Son : Perm_Tree_Access; + Son : Perm_Tree_Access; + Children_Perm : constant Perm_Kind := + Children_Permission (C); begin -- We change the current node from Entire_Object to @@ -5472,21 +3867,22 @@ package body Sem_SPARK is -- hash table as component list. C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, + (Kind => Record_Component, + Is_Node_Deep => Is_Node_Deep (C), + Permission => Permission (C), + Component => Hashtbl, Other_Components => new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, Is_Node_Deep => True, - Permission => Read_Write, - Children_Permission => Read_Write) + Permission => Children_Perm, + Children_Permission => Children_Perm) )); -- We fill the hash table with all sons of the record, -- with basic Entire_Objects nodes. + Elem := First_Component_Or_Discriminant (Etype (Prefix (N))); @@ -5495,23 +3891,19 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Read_Write, - Children_Permission => Read_Write)); - - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); + Permission => Children_Perm, + Children_Permission => Children_Perm)); + Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); Next_Component_Or_Discriminant (Elem); end loop; - - -- Now we set the right field to Write_Only or No_Access - -- depending on mode, and then we return the tree to the - -- sons, so that the recursion can continue. + -- Now we set the right field to Borrowed, and then we + -- return the tree to the sons, so that the recursion can + -- continue. declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C), Selected_Component); @@ -5522,19 +3914,7 @@ package body Sem_SPARK is end if; pragma Assert (Selected_C /= null); - - -- Given that this is a newly created Select_C, we can - -- safely assume that its permission is Read_Write. - - pragma Assert (Permission (Selected_C) = - Read_Write); - - if Mode = Super_Move then - Selected_C.all.Tree.Permission := No_Access; - else - Selected_C.all.Tree.Permission := Write_Only; - end if; - + Selected_C.all.Tree.Permission := New_Perm; return Selected_C; end; end; @@ -5545,72 +3925,40 @@ package body Sem_SPARK is -- We set the permission tree of its prefix, and then we extract -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -- permission to it, if unfolded. If folded, we unroll the tree in + -- one step. when N_Indexed_Component | N_Slice => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (Prefix (N), Mode); + Set_Perm_Prefixes (Prefix (N), New_Perm); begin if C = null then + -- We went through a function call, do nothing return null; end if; - -- The permission of the returned node should be either - -- W (because the recursive call sets <= Write_Only) - -- or No (if another path has been moved with 'Access) - - if Mode = Super_Move then - pragma Assert (Permission (C) = No_Access); - null; - else - pragma Assert (Permission (C) = Write_Only - or else Permission (C) = No_Access); - null; - end if; - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); if Kind (C) = Array_Component then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. - if Get_Elem (C) = null then - -- Hash_Table_Error - raise Program_Error; - end if; - - -- The Get_Elem can have permissions : - -- RW : first move in this path - -- W : Already other moves in this path - -- No : Already other moves with 'Access - - pragma Assert (Permission (Get_Elem (C)) /= Read_Only); - - if Mode = Super_Move then - C.all.Tree.Get_Elem.all.Tree.Permission := No_Access; - else - C.all.Tree.Get_Elem.all.Tree.Permission := - Glb (Write_Only, Permission (Get_Elem (C))); - end if; - + pragma Assert (Get_Elem (C) /= null); + C.all.Tree.Get_Elem.all.Tree.Permission := New_Perm; return Get_Elem (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace node with Array_Component. - -- We are in move mode, hence we can assume that the - -- Children_permission is RW. - - pragma Assert (Children_Permission (C) = Read_Write); - Son : Perm_Tree_Access; begin @@ -5618,14 +3966,12 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (C), - Permission => Read_Write, - Children_Permission => Read_Write)); + Permission => New_Perm, + Children_Permission => Children_Permission (C))); - if Mode = Super_Move then - Son.all.Tree.Permission := No_Access; - else - Son.all.Tree.Permission := Write_Only; - end if; + -- Children_Permission => Children_Permission (C) + -- this line should be checked maybe New_Perm + -- instead of Children_Permission (C) -- We change the current node from Entire_Object -- to Array_Component with same permission and the @@ -5633,9 +3979,8 @@ package body Sem_SPARK is C.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), + Permission => New_Perm, Get_Elem => Son); - return Get_Elem (C); end; else @@ -5651,56 +3996,32 @@ package body Sem_SPARK is when N_Explicit_Dereference => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (Prefix (N), Move); + Set_Perm_Prefixes (Prefix (N), New_Perm); begin if C = null then - -- We went through a function call: do nothing + + -- We went through a function call. Do nothing. return null; end if; - -- The permission of the returned node should be only - -- W (because the recursive call sets <= Write_Only) - -- No is NOT POSSIBLE here - - pragma Assert (Permission (C) = Write_Only); - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Reference); if Kind (C) = Reference then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. - if Get_All (C) = null then - -- Hash_Table_Error - raise Program_Error; - end if; - - -- The Get_All can have permissions : - -- RW : first move in this path - -- W : Already other moves in this path - -- No : Already other moves with 'Access - - pragma Assert (Permission (Get_All (C)) /= Read_Only); - - if Mode = Super_Move then - C.all.Tree.Get_All.all.Tree.Permission := No_Access; - else - Get_All (C).all.Tree.Permission := - Glb (Write_Only, Permission (Get_All (C))); - end if; + pragma Assert (Get_All (C) /= null); + C.all.Tree.Get_All.all.Tree.Permission := New_Perm; return Get_All (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with Reference. - -- We are in Move or Super_Move mode, hence we can assume - -- that the Children_permission is RW. - - pragma Assert (Children_Permission (C) = Read_Write); - Son : Perm_Tree_Access; begin @@ -5708,28 +4029,20 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (N)), - Permission => Read_Write, - Children_Permission => Read_Write)); - - if Mode = Super_Move then - Son.all.Tree.Permission := No_Access; - else - Son.all.Tree.Permission := Write_Only; - end if; + Permission => New_Perm, + Children_Permission => Children_Permission (C))); -- We change the current node from Entire_Object to - -- Reference with Write_Only and the previous son. + -- Reference with Borrowed and the previous son. pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), - Permission => Write_Only, - -- Write_only is equal to C.Permission + Permission => New_Perm, Get_All => Son); - return Get_All (C); end; + else raise Program_Error; end if; @@ -5741,55 +4054,34 @@ package body Sem_SPARK is when others => raise Program_Error; end case; + end Set_Perm_Prefixes; - end Set_Perm_Prefixes_Move; - - ------------------------------- - -- Set_Perm_Prefixes_Observe -- - ------------------------------- + ------------------------------ + -- Set_Perm_Prefixes_Borrow -- + ------------------------------ - function Set_Perm_Prefixes_Observe - (N : Node_Id) - return Perm_Tree_Access + function Set_Perm_Prefixes_Borrow (N : Node_Id) return Perm_Tree_Access is begin - pragma Assert (Current_Checking_Mode = Observe); - + pragma Assert (Current_Checking_Mode = Borrow); case Nkind (N) is - -- Base identifier. Set permission to R. when N_Identifier | N_Expanded_Name - | N_Defining_Identifier => declare - P : Node_Id; - C : Perm_Tree_Access; + P : constant Node_Id := Entity (N); + C : constant Perm_Tree_Access := + Get (Current_Perm_Env, Unique_Entity (P)); + pragma Assert (C /= null); begin - if Nkind (N) = N_Defining_Identifier then - P := N; - else - P := Entity (N); - end if; - - C := Get (Current_Perm_Env, Unique_Entity (P)); -- Setting the initialization map to True, so that this -- variable cannot be ignored anymore when looking at end -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); - - if C = null then - -- No null possible here, there are no parents for the path. - -- This means we are using a global variable without adding - -- it in environment with a global aspect. - - Illegal_Global_Usage (N); - end if; - - C.all.Tree.Permission := Glb (Read_Only, Permission (C)); - + C.all.Tree.Permission := Borrowed; return C; end; @@ -5797,42 +4089,45 @@ package body Sem_SPARK is | N_Unchecked_Type_Conversion | N_Qualified_Expression => - return Set_Perm_Prefixes_Observe (Expression (N)); + return Set_Perm_Prefixes_Borrow (Expression (N)); - when N_Parameter_Specification => + when N_Parameter_Specification + | N_Defining_Identifier + => raise Program_Error; -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer our subtree and assign an adequate + -- our subtree from the returned pointer and assign an adequate -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -- in one step. when N_Selected_Component => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (Prefix (N)); + Set_Perm_Prefixes_Borrow (Prefix (N)); begin if C = null then + -- We went through a function call, do nothing return null; end if; + -- The permission of the returned node should be No + + pragma Assert (Permission (C) = Borrowed); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Record_Component); if Kind (C) = Record_Component then + -- The tree is unfolded. We just modify the permission and - -- return the record subtree. We put the permission to the - -- glb of read_only and its current permission, to consider - -- the case of observing x.y while x.z has been moved. Then - -- x should be No_Access. + -- return the record subtree. declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C), Selected_Component); @@ -5843,12 +4138,10 @@ package body Sem_SPARK is end if; pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := - Glb (Read_Only, Permission (Selected_C)); - + Selected_C.all.Tree.Permission := Borrowed; return Selected_C; end; + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with @@ -5860,13 +4153,11 @@ package body Sem_SPARK is Hashtbl : Perm_Tree_Maps.Instance; - -- We create the unrolled nodes, that will all have RW - -- permission given that we are in move mode. We will - -- then set the right node to W. + -- We create the unrolled nodes, that will all have same + -- permission than parent. Son : Perm_Tree_Access; - - Child_Perm : constant Perm_Kind := + ChildrenPerm : constant Perm_Kind := Children_Permission (C); begin @@ -5875,21 +4166,22 @@ package body Sem_SPARK is -- hash table as component list. C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, + (Kind => Record_Component, + Is_Node_Deep => Is_Node_Deep (C), + Permission => Permission (C), + Component => Hashtbl, Other_Components => new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, Is_Node_Deep => True, - Permission => Child_Perm, - Children_Permission => Child_Perm) + Permission => ChildrenPerm, + Children_Permission => ChildrenPerm) )); -- We fill the hash table with all sons of the record, -- with basic Entire_Objects nodes. + Elem := First_Component_Or_Discriminant (Etype (Prefix (N))); @@ -5898,26 +4190,21 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Child_Perm, - Children_Permission => Child_Perm)); - - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); - + Permission => ChildrenPerm, + Children_Permission => ChildrenPerm)); + Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); Next_Component_Or_Discriminant (Elem); end loop; - -- Now we set the right field to Read_Only. and then we + -- Now we set the right field to Borrowed, and then we -- return the tree to the sons, so that the recursion can -- continue. declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); + Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get + (Component (C), Selected_Component); begin if Selected_C = null then @@ -5925,65 +4212,62 @@ package body Sem_SPARK is end if; pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := - Glb (Read_Only, Child_Perm); - + Selected_C.all.Tree.Permission := Borrowed; return Selected_C; end; end; + else raise Program_Error; end if; end; - -- We set the permission tree of its prefix, and then we extract from - -- the returned pointer the subtree and assign an adequate permission - -- to it, if unfolded. If folded, we unroll the tree at one step. + -- We set the permission tree of its prefix, and then we extract + -- from the returned pointer the subtree and assign an adequate + -- permission to it, if unfolded. If folded, we unroll the tree in + -- one step. when N_Indexed_Component | N_Slice => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (Prefix (N)); + Set_Perm_Prefixes_Borrow (Prefix (N)); begin if C = null then + -- We went through a function call, do nothing return null; end if; + pragma Assert (Permission (C) = Borrowed); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); if Kind (C) = Array_Component then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. pragma Assert (Get_Elem (C) /= null); - - C.all.Tree.Get_Elem.all.Tree.Permission := - Glb (Read_Only, Permission (Get_Elem (C))); - + C.all.Tree.Get_Elem.all.Tree.Permission := Borrowed; return Get_Elem (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace node with Array_Component. Son : Perm_Tree_Access; - Child_Perm : constant Perm_Kind := - Glb (Read_Only, Children_Permission (C)); - begin Son := new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (C), - Permission => Child_Perm, - Children_Permission => Child_Perm)); + Permission => Borrowed, + Children_Permission => Children_Permission (C))); -- We change the current node from Entire_Object -- to Array_Component with same permission and the @@ -5991,9 +4275,8 @@ package body Sem_SPARK is C.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (C), - Permission => Child_Perm, + Permission => Borrowed, Get_Elem => Son); - return Get_Elem (C); end; @@ -6002,64 +4285,64 @@ package body Sem_SPARK is end if; end; - -- We set the permission tree of its prefix, and then we extract from - -- the returned pointer the subtree and assign an adequate permission - -- to it, if unfolded. If folded, we unroll the tree at one step. + -- We set the permission tree of its prefix, and then we extract + -- from the returned pointer the subtree and assign an adequate + -- permission to it, if unfolded. If folded, we unroll the tree + -- at one step. when N_Explicit_Dereference => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (Prefix (N)); + Set_Perm_Prefixes_Borrow (Prefix (N)); begin if C = null then - -- We went through a function call, do nothing + + -- We went through a function call. Do nothing. return null; end if; + -- The permission of the returned node should be No + + pragma Assert (Permission (C) = Borrowed); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Reference); if Kind (C) = Reference then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. pragma Assert (Get_All (C) /= null); - - C.all.Tree.Get_All.all.Tree.Permission := - Glb (Read_Only, Permission (Get_All (C))); - + C.all.Tree.Get_All.all.Tree.Permission := Borrowed; return Get_All (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with Reference. Son : Perm_Tree_Access; - Child_Perm : constant Perm_Kind := - Glb (Read_Only, Children_Permission (C)); - begin Son := new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (N)), - Permission => Child_Perm, - Children_Permission => Child_Perm)); + Permission => Borrowed, + Children_Permission => Children_Permission (C))); -- We change the current node from Entire_Object to - -- Reference with Write_Only and the previous son. + -- Reference with Borrowed and the previous son. pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), - Permission => Child_Perm, + Permission => Borrowed, Get_All => Son); - return Get_All (C); end; + else raise Program_Error; end if; @@ -6070,16 +4353,14 @@ package body Sem_SPARK is when others => raise Program_Error; - end case; - end Set_Perm_Prefixes_Observe; + end Set_Perm_Prefixes_Borrow; ------------------- -- Setup_Globals -- ------------------- procedure Setup_Globals (Subp : Entity_Id) is - procedure Setup_Globals_From_List (First_Item : Node_Id; Kind : Formal_Kind); @@ -6123,12 +4404,17 @@ package body Sem_SPARK is begin case Global_Mode is - when Name_Input | Name_Proof_In => + when Name_Input + | Name_Proof_In + => Kind := E_In_Parameter; + when Name_Output => Kind := E_Out_Parameter; + when Name_In_Out => Kind := E_In_Out_Parameter; + when others => raise Program_Error; end case; @@ -6165,36 +4451,57 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Id)), - Permission => Read_Write, - Children_Permission => Read_Write)); + Permission => Unrestricted, + Children_Permission => Unrestricted)); case Mode is - when E_In_Parameter => - -- Borrowed IN: RW for everybody + -- All out and in out parameters are considered to be unrestricted. + -- They are whether borrowed or moved. Ada Rules would restrict + -- these permissions further. For example an in parameter cannot + -- be written. - if Is_Borrowed_In (Id) and not Global_Var then - Elem.all.Tree.Permission := Read_Write; - Elem.all.Tree.Children_Permission := Read_Write; + -- In the following we deal with in parameters that can be observed. + -- We only consider the observing cases. - -- Observed IN: R for everybody + when E_In_Parameter => - else - Elem.all.Tree.Permission := Read_Only; - Elem.all.Tree.Children_Permission := Read_Only; - end if; + -- Handling global variables as in parameters here + -- Remove the following condition once decided how globals + -- should be considered. + + if not Global_Var then + if (Is_Access_Type (Etype (Id)) + and then Is_Access_Constant (Etype (Id)) + and then Is_Anonymous_Access_Type (Etype (Id))) + or else + (not Is_Access_Type (Etype (Id)) + and then Is_Deep (Etype (Id)) + and then not Is_Anonymous_Access_Type (Etype (Id))) + then + Elem.all.Tree.Permission := Observed; + Elem.all.Tree.Children_Permission := Observed; - -- OUT: borrow, but callee has W only + else + Elem.all.Tree.Permission := Unrestricted; + Elem.all.Tree.Children_Permission := Unrestricted; + end if; - when E_Out_Parameter => - Elem.all.Tree.Permission := Write_Only; - Elem.all.Tree.Children_Permission := Write_Only; + else + Elem.all.Tree.Permission := Observed; + Elem.all.Tree.Children_Permission := Observed; + end if; - -- IN OUT: borrow and callee has RW + -- When out or in/out formal or global parameters, we set them to + -- the Unrestricted state. "We want to be able to assume that all + -- relevant writable globals are unrestricted when a subprogram + -- starts executing". Formal parameters of mode out or in/out + -- are whether Borrowers or the targets of a move operation: + -- they start theirs lives in the subprogram as Unrestricted. - when E_In_Out_Parameter => - Elem.all.Tree.Permission := Read_Write; - Elem.all.Tree.Children_Permission := Read_Write; + when others => + Elem.all.Tree.Permission := Unrestricted; + Elem.all.Tree.Children_Permission := Unrestricted; end case; Set (Current_Perm_Env, Id, Elem); @@ -6204,9 +4511,7 @@ package body Sem_SPARK is -- Setup_Parameters -- ---------------------- - procedure Setup_Parameters (Subp : Entity_Id) is - Formal : Entity_Id; - + procedure Setup_Parameters (Subp : Entity_Id) is Formal : Entity_Id; begin Formal := First_Formal (Subp); while Present (Formal) loop @@ -6216,4 +4521,85 @@ package body Sem_SPARK is end loop; end Setup_Parameters; + ------------------------------- + -- Has_Ownership_Aspect_True -- + ------------------------------- + + function Has_Ownership_Aspect_True + (N : Entity_Id; + Msg : String) + return Boolean + is + begin + case Ekind (Etype (N)) is + when Access_Kind => + if Ekind (Etype (N)) = E_General_Access_Type then + Error_Msg_NE (Msg & " & not allowed " & + "(Named General Access type)", N, N); + return False; + + else + return True; + end if; + + when E_Array_Type + | E_Array_Subtype + => + declare + Com_Ty : constant Node_Id := Component_Type (Etype (N)); + Ret : Boolean := Has_Ownership_Aspect_True (Com_Ty, ""); + + begin + if Nkind (Parent (N)) = N_Full_Type_Declaration and + Is_Anonymous_Access_Type (Com_Ty) + then + Ret := False; + end if; + + if not Ret then + Error_Msg_NE (Msg & " & not allowed " + & "(Components of Named General Access type or" + & " Anonymous type)", N, N); + end if; + return Ret; + end; + + -- ??? What about hidden components + + when E_Record_Type + | E_Record_Subtype + => + declare + Elmt : Entity_Id; + Elmt_T_Perm : Boolean := True; + Elmt_Perm, Elmt_Anonym : Boolean; + + begin + Elmt := First_Component_Or_Discriminant (Etype (N)); + while Present (Elmt) loop + Elmt_Perm := Has_Ownership_Aspect_True (Elmt, + "type of component"); + Elmt_Anonym := Is_Anonymous_Access_Type (Etype (Elmt)); + if Elmt_Anonym then + Error_Msg_NE + ("type of component & not allowed" + & " (Components of Anonymous type)", Elmt, Elmt); + end if; + Elmt_T_Perm := Elmt_T_Perm and Elmt_Perm and not Elmt_Anonym; + Next_Component_Or_Discriminant (Elmt); + end loop; + if not Elmt_T_Perm then + Error_Msg_NE + (Msg & " & not allowed (One or " + & "more components have Ownership Aspect False)", + N, N); + end if; + return Elmt_T_Perm; + end; + + when others => + return True; + end case; + + end Has_Ownership_Aspect_True; end Sem_SPARK; -- cgit v1.1 From 09825f923fadac7b79a894c4e7f6e0839c2837ac Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Tue, 21 Aug 2018 14:47:44 +0000 Subject: [Ada] Einfo: remove obsolete code 2018-08-21 Bob Duff gcc/ada * einfo.ads, einfo.adb (Private_View, Shadow_Entities): Remove obsolete code. From-SVN: r263728 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/einfo.adb | 40 ---------------------------------------- gcc/ada/einfo.ads | 35 ----------------------------------- 3 files changed, 5 insertions(+), 75 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f34ebbd..a89911a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-08-21 Bob Duff + + * einfo.ads, einfo.adb (Private_View, Shadow_Entities): Remove + obsolete code. + 2018-08-21 Maroua Maalej * sem_spark.adb (Check_Call_Statement): Check global and formal diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c9cdfc2..52a9435 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -118,7 +118,6 @@ package body Einfo is -- Alignment Uint14 -- Normalized_Position Uint14 -- Postconditions_Proc Node14 - -- Shadow_Entities List14 -- Discriminant_Number Uint15 -- DT_Position Uint15 @@ -199,7 +198,6 @@ package body Einfo is -- Corresponding_Remote_Type Node22 -- Enumeration_Rep_Expr Node22 -- Original_Record_Component Node22 - -- Private_View Node22 -- Protected_Formal Node22 -- Scope_Depth_Value Uint22 -- Shared_Var_Procs_Instance Node22 @@ -3126,12 +3124,6 @@ package body Einfo is return Elist18 (Id); end Private_Dependents; - function Private_View (Id : E) return N is - begin - pragma Assert (Is_Private_Type (Id)); - return Node22 (Id); - end Private_View; - function Protected_Body_Subprogram (Id : E) return E is begin pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); @@ -3314,12 +3306,6 @@ package body Einfo is return Flag167 (Id); end Sec_Stack_Needed_For_Return; - function Shadow_Entities (Id : E) return S is - begin - pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); - return List14 (Id); - end Shadow_Entities; - function Shared_Var_Procs_Instance (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Variable); @@ -6376,12 +6362,6 @@ package body Einfo is Set_Elist18 (Id, V); end Set_Private_Dependents; - procedure Set_Private_View (Id : E; V : N) is - begin - pragma Assert (Is_Private_Type (Id)); - Set_Node22 (Id, V); - end Set_Private_View; - procedure Set_Prev_Entity (Id : E; V : E) is begin Set_Node36 (Id, V); @@ -6573,12 +6553,6 @@ package body Einfo is Set_Flag167 (Id, V); end Set_Sec_Stack_Needed_For_Return; - procedure Set_Shadow_Entities (Id : E; V : S) is - begin - pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); - Set_List14 (Id, V); - end Set_Shadow_Entities; - procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); @@ -10405,11 +10379,6 @@ package body Einfo is => Write_Str ("Postconditions_Proc"); - when E_Generic_Package - | E_Package - => - Write_Str ("Shadow_Entities"); - when others => Write_Str ("Field14??"); end case; @@ -10845,15 +10814,6 @@ package body Einfo is when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Limited_Private_Subtype - | E_Limited_Private_Type - | E_Private_Subtype - | E_Private_Type - | E_Record_Subtype_With_Private - | E_Record_Type_With_Private - => - Write_Str ("Private_View"); - when Formal_Kind => Write_Str ("Protected_Formal"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index dbe1ad6..018684d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4005,17 +4005,6 @@ package Einfo is -- declaration of the type is seen. Subprograms that have such an -- access parameter are also placed in the list of private_dependents. --- Private_View (Node22) --- For each private type, three entities are allocated, the private view, --- the full view, and the shadow entity. The shadow entity contains a --- copy of the private view and is used for restoring the proper private --- view after a region in which the full view is visible (and is copied --- into the entity normally used for the private view during this period --- of visibility). The Private_View field is self-referential when the --- private view lives in its normal entity, but in the copy that is made --- in the shadow entity, it points to the proper location in which to --- restore the private view saved in the shadow. - -- Protected_Body_Subprogram (Node11) -- Defined in protected operations. References the entity for the -- subprogram which implements the body of the operation. @@ -4264,18 +4253,6 @@ package Einfo is -- returned value of a function and thus should not be released on scope -- exit. --- Shadow_Entities (List14) --- Defined in package and generic package entities. Points to a list --- of entities that correspond to private types. For each private type --- a shadow entity is created that holds a copy of the private view. --- In regions of the program where the full views of these private --- entities are visible, the full view is copied into the entity that --- is normally used to hold the private view, but the shadow entity --- copy is unchanged. The shadow entities are then used to restore the --- original private views at the end of the region. This list is a --- standard format list (i.e. First (Shadow_Entities) is the first --- entry and subsequent entries are obtained using Next. - -- Shared_Var_Procs_Instance (Node22) -- Defined in variables. Set non-Empty only if Is_Shared_Passive is -- set, in which case this is the entity for the associated instance of @@ -6323,7 +6300,6 @@ package Einfo is -- Underlying_Full_View (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Has_Completion (Flag26) -- (plus type attributes) @@ -6402,7 +6378,6 @@ package Einfo is -- Generic_Homonym (Node11) (generic case only) -- Associated_Formal_Package (Node12) -- Elaboration_Entity (Node13) - -- Shadow_Entities (List14) -- Related_Instance (Node15) (non-generic case only) -- First_Private_Entity (Node16) -- First_Entity (Node17) @@ -6480,7 +6455,6 @@ package Einfo is -- Underlying_Full_View (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Has_Completion (Flag26) -- Is_Controlled_Active (Flag42) (base type only) @@ -6661,7 +6635,6 @@ package Einfo is -- Underlying_Full_View (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Interfaces (Elist25) -- Predicated_Parent (Node38) (subtype only) @@ -7476,7 +7449,6 @@ package Einfo is function Prival (Id : E) return E; function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; - function Private_View (Id : E) return N; function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; function Protected_Subprogram (Id : E) return N; @@ -7509,7 +7481,6 @@ package Einfo is function Scale_Value (Id : E) return U; function Scope_Depth_Value (Id : E) return U; function Sec_Stack_Needed_For_Return (Id : E) return B; - function Shadow_Entities (Id : E) return S; function Shared_Var_Procs_Instance (Id : E) return E; function Size_Check_Code (Id : E) return N; function Size_Depends_On_Discriminant (Id : E) return B; @@ -8182,7 +8153,6 @@ package Einfo is procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); - procedure Set_Private_View (Id : E; V : N); procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); procedure Set_Protected_Subprogram (Id : E; V : N); @@ -8215,7 +8185,6 @@ package Einfo is procedure Set_Scale_Value (Id : E; V : U); procedure Set_Scope_Depth_Value (Id : E; V : U); procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); - procedure Set_Shadow_Entities (Id : E; V : S); procedure Set_Shared_Var_Procs_Instance (Id : E; V : E); procedure Set_Size_Check_Code (Id : E; V : N); procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); @@ -9059,7 +9028,6 @@ package Einfo is pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); - pragma Inline (Private_View); pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); pragma Inline (Protected_Subprogram); @@ -9093,7 +9061,6 @@ package Einfo is pragma Inline (Scale_Value); pragma Inline (Scope_Depth_Value); pragma Inline (Sec_Stack_Needed_For_Return); - pragma Inline (Shadow_Entities); pragma Inline (Shared_Var_Procs_Instance); pragma Inline (Size_Check_Code); pragma Inline (Size_Depends_On_Discriminant); @@ -9552,7 +9519,6 @@ package Einfo is pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); - pragma Inline (Set_Private_View); pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); pragma Inline (Set_Protected_Subprogram); @@ -9585,7 +9551,6 @@ package Einfo is pragma Inline (Set_Scale_Value); pragma Inline (Set_Scope_Depth_Value); pragma Inline (Set_Sec_Stack_Needed_For_Return); - pragma Inline (Set_Shadow_Entities); pragma Inline (Set_Shared_Var_Procs_Instance); pragma Inline (Set_Size_Check_Code); pragma Inline (Set_Size_Depends_On_Discriminant); -- cgit v1.1 From 6989a2bbfa259633296bf1e9f278ea83c5345811 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:47:50 +0000 Subject: [Ada] Fix scope computation for loop statements 2018-08-21 Ed Schonberg gcc/ada/ * sem_ch13.adb (Build_Predicate_Functioss): Apply Reset_Quantified_Variables_Scope after predicate function has been analyzed, so that the scope can be reset on the generated loop statements that have replaced the quantified expressions. From-SVN: r263729 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/sem_ch13.adb | 39 ++++++++++++++++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a89911a..48974e7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-08-21 Ed Schonberg + + * sem_ch13.adb (Build_Predicate_Functioss): Apply + Reset_Quantified_Variables_Scope after predicate function has + been analyzed, so that the scope can be reset on the generated + loop statements that have replaced the quantified expressions. + 2018-08-21 Bob Duff * einfo.ads, einfo.adb (Private_View, Shadow_Entities): Remove diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 28a3dd8..1a12622 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8754,7 +8754,6 @@ package body Sem_Ch13 is -- Case where predicates are present if Present (Expr) then - -- Test for raise expression present Test_REs (Expr); @@ -8856,6 +8855,42 @@ package body Sem_Ch13 is Insert_After_And_Analyze (N, FBody); + -- The defining identifier of a quantified expression carries the + -- scope in which the type appears, but when unnesting we need + -- to indicate that its proper scope is the constructed predicate + -- function. The quantified expressions have been converted into + -- loops during analysis and expansion. + + declare + function Reset_Quantified_Variable_Scope (N : Node_Id) + return Traverse_Result; + + procedure Reset_Quantified_Variables_Scope is + new Traverse_Proc (Reset_Quantified_Variable_Scope); + + ------------------------------------- + -- Reset_Quantified_Variable_Scope -- + ------------------------------------- + + function Reset_Quantified_Variable_Scope (N : Node_Id) + return Traverse_Result + is + begin + if Nkind_In (N, N_Iterator_Specification, + N_Loop_Parameter_Specification) + then + Set_Scope (Defining_Identifier (N), + Predicate_Function (Typ)); + end if; + return OK; + end Reset_Quantified_Variable_Scope; + + begin + if Unnest_Subprogram_Mode then + Reset_Quantified_Variables_Scope (Expr); + end if; + end; + -- within a generic unit, prevent a double analysis of the body -- which will not be marked analyzed yet. This will happen when -- the freeze node is created during the preanalysis of an @@ -8972,6 +9007,8 @@ package body Sem_Ch13 is Insert_Before_And_Analyze (N, FDecl); Insert_After_And_Analyze (N, FBody); + + -- Should quantified expressions be handled here as well ??? end; end if; -- cgit v1.1 From 5bb9ebcbc8270bcc08f955d196ad8c1bba003ec1 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:47:56 +0000 Subject: [Ada] Properly set scope of artificial entities in blocks 2018-08-21 Ed Schonberg gcc/ada/ * exp_ch9.adb (Expand_N_Timed_Entry_Call, Expand_Conditional_Entry_Call): Use Reset_Scopes_Of to set properly the scope of all entities created in blocks generated by the expansion of these constructs. From-SVN: r263730 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/exp_ch9.adb | 40 +++++++++++++++++++++++++++++----------- 2 files changed, 36 insertions(+), 11 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 48974e7..9804563 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,12 @@ 2018-08-21 Ed Schonberg + * exp_ch9.adb (Expand_N_Timed_Entry_Call, + Expand_Conditional_Entry_Call): Use Reset_Scopes_Of to set + properly the scope of all entities created in blocks generated + by the expansion of these constructs. + +2018-08-21 Ed Schonberg + * sem_ch13.adb (Build_Predicate_Functioss): Apply Reset_Quantified_Variables_Scope after predicate function has been analyzed, so that the scope can be reset on the generated diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d7e6663..c398948 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -476,10 +476,11 @@ package body Exp_Ch9 is -- ... -- := P.; - procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id); - -- Reset the scope of declarations and blocks at the top level of Proc_Body - -- to be E. Used after expanding entry bodies into their corresponding - -- procedures. This is needed during unnesting to determine whether a + procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); + -- Reset the scope of declarations and blocks at the top level of Bod + -- to be E. Bod is either a block or a subprogram body. Used after + -- expanding various kinds of entry bodies into their corresponding + -- constructs. This is needed during unnesting to determine whether a -- body geenrated for an entry or an accept alternative includes uplevel -- references. @@ -8240,6 +8241,7 @@ package body Exp_Ch9 is end if; Analyze (N); + Reset_Scopes_To (N, Entity (Identifier (N))); end Expand_N_Conditional_Entry_Call; --------------------------------------- @@ -12653,7 +12655,7 @@ package body Exp_Ch9 is Expression => D_Disc)); -- Do the assignment at this stage only because the evaluation of the - -- expression must not occur before (see ACVC C97302A). + -- expression must not occur earlier (see ACVC C97302A). Append_To (Stmts, Make_Assignment_Statement (Loc, @@ -12850,7 +12852,7 @@ package body Exp_Ch9 is end loop; -- Do the assignment at this stage only because the evaluation - -- of the expression must not occur before (see ACVC C97302A). + -- of the expression must not occur earlier (see ACVC C97302A). Insert_Before (Stmt, Make_Assignment_Statement (Loc, @@ -12935,6 +12937,21 @@ package body Exp_Ch9 is Make_Handled_Sequence_Of_Statements (Loc, Stmts))); Analyze (N); + + -- Some items in Decls used to be in the N_Block in E_Call that + -- is constructed in Expand_Entry_Call, and are now in the new + -- Block into which N has been rewritten. Adjust their scopes + -- to reflect that. + + if Nkind (E_Call) = N_Block_Statement then + Obj := First_Entity (Entity (Identifier (E_Call))); + while Present (Obj) loop + Set_Scope (Obj, Entity (Identifier (N))); + Next_Entity (Obj); + end loop; + end if; + + Reset_Scopes_To (N, Entity (Identifier (N))); end Expand_N_Timed_Entry_Call; ---------------------------------------- @@ -14832,7 +14849,7 @@ package body Exp_Ch9 is -- Reset_Scopes_To -- --------------------- - procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id) is + procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is function Reset_Scope (N : Node_Id) return Traverse_Result; -- Temporaries may have been declared during expansion of the procedure @@ -14853,7 +14870,8 @@ package body Exp_Ch9 is -- If this is a block statement with an Identifier, it forms a scope, -- so we want to reset its scope but not look inside. - if Nkind (N) = N_Block_Statement + if N /= Bod + and then Nkind (N) = N_Block_Statement and then Present (Identifier (N)) then Set_Scope (Entity (Identifier (N)), E); @@ -14868,7 +14886,7 @@ package body Exp_Ch9 is Set_Scope (Defining_Entity (N), E); return Skip; - elsif N = Proc_Body then + elsif N = Bod then -- Scan declarations in new body. Declarations in the statement -- part will be handled during later traversal. @@ -14879,7 +14897,7 @@ package body Exp_Ch9 is Next (Decl); end loop; - elsif N /= Proc_Body and then Nkind (N) in N_Proper_Body then + elsif N /= Bod and then Nkind (N) in N_Proper_Body then return Skip; end if; @@ -14889,7 +14907,7 @@ package body Exp_Ch9 is -- Start of processing for Reset_Scopes_To begin - Reset_Scopes (Proc_Body); + Reset_Scopes (Bod); end Reset_Scopes_To; ---------------------- -- cgit v1.1 From 24241bd0388ec6f730788540b289da12c13a34cc Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:48:03 +0000 Subject: [Ada] Spurious error on overriding protected function in instance The conformance between an overriding protected operation with progenitors and the overridden interface operation requires subtype conformance; requiring equality of return types in the case of a function is too restrictive and leads to spurious errors when the return type is a generic actual. 2018-08-21 Ed Schonberg gcc/ada/ * sem_ch6.adb (Check_Synchronized_Overriding): The conformance between an overriding protected operation and the overridden abstract progenitor operation requires subtype conformance; requiring equality of return types in the case of a function is too restrictive and leads to spurious errors when the return type is a generic actual. gcc/testsuite/ * gnat.dg/prot6.adb, gnat.dg/prot6.ads: New testcase. From-SVN: r263731 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/sem_ch6.adb | 4 +++- 2 files changed, 12 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9804563..ff886eb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,14 @@ 2018-08-21 Ed Schonberg + * sem_ch6.adb (Check_Synchronized_Overriding): The conformance + between an overriding protected operation and the overridden + abstract progenitor operation requires subtype conformance; + requiring equality of return types in the case of a function is + too restrictive and leads to spurious errors when the return + type is a generic actual. + +2018-08-21 Ed Schonberg + * exp_ch9.adb (Expand_N_Timed_Entry_Call, Expand_Conditional_Entry_Call): Use Reset_Scopes_Of to set properly the scope of all entities created in blocks generated diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2dd9d2f..2ddd3d3 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -7440,13 +7440,15 @@ package body Sem_Ch6 is end; -- Functions can override abstract interface functions + -- Return types must be subtype conformant. elsif Ekind (Def_Id) = E_Function and then Ekind (Subp) = E_Function and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), Parameter_Specifications (Parent (Subp))) - and then Etype (Def_Id) = Etype (Subp) + and then Conforming_Types (Etype (Def_Id), Etype (Subp), + Subtype_Conformant) then Candidate := Subp; -- cgit v1.1 From 322d87a9b17660f7d04a7320505591538582892a Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 21 Aug 2018 14:48:35 +0000 Subject: [Ada] Crash processing SPARK annotate aspect The compiler blows up writing the ALI file of a package that has a ghost subprogram with an annotate contract. 2018-08-21 Javier Miranda gcc/ada/ * lib-writ.adb (Write_Unit_Information): Handle pragmas removed by the expander. gcc/testsuite/ * gnat.dg/spark2.adb, gnat.dg/spark2.ads: New testcase. From-SVN: r263732 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/lib-writ.adb | 9 ++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ff886eb..1d21061 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-08-21 Javier Miranda + + * lib-writ.adb (Write_Unit_Information): Handle pragmas removed + by the expander. + 2018-08-21 Ed Schonberg * sem_ch6.adb (Check_Synchronized_Overriding): The conformance diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 9a54fa9..beb9489 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -744,7 +744,14 @@ package body Lib.Writ is Note_Unit := U; end if; - if Note_Unit = Unit_Num then + -- No action needed for pragmas removed by the expander (for + -- example, pragmas of ignored ghost entities). + + if Nkind (N) = N_Null_Statement then + pragma Assert (Nkind (Original_Node (N)) = N_Pragma); + null; + + elsif Note_Unit = Unit_Num then Write_Info_Initiate ('N'); Write_Info_Char (' '); -- cgit v1.1 From 5b1c45479aa2fd573063e370005f0c377e8b888e Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 21 Aug 2018 14:49:26 +0000 Subject: [Ada] Retention of with clauses for ignored Ghost units This patch ensures that with clauses that mention ignored Ghost units are retained in the tree. The retention is necessary for several reasons: * The with clauses allow the new elaboration order mechanism to produce the same library edges regardless of whether the Ghost unit is checked or ignored. This ensures that the elaboration order remains consistent. * The with clauses allow the unnesting mechanism to properly recognize that all units have been examined for unnesing purposes. No observable impact, no test needed. 2018-08-21 Hristian Kirtchev gcc/ada/ * sem_ch10.adb: Remove the with and use clause for unit Ghost. (Analyze_With_Clause): Do not mark a with clause which mentions an ignored Ghost code for elimination. From-SVN: r263733 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/sem_ch10.adb | 3 --- 2 files changed, 6 insertions(+), 3 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1d21061..373a648 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-08-21 Hristian Kirtchev + + * sem_ch10.adb: Remove the with and use clause for unit Ghost. + (Analyze_With_Clause): Do not mark a with clause which mentions + an ignored Ghost code for elimination. + 2018-08-21 Javier Miranda * lib-writ.adb (Write_Unit_Information): Handle pragmas removed diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 39ed046..e6d0ba5 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -34,7 +34,6 @@ with Elists; use Elists; with Fname; use Fname; with Fname.UF; use Fname.UF; with Freeze; use Freeze; -with Ghost; use Ghost; with Impunit; use Impunit; with Inline; use Inline; with Lib; use Lib; @@ -2912,8 +2911,6 @@ package body Sem_Ch10 is Set_Fatal_Error (Current_Sem_Unit, Error_Ignored); end if; end case; - - Mark_Ghost_Clause (N); end Analyze_With_Clause; ------------------------------ -- cgit v1.1 From 0db1c3863d5167dd47e5a0ab4a714ace875a9202 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:49:34 +0000 Subject: [Ada] Spurious crash on expression function as completion with contracts This patch fixes a compiler abort on an expression function that is a completion of a subprogram with preconditions. The problem is caused by the presence of types in the precondition that are not frozen when the subprogram body constructed for the expression function receives the code that enforces the precondition. These types must be frozen before the contract is expanded, so the freeze nodes for these types appear in the proper scope. This is analogous to what is done with type references that appear in the original expression of the expression function. 2018-08-21 Ed Schonberg gcc/ada/ * sem_ch6.adb: Remove Freeze_Expr_Types. * freeze.ads, freeze.adb (Freeze_Expr_Types): Moved from sem_ch6.adb, and extended to handle other expressions that may contain unfrozen types that must be frozen in their proper scopes. * contracts.adb (Analyze_Entry_Or_Subprogram_Contract): If the contract is for the generated body of an expression function that is a completion, traverse the expressions for pre- and postconditions to freeze all types before adding the contract code within the subprogram body. gcc/testsuite/ * gnat.dg/expr_func6.adb, gnat.dg/expr_func6.ads: New testcase. From-SVN: r263734 --- gcc/ada/ChangeLog | 13 ++++ gcc/ada/contracts.adb | 40 ++++++++-- gcc/ada/freeze.adb | 204 ++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/freeze.ads | 11 +++ gcc/ada/sem_ch6.adb | 204 +------------------------------------------------- 5 files changed, 263 insertions(+), 209 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 373a648..ca38083 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2018-08-21 Ed Schonberg + + * sem_ch6.adb: Remove Freeze_Expr_Types. + * freeze.ads, freeze.adb (Freeze_Expr_Types): Moved from + sem_ch6.adb, and extended to handle other expressions that may + contain unfrozen types that must be frozen in their proper + scopes. + * contracts.adb (Analyze_Entry_Or_Subprogram_Contract): If the + contract is for the generated body of an expression function + that is a completion, traverse the expressions for pre- and + postconditions to freeze all types before adding the contract + code within the subprogram body. + 2018-08-21 Hristian Kirtchev * sem_ch10.adb: Remove the with and use clause for unit Ghost. diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 5577604..e70765a 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -32,6 +32,7 @@ with Errout; use Errout; with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -47,6 +48,7 @@ with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; +with Stand; use Stand; with Stringt; use Stringt; with SCIL_LL; use SCIL_LL; with Tbuild; use Tbuild; @@ -589,14 +591,40 @@ package body Contracts is if Skip_Assert_Exprs then null; - -- Otherwise analyze the pre/postconditions + -- Otherwise analyze the pre/postconditions. Their expressions + -- might include references to types that are not frozen yet, + -- in the case where the body is a rewritten expression function + -- that is a completion, so freeze all types within before + -- constructing the contract code. else - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id); - Prag := Next_Pragma (Prag); - end loop; + declare + Bod : Node_Id; + Freeze_Types : Boolean := False; + begin + if Present (Freeze_Id) then + Bod := Unit_Declaration_Node (Freeze_Id); + if Nkind (Bod) = N_Subprogram_Body + and then Was_Expression_Function (Bod) + and then Ekind (Subp_Id) = E_Function + and then Chars (Subp_Id) = Chars (Freeze_Id) + and then Subp_Id /= Freeze_Id + then + Freeze_Types := True; + end if; + end if; + + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Freeze_Types then + Freeze_Expr_Types (Subp_Id, Standard_Boolean, + Expression (Corresponding_Aspect (Prag)), Bod); + end if; + + Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id); + Prag := Next_Pragma (Prag); + end loop; + end; end if; -- Analyze contract-cases and test-cases diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ea9454a..d7f3f58 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -49,6 +49,7 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; @@ -7643,6 +7644,209 @@ package body Freeze is In_Spec_Expression := In_Spec_Exp; end Freeze_Expression; + ----------------------- + -- Freeze_Expr_Types -- + ----------------------- + + procedure Freeze_Expr_Types + (Def_Id : Entity_Id; + Typ : Entity_Id; + Expr : Node_Id; + N : Node_Id) + is + + function Cloned_Expression return Node_Id; + -- Build a duplicate of the expression of the return statement that + -- has no defining entities shared with the original expression. + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; + -- Freeze all types referenced in the subtree rooted at Node + + ----------------------- + -- Cloned_Expression -- + ----------------------- + + function Cloned_Expression return Node_Id is + function Clone_Id (Node : Node_Id) return Traverse_Result; + -- Tree traversal routine that clones the defining identifier of + -- iterator and loop parameter specification nodes. + + -------------- + -- Clone_Id -- + -------------- + + function Clone_Id (Node : Node_Id) return Traverse_Result is + begin + if Nkind_In (Node, N_Iterator_Specification, + N_Loop_Parameter_Specification) + then + Set_Defining_Identifier (Node, + New_Copy (Defining_Identifier (Node))); + end if; + + return OK; + end Clone_Id; + + procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); + + -- Local variable + + Dup_Expr : constant Node_Id := New_Copy_Tree (Expr); + + -- Start of processing for Cloned_Expression + + begin + -- We must duplicate the expression with semantic information to + -- inherit the decoration of global entities in generic instances. + -- Set the parent of the new node to be the parent of the original + -- to get the proper context, which is needed for complete error + -- reporting and for semantic analysis. + + Set_Parent (Dup_Expr, Parent (Expr)); + + -- Replace the defining identifier of iterators and loop param + -- specifications by a clone to ensure that the cloned expression + -- and the original expression don't have shared identifiers; + -- otherwise, as part of the preanalysis of the expression, these + -- shared identifiers may be left decorated with itypes which + -- will not be available in the tree passed to the backend. + + Clone_Def_Ids (Dup_Expr); + + return Dup_Expr; + end Cloned_Expression; + + ---------------------- + -- Freeze_Type_Refs -- + ---------------------- + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is + procedure Check_And_Freeze_Type (Typ : Entity_Id); + -- Check that Typ is fully declared and freeze it if so + + --------------------------- + -- Check_And_Freeze_Type -- + --------------------------- + + procedure Check_And_Freeze_Type (Typ : Entity_Id) is + begin + -- Skip Itypes created by the preanalysis, and itypes whose + -- scope is another type (i.e. component subtypes that depend + -- on a discriminant), + + if Is_Itype (Typ) + and then (Scope_Within_Or_Same (Scope (Typ), Def_Id) + or else Is_Type (Scope (Typ))) + then + return; + end if; + + -- This provides a better error message than generating + -- primitives whose compilation fails much later. Refine + -- the error message if possible. + + Check_Fully_Declared (Typ, Node); + + if Error_Posted (Node) then + if Has_Private_Component (Typ) + and then not Is_Private_Type (Typ) + then + Error_Msg_NE ("\type& has private component", Node, Typ); + end if; + + else + Freeze_Before (N, Typ); + end if; + end Check_And_Freeze_Type; + + -- Start of processing for Freeze_Type_Refs + + begin + -- Check that a type referenced by an entity can be frozen + + if Is_Entity_Name (Node) and then Present (Entity (Node)) then + Check_And_Freeze_Type (Etype (Entity (Node))); + + -- Check that the enclosing record type can be frozen + + if Ekind_In (Entity (Node), E_Component, E_Discriminant) then + Check_And_Freeze_Type (Scope (Entity (Node))); + end if; + + -- Freezing an access type does not freeze the designated type, + -- but freezing conversions between access to interfaces requires + -- that the interface types themselves be frozen, so that dispatch + -- table entities are properly created. + + -- Unclear whether a more general rule is needed ??? + + elsif Nkind (Node) = N_Type_Conversion + and then Is_Access_Type (Etype (Node)) + and then Is_Interface (Designated_Type (Etype (Node))) + then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); + end if; + + -- An implicit dereference freezes the designated type. In the + -- case of a dispatching call whose controlling argument is an + -- access type, the dereference is not made explicit, so we must + -- check for such a call and freeze the designated type. + + if Nkind (Node) in N_Has_Etype + and then Present (Etype (Node)) + and then Is_Access_Type (Etype (Node)) + and then Nkind (Parent (Node)) = N_Function_Call + and then Node = Controlling_Argument (Parent (Node)) + then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); + end if; + + -- No point in posting several errors on the same expression + + if Serious_Errors_Detected > 0 then + return Abandon; + else + return OK; + end if; + end Freeze_Type_Refs; + + procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); + + -- Local variables + + Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); + Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); + Dup_Expr : constant Node_Id := Cloned_Expression; + + -- Start of processing for Freeze_Expr_Types + + begin + -- Preanalyze a duplicate of the expression to have available the + -- minimum decoration needed to locate referenced unfrozen types + -- without adding any decoration to the function expression. + + Push_Scope (Def_Id); + Install_Formals (Def_Id); + + Preanalyze_Spec_Expression (Dup_Expr, Typ); + End_Scope; + + -- Restore certain attributes of Def_Id since the preanalysis may + -- have introduced itypes to this scope, thus modifying attributes + -- First_Entity and Last_Entity. + + Set_First_Entity (Def_Id, Saved_First_Entity); + Set_Last_Entity (Def_Id, Saved_Last_Entity); + + if Present (Last_Entity (Def_Id)) then + Set_Next_Entity (Last_Entity (Def_Id), Empty); + end if; + + -- Freeze all types referenced in the expression + + Freeze_References (Dup_Expr); + end Freeze_Expr_Types; + ----------------------------- -- Freeze_Fixed_Point_Type -- ----------------------------- diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 20badd0..96b3c90 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -230,6 +230,17 @@ package Freeze is -- so need to be similarly treated. Freeze_Expression takes care of -- determining the proper insertion point for generated freeze actions. + procedure Freeze_Expr_Types + (Def_Id : Entity_Id; + Typ : Entity_Id; + Expr : Node_Id; + N : Node_Id); + -- N is the body constructed for an expression function that is a + -- completion, and Def_Id is the function being completed. + -- This procedure freezes before N all the types referenced in Expr, + -- which is either the expression of the expression function, or + -- the expression in a pre/post aspect that applies to Def_Id; + procedure Freeze_Fixed_Point_Type (Typ : Entity_Id); -- Freeze fixed point type. For fixed-point types, we have to defer -- setting the size and bounds till the freeze point, since they are diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2ddd3d3..5548c81 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -285,208 +285,6 @@ package body Sem_Ch6 is LocX : constant Source_Ptr := Sloc (Expr); Spec : constant Node_Id := Specification (N); - procedure Freeze_Expr_Types (Def_Id : Entity_Id); - -- N is an expression function that is a completion and Def_Id its - -- defining entity. Freeze before N all the types referenced by the - -- expression of the function. - - ----------------------- - -- Freeze_Expr_Types -- - ----------------------- - - procedure Freeze_Expr_Types (Def_Id : Entity_Id) is - function Cloned_Expression return Node_Id; - -- Build a duplicate of the expression of the return statement that - -- has no defining entities shared with the original expression. - - function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; - -- Freeze all types referenced in the subtree rooted at Node - - ----------------------- - -- Cloned_Expression -- - ----------------------- - - function Cloned_Expression return Node_Id is - function Clone_Id (Node : Node_Id) return Traverse_Result; - -- Tree traversal routine that clones the defining identifier of - -- iterator and loop parameter specification nodes. - - -------------- - -- Clone_Id -- - -------------- - - function Clone_Id (Node : Node_Id) return Traverse_Result is - begin - if Nkind_In (Node, N_Iterator_Specification, - N_Loop_Parameter_Specification) - then - Set_Defining_Identifier (Node, - New_Copy (Defining_Identifier (Node))); - end if; - - return OK; - end Clone_Id; - - procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); - - -- Local variable - - Dup_Expr : constant Node_Id := New_Copy_Tree (Expr); - - -- Start of processing for Cloned_Expression - - begin - -- We must duplicate the expression with semantic information to - -- inherit the decoration of global entities in generic instances. - -- Set the parent of the new node to be the parent of the original - -- to get the proper context, which is needed for complete error - -- reporting and for semantic analysis. - - Set_Parent (Dup_Expr, Parent (Expr)); - - -- Replace the defining identifier of iterators and loop param - -- specifications by a clone to ensure that the cloned expression - -- and the original expression don't have shared identifiers; - -- otherwise, as part of the preanalysis of the expression, these - -- shared identifiers may be left decorated with itypes which - -- will not be available in the tree passed to the backend. - - Clone_Def_Ids (Dup_Expr); - - return Dup_Expr; - end Cloned_Expression; - - ---------------------- - -- Freeze_Type_Refs -- - ---------------------- - - function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is - procedure Check_And_Freeze_Type (Typ : Entity_Id); - -- Check that Typ is fully declared and freeze it if so - - --------------------------- - -- Check_And_Freeze_Type -- - --------------------------- - - procedure Check_And_Freeze_Type (Typ : Entity_Id) is - begin - -- Skip Itypes created by the preanalysis, and itypes whose - -- scope is another type (i.e. component subtypes that depend - -- on a discriminant), - - if Is_Itype (Typ) - and then (Scope_Within_Or_Same (Scope (Typ), Def_Id) - or else Is_Type (Scope (Typ))) - then - return; - end if; - - -- This provides a better error message than generating - -- primitives whose compilation fails much later. Refine - -- the error message if possible. - - Check_Fully_Declared (Typ, Node); - - if Error_Posted (Node) then - if Has_Private_Component (Typ) - and then not Is_Private_Type (Typ) - then - Error_Msg_NE ("\type& has private component", Node, Typ); - end if; - - else - Freeze_Before (N, Typ); - end if; - end Check_And_Freeze_Type; - - -- Start of processing for Freeze_Type_Refs - - begin - -- Check that a type referenced by an entity can be frozen - - if Is_Entity_Name (Node) and then Present (Entity (Node)) then - Check_And_Freeze_Type (Etype (Entity (Node))); - - -- Check that the enclosing record type can be frozen - - if Ekind_In (Entity (Node), E_Component, E_Discriminant) then - Check_And_Freeze_Type (Scope (Entity (Node))); - end if; - - -- Freezing an access type does not freeze the designated type, - -- but freezing conversions between access to interfaces requires - -- that the interface types themselves be frozen, so that dispatch - -- table entities are properly created. - - -- Unclear whether a more general rule is needed ??? - - elsif Nkind (Node) = N_Type_Conversion - and then Is_Access_Type (Etype (Node)) - and then Is_Interface (Designated_Type (Etype (Node))) - then - Check_And_Freeze_Type (Designated_Type (Etype (Node))); - end if; - - -- An implicit dereference freezes the designated type. In the - -- case of a dispatching call whose controlling argument is an - -- access type, the dereference is not made explicit, so we must - -- check for such a call and freeze the designated type. - - if Nkind (Node) in N_Has_Etype - and then Present (Etype (Node)) - and then Is_Access_Type (Etype (Node)) - and then Nkind (Parent (Node)) = N_Function_Call - and then Node = Controlling_Argument (Parent (Node)) - then - Check_And_Freeze_Type (Designated_Type (Etype (Node))); - end if; - - -- No point in posting several errors on the same expression - - if Serious_Errors_Detected > 0 then - return Abandon; - else - return OK; - end if; - end Freeze_Type_Refs; - - procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); - - -- Local variables - - Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); - Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); - Dup_Expr : constant Node_Id := Cloned_Expression; - - -- Start of processing for Freeze_Expr_Types - - begin - -- Preanalyze a duplicate of the expression to have available the - -- minimum decoration needed to locate referenced unfrozen types - -- without adding any decoration to the function expression. - - Push_Scope (Def_Id); - Install_Formals (Def_Id); - - Preanalyze_Spec_Expression (Dup_Expr, Etype (Def_Id)); - End_Scope; - - -- Restore certain attributes of Def_Id since the preanalysis may - -- have introduced itypes to this scope, thus modifying attributes - -- First_Entity and Last_Entity. - - Set_First_Entity (Def_Id, Saved_First_Entity); - Set_Last_Entity (Def_Id, Saved_Last_Entity); - - if Present (Last_Entity (Def_Id)) then - Set_Next_Entity (Last_Entity (Def_Id), Empty); - end if; - - -- Freeze all types referenced in the expression - - Freeze_References (Dup_Expr); - end Freeze_Expr_Types; - -- Local variables Asp : Node_Id; @@ -600,7 +398,7 @@ package body Sem_Ch6 is -- As elsewhere, we do not emit freeze nodes within a generic unit. if not Inside_A_Generic then - Freeze_Expr_Types (Def_Id); + Freeze_Expr_Types (Def_Id, Etype (Def_Id), Expr, N); end if; -- For navigation purposes, indicate that the function is a body -- cgit v1.1 From 084e3bd183b1b7253f1216b5b165bde7bfbf6bf6 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:49:42 +0000 Subject: [Ada] Crash on expression function and tagged types This patch fixes a compiler abort on an expression function whose expression includes tagged types that have not been frozen before the generated body of the function is analyzed, even though that body is inserted at the end of the current declarative part. 2018-08-21 Ed Schonberg gcc/ada/ * sem_ch6.adb (Analyze_Subprogram_Body_Helper, Mask_Type): Refine the handling of freezing types for expression functions that are not completions, when analyzing the generated body for the function: the body is inserted at the end of the enclosing declarative part, and its analysis may freeze types declared in the same scope that have not been frozen yet. gcc/testsuite/ * gnat.dg/expr_func7.adb, gnat.dg/expr_func7.ads: New testcase. From-SVN: r263735 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/sem_ch6.adb | 36 ++++++++++++++++++++---------------- 2 files changed, 29 insertions(+), 16 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ca38083..503aa06 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,14 @@ 2018-08-21 Ed Schonberg + * sem_ch6.adb (Analyze_Subprogram_Body_Helper, Mask_Type): + Refine the handling of freezing types for expression functions + that are not completions, when analyzing the generated body for + the function: the body is inserted at the end of the enclosing + declarative part, and its analysis may freeze types declared in + the same scope that have not been frozen yet. + +2018-08-21 Ed Schonberg + * sem_ch6.adb: Remove Freeze_Expr_Types. * freeze.ads, freeze.adb (Freeze_Expr_Types): Moved from sem_ch6.adb, and extended to handle other expressions that may diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5548c81..3e0cae1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3145,8 +3145,12 @@ package body Sem_Ch6 is end if; if not Is_Frozen (Typ) then - Set_Is_Frozen (Typ); - Append_New_Elmt (Typ, Result); + if Scope (Typ) /= Current_Scope then + Set_Is_Frozen (Typ); + Append_New_Elmt (Typ, Result); + else + Freeze_Before (N, Typ); + end if; end if; end Mask_Type; @@ -3636,28 +3640,28 @@ package body Sem_Ch6 is -- They are necessary in any case to insure order of elaboration -- in gigi. - if not Is_Frozen (Spec_Id) + if Nkind (N) = N_Subprogram_Body + and then Was_Expression_Function (N) + and then not Has_Completion (Spec_Id) + and then Serious_Errors_Detected = 0 and then (Expander_Active or else ASIS_Mode - or else (Operating_Mode = Check_Semantics - and then Serious_Errors_Detected = 0)) + or else Operating_Mode = Check_Semantics) then -- The body generated for an expression function that is not a -- completion is a freeze point neither for the profile nor for -- anything else. That's why, in order to prevent any freezing -- during analysis, we need to mask types declared outside the - -- expression that are not yet frozen. + -- expression (and in an outer scope) that are not yet frozen. - if Nkind (N) = N_Subprogram_Body - and then Was_Expression_Function (N) - and then not Has_Completion (Spec_Id) - then - Set_Is_Frozen (Spec_Id); - Mask_Types := Mask_Unfrozen_Types (Spec_Id); - else - Set_Has_Delayed_Freeze (Spec_Id); - Freeze_Before (N, Spec_Id); - end if; + Set_Is_Frozen (Spec_Id); + Mask_Types := Mask_Unfrozen_Types (Spec_Id); + + elsif not Is_Frozen (Spec_Id) + and then Serious_Errors_Detected = 0 + then + Set_Has_Delayed_Freeze (Spec_Id); + Freeze_Before (N, Spec_Id); end if; end if; -- cgit v1.1 From 5ec8edb56ea77f8627b6fc7b9f95751d27cd9162 Mon Sep 17 00:00:00 2001 From: Jerome Lambourg Date: Tue, 21 Aug 2018 14:49:49 +0000 Subject: [Ada] Add a new gnat tool vxlink VxLink is a helper tool used as a wrapper around g++/gcc to build VxWorks DKM (Downloadable Kernel Modules). Such DKM is a partially linked object that includes entry points for constructors and destructors. This tool thus uses g++ to generate an intermediate partially linked object, retrieves the list of constructors and destructors in it and produces a C file that lists those ctors/dtors in a way that is understood be VxWorks kernel. It then links this file with the intermediate object to produce a valid DKM. 2018-08-21 Jerome Lambourg gcc/ada/ * vxlink-bind.adb, vxlink-bind.ads, vxlink-link.adb, vxlink-link.ads, vxlink-main.adb, vxlink.adb, vxlink.ads: Add a new tool vxlink to handle VxWorks constructors in DKMs. * gcc-interface/Makefile.in: add rules to build vxlink From-SVN: r263736 --- gcc/ada/ChangeLog | 7 + gcc/ada/gcc-interface/Makefile.in | 11 ++ gcc/ada/vxlink-bind.adb | 390 ++++++++++++++++++++++++++++++++++++++ gcc/ada/vxlink-bind.ads | 87 +++++++++ gcc/ada/vxlink-link.adb | 194 +++++++++++++++++++ gcc/ada/vxlink-link.ads | 63 ++++++ gcc/ada/vxlink-main.adb | 81 ++++++++ gcc/ada/vxlink.adb | 288 ++++++++++++++++++++++++++++ gcc/ada/vxlink.ads | 68 +++++++ 9 files changed, 1189 insertions(+) create mode 100644 gcc/ada/vxlink-bind.adb create mode 100644 gcc/ada/vxlink-bind.ads create mode 100644 gcc/ada/vxlink-link.adb create mode 100644 gcc/ada/vxlink-link.ads create mode 100644 gcc/ada/vxlink-main.adb create mode 100644 gcc/ada/vxlink.adb create mode 100644 gcc/ada/vxlink.ads (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 503aa06..8d0da5a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-08-21 Jerome Lambourg + + * vxlink-bind.adb, vxlink-bind.ads, vxlink-link.adb, + vxlink-link.ads, vxlink-main.adb, vxlink.adb, vxlink.ads: Add a + new tool vxlink to handle VxWorks constructors in DKMs. + * gcc-interface/Makefile.in: add rules to build vxlink + 2018-08-21 Ed Schonberg * sem_ch6.adb (Analyze_Subprogram_Body_Helper, Mask_Type): diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9a52e6d..4d870c2 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -441,6 +441,11 @@ ifeq ($(ENABLE_VXADDR2LINE),true) TOOLSCASE=cross top_buildir=../../.. \ ../../vxaddr2line$(exeext) endif +ifeq ($(ENABLE_VXLINK),true) + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=cross top_build=../../.. \ + ../../vxlink$(exeext) +endif common-tools: ../stamp-tools $(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \ @@ -478,6 +483,12 @@ common-tools: ../stamp-tools $(GNATLINK) -v vxaddr2line -o $@ \ --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" ../targext.o $(CLIB) +../../vxlink$(exeext): ../stamp-tools + $(GNATMAKE) -c $(ADA_INCLUDES) vxlink-main --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxlink-main + $(GNATLINK) -v vxlink-main -o $@ \ + --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" + gnatmake-re: ../stamp-tools $(GNATMAKE) -j0 $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" $(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" diff --git a/gcc/ada/vxlink-bind.adb b/gcc/ada/vxlink-bind.adb new file mode 100644 index 0000000..9f45694 --- /dev/null +++ b/gcc/ada/vxlink-bind.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . B I N D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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 Ada_2012; + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.IO_Exceptions; +with Ada.Strings.Fixed; + +with GNAT.Regpat; use GNAT.Regpat; + +package body VxLink.Bind is + + function Split_Lines (S : String) return Strings_List.Vector; + + function Split (S : String; C : Character) return Strings_List.Vector; + + function Parse_Nm_Output (S : String) return Symbol_Sets.Set; + + procedure Emit_Module_Dtor + (FP : File_Type); + + procedure Emit_CDtor + (FP : File_Type; + Var : String; + Set : Symbol_Sets.Set); + + ----------------- + -- Split_Lines -- + ----------------- + + function Split_Lines (S : String) return Strings_List.Vector + is + Last : Natural := S'First; + Ret : Strings_List.Vector; + begin + for J in S'Range loop + if S (J) = ASCII.CR + and then J < S'Last + and then S (J + 1) = ASCII.LF + then + Ret.Append (S (Last .. J - 1)); + Last := J + 2; + elsif S (J) = ASCII.LF then + Ret.Append (S (Last .. J - 1)); + Last := J + 1; + end if; + end loop; + + if Last <= S'Last then + Ret.Append (S (Last .. S'Last)); + end if; + + return Ret; + end Split_Lines; + + ----------- + -- Split -- + ----------- + + function Split (S : String; C : Character) return Strings_List.Vector + is + Last : Natural := S'First; + Ret : Strings_List.Vector; + begin + for J in S'Range loop + if S (J) = C then + if J > Last then + Ret.Append (S (Last .. J - 1)); + end if; + + Last := J + 1; + end if; + end loop; + + if Last <= S'Last then + Ret.Append (S (Last .. S'Last)); + end if; + + return Ret; + end Split; + + --------------------- + -- Parse_Nm_Output -- + --------------------- + + function Parse_Nm_Output (S : String) return Symbol_Sets.Set + is + Nm_Regexp : constant Pattern_Matcher := + Compile ("^[0-9A-Za-z]* ([a-zA-Z]) (.*)$"); + type CDTor_Type is + (CTOR_Diab, + CTOR_Gcc, + DTOR_Diab, + DTOR_Gcc); + subtype CTOR_Type is CDTor_Type range CTOR_Diab .. CTOR_Gcc; + CTOR_DIAB_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?STI__*([0-9]+)_"); + CTOR_GCC_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?GLOBAL_.I._*([0-9]+)_"); + DTOR_DIAB_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?STD__*([0-9]+)_"); + DTOR_GCC_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?GLOBAL_.D._*([0-9]+)_"); + type Regexp_Access is access constant Pattern_Matcher; + CDTor_Regexps : constant array (CDTor_Type) of Regexp_Access := + (CTOR_Diab => CTOR_DIAB_Regexp'Access, + CTOR_Gcc => CTOR_GCC_Regexp'Access, + DTOR_Diab => DTOR_DIAB_Regexp'Access, + DTOR_Gcc => DTOR_GCC_Regexp'Access); + Result : Symbol_Sets.Set; + + begin + for Line of Split_Lines (S) loop + declare + Sym : Symbol; + Nm_Grps : Match_Array (0 .. 2); + Ctor_Grps : Match_Array (0 .. 1); + begin + Match (Nm_Regexp, Line, Nm_Grps); + + if Nm_Grps (0) /= No_Match then + declare + Sym_Type : constant Character := + Line (Nm_Grps (1).First); + Sym_Name : constant String := + Line (Nm_Grps (2).First .. Nm_Grps (2).Last); + begin + Sym := + (Name => To_Unbounded_String (Sym_Name), + Cat => Sym_Type, + Internal => False, + Kind => Sym_Other, + Priority => -1); + + for J in CDTor_Regexps'Range loop + Match (CDTor_Regexps (J).all, Sym_Name, Ctor_Grps); + + if Ctor_Grps (0) /= No_Match then + if J in CTOR_Type then + Sym.Kind := Sym_Ctor; + else + Sym.Kind := Sym_Dtor; + end if; + + Sym.Priority := Integer'Value + (Line (Ctor_Grps (1).First .. Ctor_Grps (1).Last)); + + exit; + end if; + end loop; + + Result.Include (Sym); + end; + end if; + end; + end loop; + + return Result; + end Parse_Nm_Output; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Binder : out VxLink_Binder; + Object_File : String) + is + Args : Arguments_List; + Module_Dtor_Not_Needed : Boolean := False; + Module_Dtor_Needed : Boolean := False; + + begin + Args.Append (Nm); + Args.Append (Object_File); + + declare + Output : constant String := Run (Args); + Symbols : Symbol_Sets.Set; + begin + if Is_Error_State then + return; + end if; + + Symbols := Parse_Nm_Output (Output); + + for Sym of Symbols loop + if Sym.Kind = Sym_Ctor then + Binder.Constructors.Insert (Sym); + elsif Sym.Kind = Sym_Dtor then + Binder.Destructors.Insert (Sym); + elsif Match ("_?__.*_atexit$", To_String (Sym.Name)) then + if Sym.Cat = 'T' then + Module_Dtor_Not_Needed := True; + elsif Sym.Cat = 'U' then + Module_Dtor_Needed := True; + end if; + end if; + end loop; + + Binder.Module_Dtor_Needed := + not Module_Dtor_Not_Needed and then Module_Dtor_Needed; + end; + end Initialize; + + -------------------- + -- Parse_Tag_File -- + -------------------- + + procedure Parse_Tag_File + (Binder : in out VxLink_Binder; + File : String) + is + FP : Ada.Text_IO.File_Type; + + begin + Open + (FP, + Mode => In_File, + Name => File); + loop + declare + Line : constant String := + Ada.Strings.Fixed.Trim + (Get_Line (FP), Ada.Strings.Both); + Tokens : Strings_List.Vector; + + begin + if Line'Length = 0 then + -- Skip empty lines + null; + + elsif Line (Line'First) = '#' then + -- Skip comment + null; + + else + Tokens := Split (Line, ' '); + if Tokens.First_Element = "section" then + -- Sections are not used for tags, only when building + -- kernels. So skip for now + null; + else + Binder.Tags_List.Append (Line); + end if; + end if; + end; + end loop; + + exception + when Ada.IO_Exceptions.End_Error => + Close (FP); + when others => + Log_Error ("Cannot open file " & File & + ". DKM tags won't be generated"); + end Parse_Tag_File; + + ---------------------- + -- Emit_Module_Dtor -- + ---------------------- + + procedure Emit_Module_Dtor + (FP : File_Type) + is + Dtor_Name : constant String := "_GLOBAL__D_65536_0_cxa_finalize"; + begin + Put_Line (FP, "extern void __cxa_finalize(void *);"); + Put_Line (FP, "static void " & Dtor_Name & "()"); + Put_Line (FP, "{"); + Put_Line (FP, " __cxa_finalize(&__dso_handle);"); + Put_Line (FP, "}"); + Put_Line (FP, ""); + end Emit_Module_Dtor; + + ---------------- + -- Emit_CDtor -- + ---------------- + + procedure Emit_CDtor + (FP : File_Type; + Var : String; + Set : Symbol_Sets.Set) + is + begin + for Sym of Set loop + if not Sym.Internal then + Put_Line (FP, "extern void " & To_String (Sym.Name) & "();"); + end if; + end loop; + + New_Line (FP); + + Put_Line (FP, "extern void (*" & Var & "[])();"); + Put_Line (FP, "void (*" & Var & "[])() ="); + Put_Line (FP, " {"); + for Sym of Set loop + Put_Line (FP, " " & To_String (Sym.Name) & ","); + end loop; + Put_Line (FP, " 0};"); + New_Line (FP); + end Emit_CDtor; + + --------------- + -- Emit_CTDT -- + --------------- + + procedure Emit_CTDT + (Binder : in out VxLink_Binder; + Namespace : String) + is + FP : Ada.Text_IO.File_Type; + CDtor_File : constant String := Namespace & "-cdtor.c"; + begin + Binder.CTDT_File := To_Unbounded_String (CDtor_File); + Create + (File => FP, + Name => CDtor_File); + Put_Line (FP, "#if defined(_HAVE_TOOL_XTORS)"); + Put_Line (FP, "#include "); + if Binder.Module_Dtor_Needed then + Put_Line (FP, "#define _WRS_NEED_CALL_CXA_FINALIZE"); + end if; + Put_Line (FP, "#include TOOL_HEADER (toolXtors.h)"); + Put_Line (FP, "#else"); + Put_Line (FP, ""); + + if Binder.Module_Dtor_Needed then + Emit_Module_Dtor (FP); + end if; + + Emit_CDtor (FP, "_ctors", Binder.Constructors); + Emit_CDtor (FP, "_dtors", Binder.Destructors); + + Put_Line (FP, "#endif"); + + if not Binder.Tags_List.Is_Empty then + New_Line (FP); + Put_Line (FP, "/* build variables */"); + Put_Line (FP, "__asm("" .section \"".wrs_build_vars\"",\""a\"""");"); + for Tag of Binder.Tags_List loop + Put_Line (FP, "__asm("" .ascii \""" & Tag & "\"""");"); + Put_Line (FP, "__asm("" .byte 0"");"); + end loop; + Put_Line (FP, "__asm("" .ascii \""end\"""");"); + Put_Line (FP, "__asm("" .byte 0"");"); + end if; + + Close (FP); + + exception + when others => + Close (FP); + Set_Error_State ("Internal error"); + raise; + end Emit_CTDT; + + --------------- + -- CTDT_File -- + --------------- + + function CTDT_File (Binder : VxLink_Binder) return String + is + begin + return To_String (Binder.CTDT_File); + end CTDT_File; + +end VxLink.Bind; diff --git a/gcc/ada/vxlink-bind.ads b/gcc/ada/vxlink-bind.ads new file mode 100644 index 0000000..7e6a1b0 --- /dev/null +++ b/gcc/ada/vxlink-bind.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . B I N D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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 Ada_2012; + +private with Ada.Containers.Ordered_Sets; +private with Ada.Strings.Unbounded; + +package VxLink.Bind is + + type VxLink_Binder is private; + + procedure Initialize + (Binder : out VxLink_Binder; + Object_File : String); + + procedure Parse_Tag_File + (Binder : in out VxLink_Binder; + File : String); + + procedure Emit_CTDT + (Binder : in out VxLink_Binder; + Namespace : String); + + function CTDT_File (Binder : VxLink_Binder) return String; + +private + + use Ada.Strings.Unbounded; + + type Symbol_Kind is (Sym_Ctor, Sym_Dtor, Sym_Other); + + type Symbol is record + Name : Unbounded_String; + Cat : Character; + Internal : Boolean; + Kind : Symbol_Kind; + Priority : Integer; + end record; + + function "=" (S1, S2 : Symbol) return Boolean + is (S1.Name = S2.Name and then S1.Cat = S2.Cat); + + function "<" (S1, S2 : Symbol) return Boolean + is (if S1.Priority /= S2.Priority + then S1.Priority < S2.Priority + elsif S1.Name /= S2.Name + then S1.Name < S2.Name + else S1.Cat < S2.Cat); + + package Symbol_Sets is new Ada.Containers.Ordered_Sets + (Symbol, + "<" => "<", + "=" => "="); + + type VxLink_Binder is record + CTDT_File : Unbounded_String; + Constructors : Symbol_Sets.Set; + Destructors : Symbol_Sets.Set; + Module_Dtor_Needed : Boolean; + EH_Frame_Needed : Boolean; + Tags_List : Strings_List.Vector; + end record; + +end VxLink.Bind; diff --git a/gcc/ada/vxlink-link.adb b/gcc/ada/vxlink-link.adb new file mode 100644 index 0000000..5211074 --- /dev/null +++ b/gcc/ada/vxlink-link.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . L I N K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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 Ada_2012; + +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +package body VxLink.Link is + + Gcc : constant String := VxLink.Gcc; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Linker : out VxLink_Linker) + is + Leading : Boolean := True; + Next_Is_Object : Boolean := False; + + begin + for J in 1 .. Ada.Command_Line.Argument_Count loop + declare + Arg : String renames Argument (J); + begin + if Next_Is_Object then + Next_Is_Object := False; + Linker.Dest_Object := To_Unbounded_String (Arg); + Leading := False; + + elsif Argument (J) = "-o" then + Next_Is_Object := True; + + elsif Argument (J) = "-noauto-register" then + -- Filter out this argument, and do not generate _ctors/_dtors + Linker.Add_CDtors := False; + elsif Arg = "-v" and then not Is_Verbose then + -- first -v means VxLink should be verbose, two -v passes -v to + -- the linker. + Set_Verbose (True); + else + if Arg = "-nostdlib" or Arg = "-nostartfiles" then + Linker.Add_CDtors := False; + end if; + + if Leading then + Linker.Args_Leading.Append (Arg); + else + Linker.Args_Trailing.Append (Arg); + end if; + end if; + end; + end loop; + + if Linker.Dest_Object = Null_Unbounded_String then + Set_Error_State ("no output object is defined"); + elsif Linker.Add_CDtors then + -- We'll need to create intermediate artefacts, so we'll use the + -- destination object as base namespace just in case we have + -- several link operations in the same directory + declare + Obj : constant String := + Base_Name (To_String (Linker.Dest_Object)); + + begin + for J in reverse Obj'Range loop + if Obj (J) = '.' then + Linker.Dest_Base := + To_Unbounded_String (Obj (Obj'First .. J - 1)); + exit; + end if; + end loop; + + Linker.Partial_Obj := Linker.Dest_Base & "-partial.o"; + end; + end if; + end Initialize; + + ----------------- + -- Needs_CDtor -- + ----------------- + + function Needs_CDtor (Linker : VxLink_Linker) return Boolean is + begin + return Linker.Add_CDtors; + end Needs_CDtor; + + -------------------- + -- Partial_Object -- + -------------------- + + function Partial_Object (Linker : VxLink_Linker) return String is + begin + return To_String (Linker.Partial_Obj); + end Partial_Object; + + --------------- + -- Namespace -- + --------------- + + function Namespace (Linker : VxLink_Linker) return String is + begin + return To_String (Linker.Dest_Base); + end Namespace; + + --------------------- + -- Do_Initial_Link -- + --------------------- + + procedure Do_Initial_Link (Linker : VxLink_Linker) + is + Args : Arguments_List; + Gxx_Path : constant String := Gxx; + begin + if Is_Error_State then + return; + end if; + + if Gxx_Path'Length /= 0 then + Args.Append (Gxx); + else + Args.Append (Gcc); + end if; + Args.Append (Linker.Args_Leading); + Args.Append ("-o"); + + if Linker.Add_CDtors then + Args.Append (To_String (Linker.Partial_Obj)); + else + Args.Append (To_String (Linker.Dest_Object)); + end if; + + Args.Append (Linker.Args_Trailing); + + if not Linker.Add_CDtors then + Args.Append ("-nostartfiles"); + end if; + + Run (Args); + end Do_Initial_Link; + + ------------------- + -- Do_Final_Link -- + ------------------- + + procedure Do_Final_Link + (Linker : VxLink_Linker; + Ctdt_Obj : String) + is + Args : Arguments_List; + begin + if not Linker.Add_CDtors then + return; + end if; + + if Is_Error_State then + return; + end if; + + Args.Append (Gcc); + Args.Append ("-nostdlib"); + Args.Append (Ctdt_Obj); + Args.Append (To_String (Linker.Partial_Obj)); + Args.Append ("-o"); + Args.Append (To_String (Linker.Dest_Object)); + + Run (Args); + end Do_Final_Link; + +end VxLink.Link; diff --git a/gcc/ada/vxlink-link.ads b/gcc/ada/vxlink-link.ads new file mode 100644 index 0000000..4c46f48 --- /dev/null +++ b/gcc/ada/vxlink-link.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . L I N K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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 Ada_2012; + +private with Ada.Strings.Unbounded; + +package VxLink.Link is + + type VxLink_Linker is private; + + procedure Initialize + (Linker : out VxLink_Linker); + + function Needs_CDtor (Linker : VxLink_Linker) return Boolean; + + function Partial_Object (Linker : VxLink_Linker) return String; + + function Namespace (Linker : VxLink_Linker) return String; + + procedure Do_Initial_Link + (Linker : VxLink_Linker); + + procedure Do_Final_Link + (Linker : VxLink_Linker; + Ctdt_Obj : String); + +private + + use Ada.Strings.Unbounded; + + type VxLink_Linker is record + Args_Leading : Arguments_List; + Args_Trailing : Arguments_List; + Add_CDtors : Boolean := True; + Dest_Object : Unbounded_String; + Dest_Base : Unbounded_String; + Partial_Obj : Unbounded_String; + end record; + +end VxLink.Link; diff --git a/gcc/ada/vxlink-main.adb b/gcc/ada/vxlink-main.adb new file mode 100644 index 0000000..04a22c3 --- /dev/null +++ b/gcc/ada/vxlink-main.adb @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . M A I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- VxLink is a helper tool used as a wrapper around g++/gcc to build VxWorks +-- DKM (Downloadable Kernel Modules). +-- Such DKM is a partially linked object that contains entry points for +-- constructors and destructors. This tool thus uses g++ to generate an +-- intermediate partially linked object, retrieves the list of constructors +-- and destructors in it and produces a C file that lists those ctors/dtors +-- in a way that is understood be VxWorks kernel. It then links this file +-- with the intermediate object to produce a valid DKM. + +pragma Ada_2012; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with VxLink.Link; use VxLink.Link; +with VxLink.Bind; use VxLink.Bind; + +procedure VxLink.Main is + Linker : VxLink_Linker; + Binder : VxLink_Binder; + VSB_Dir : String_Access := Getenv ("VSB_DIR"); +begin + Initialize (Linker); + + if Is_Error_State then + return; + end if; + + Do_Initial_Link (Linker); + + if Is_Error_State then + return; + end if; + + if not Needs_CDtor (Linker) then + -- Initial link is enough, let's return + return; + end if; + + if VSB_Dir /= null and then VSB_Dir'Length > 0 then + declare + DKM_Tag_File : constant String := + Normalize_Pathname + ("krnl/tags/dkm.tags", VSB_Dir.all); + begin + if Is_Regular_File (DKM_Tag_File) then + Parse_Tag_File (Binder, DKM_Tag_File); + end if; + end; + end if; + + Initialize (Binder, Object_File => Partial_Object (Linker)); + Emit_CTDT (Binder, Namespace => Namespace (Linker)); + + Do_Final_Link (Linker, CTDT_File (Binder)); + Free (VSB_Dir); +end VxLink.Main; diff --git a/gcc/ada/vxlink.adb b/gcc/ada/vxlink.adb new file mode 100644 index 0000000..400ad22 --- /dev/null +++ b/gcc/ada/vxlink.adb @@ -0,0 +1,288 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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 Ada_2012; + +with Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Text_IO; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Expect; use GNAT.Expect; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body VxLink is + + Target_Triplet : Unbounded_String := Null_Unbounded_String; + Verbose : Boolean := False; + Error_State : Boolean := False; + + function Triplet return String; + + function Which (Exe : String) return String; + + ------------- + -- Triplet -- + ------------- + + function Triplet return String is + begin + if Target_Triplet = Null_Unbounded_String then + declare + Exe : constant String := File_Name (Ada.Command_Line.Command_Name); + begin + for J in reverse Exe'Range loop + if Exe (J) = '-' then + Target_Triplet := To_Unbounded_String (Exe (Exe'First .. J)); + exit; + end if; + end loop; + end; + end if; + + return To_String (Target_Triplet); + end Triplet; + + ----------- + -- Which -- + ----------- + + function Which (Exe : String) return String + is + Suffix : GNAT.OS_Lib.String_Access := Get_Executable_Suffix; + Basename : constant String := Exe & Suffix.all; + Path : GNAT.OS_Lib.String_Access := Getenv ("PATH"); + Last : Natural := Path'First; + + begin + Free (Suffix); + + for J in Path'Range loop + if Path (J) = Path_Separator then + declare + Full : constant String := Normalize_Pathname + (Name => Basename, + Directory => Path (Last .. J - 1), + Resolve_Links => False, + Case_Sensitive => True); + begin + if Is_Executable_File (Full) then + Free (Path); + + return Full; + end if; + end; + + Last := J + 1; + end if; + end loop; + + Free (Path); + + return ""; + end Which; + + ----------------- + -- Set_Verbose -- + ----------------- + + procedure Set_Verbose (Value : Boolean) + is + begin + Verbose := Value; + end Set_Verbose; + + ---------------- + -- Is_Verbose -- + ---------------- + + function Is_Verbose return Boolean + is + begin + return Verbose; + end Is_Verbose; + + --------------------- + -- Set_Error_State -- + --------------------- + + procedure Set_Error_State (Message : String) + is + begin + Log_Error ("Error: " & Message); + Error_State := True; + Ada.Command_Line.Set_Exit_Status (1); + end Set_Error_State; + + -------------------- + -- Is_Error_State -- + -------------------- + + function Is_Error_State return Boolean + is + begin + return Error_State; + end Is_Error_State; + + -------------- + -- Log_Info -- + -------------- + + procedure Log_Info (S : String) + is + begin + if Verbose then + Ada.Text_IO.Put_Line (S); + end if; + end Log_Info; + + --------------- + -- Log_Error -- + --------------- + + procedure Log_Error (S : String) + is + begin + Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, S); + end Log_Error; + + --------- + -- Run -- + --------- + + procedure Run (Arguments : Arguments_List) + is + Output : constant String := Run (Arguments); + begin + if not Is_Error_State then + -- In case of erroneous execution, the function version of run will + -- have already displayed the output + Ada.Text_IO.Put (Output); + end if; + end Run; + + --------- + -- Run -- + --------- + + function Run (Arguments : Arguments_List) return String + is + Args : GNAT.OS_Lib.Argument_List_Access := + new GNAT.OS_Lib.Argument_List + (1 .. Natural (Arguments.Length) - 1); + Base : constant String := Base_Name (Arguments.First_Element); + Status : aliased Integer := 0; + Debug_Line : Unbounded_String; + Add_Quotes : Boolean; + + begin + if Verbose then + Append (Debug_Line, Base); + end if; + + for J in Arguments.First_Index + 1 .. Arguments.Last_Index loop + declare + Arg : String renames Arguments.Element (J); + begin + Args (J - 1) := new String'(Arg); + + if Verbose then + Add_Quotes := False; + + for K in Arg'Range loop + if Arg (K) = ' ' then + Add_Quotes := True; + exit; + end if; + end loop; + + Append (Debug_Line, ' '); + + if Add_Quotes then + Append (Debug_Line, '"' & Arg & '"'); + else + Append (Debug_Line, Arg); + end if; + end if; + end; + end loop; + + if Verbose then + Ada.Text_IO.Put_Line (To_String (Debug_Line)); + end if; + + declare + Ret : constant String := + Get_Command_Output + (Command => Arguments.First_Element, + Arguments => Args.all, + Input => "", + Status => Status'Access, + Err_To_Out => True); + begin + GNAT.OS_Lib.Free (Args); + + if Status /= 0 then + Ada.Text_IO.Put_Line (Ret); + Set_Error_State + (Base_Name (Arguments.First_Element) & + " returned" & Status'Image); + end if; + + return Ret; + end; + end Run; + + --------- + -- Gcc -- + --------- + + function Gcc return String + is + begin + return Which (Triplet & "gcc"); + end Gcc; + + --------- + -- Gxx -- + --------- + + function Gxx return String + is + begin + return Which (Triplet & "g++"); + end Gxx; + + -------- + -- Nm -- + -------- + + function Nm return String + is + begin + return Which (Triplet & "nm"); + end Nm; + +end VxLink; diff --git a/gcc/ada/vxlink.ads b/gcc/ada/vxlink.ads new file mode 100644 index 0000000..37ae5d7 --- /dev/null +++ b/gcc/ada/vxlink.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, AdaCore -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- See vxlink-main.adb for a description of the tool. +-- +-- This package contains only common utility functions used by the other +-- child packages. + +pragma Ada_2012; + +with Ada.Containers.Indefinite_Vectors; + +package VxLink is + + package Strings_List is new Ada.Containers.Indefinite_Vectors + (Positive, String); + + subtype Arguments_List is Strings_List.Vector; + + procedure Set_Verbose (Value : Boolean); + function Is_Verbose return Boolean; + + procedure Set_Error_State (Message : String); + function Is_Error_State return Boolean; + + procedure Log_Info (S : String); + procedure Log_Error (S : String); + + procedure Run (Arguments : Arguments_List); + + function Run (Arguments : Arguments_List) return String; + + function Gcc return String; + -- Current toolchain's gcc command + + function Gxx return String; + -- Current toolchain's g++ command + + function Nm return String; + -- Current toolchain's nm command + + function Ends_With (Str, Suffix : String) return Boolean + is (Str'Length >= Suffix'Length + and then Str (Str'Last - Suffix'Length + 1 .. Str'Last) = Suffix); + +end VxLink; -- cgit v1.1 From 92a68a0464fc59667a3713c2a041b9f4582122a4 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 21 Aug 2018 14:50:03 +0000 Subject: [Ada] Minor reformattings 2018-08-21 Hristian Kirtchev gcc/ada/ * checks.adb, contracts.adb, exp_aggr.adb, exp_attr.adb, exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, exp_unst.adb, exp_util.adb, freeze.adb, gnatlink.adb, layout.adb, lib-writ.adb, lib-xref-spark_specific.adb, sem_ch13.adb, sem_ch3.adb, sem_ch6.adb, sem_res.adb, sem_util.adb, sinfo.ads, sprint.adb: Minor reformatting. From-SVN: r263737 --- gcc/ada/ChangeLog | 9 +++++++ gcc/ada/checks.adb | 6 ++--- gcc/ada/contracts.adb | 19 ++++++++------ gcc/ada/exp_aggr.adb | 5 ++-- gcc/ada/exp_attr.adb | 40 +++++++++++++++++------------- gcc/ada/exp_ch6.adb | 5 ++-- gcc/ada/exp_ch7.adb | 7 +++--- gcc/ada/exp_ch9.adb | 8 +++--- gcc/ada/exp_unst.adb | 13 ++++------ gcc/ada/exp_util.adb | 19 ++++++-------- gcc/ada/freeze.adb | 33 ++++++++++++------------- gcc/ada/gnatlink.adb | 6 ++--- gcc/ada/layout.adb | 7 +++--- gcc/ada/lib-writ.adb | 13 ++++++---- gcc/ada/lib-xref-spark_specific.adb | 1 + gcc/ada/sem_ch13.adb | 49 ++++++++++++++++++++----------------- gcc/ada/sem_ch3.adb | 8 ++++-- gcc/ada/sem_ch6.adb | 14 +++++++---- gcc/ada/sem_res.adb | 17 +++++++++---- gcc/ada/sem_util.adb | 5 ++-- gcc/ada/sinfo.ads | 2 +- gcc/ada/sprint.adb | 9 +++---- 22 files changed, 163 insertions(+), 132 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8d0da5a..0622701 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-08-21 Hristian Kirtchev + + * checks.adb, contracts.adb, exp_aggr.adb, exp_attr.adb, + exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, exp_unst.adb, + exp_util.adb, freeze.adb, gnatlink.adb, layout.adb, + lib-writ.adb, lib-xref-spark_specific.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch6.adb, sem_res.adb, sem_util.adb, sinfo.ads, + sprint.adb: Minor reformatting. + 2018-08-21 Jerome Lambourg * vxlink-bind.adb, vxlink-bind.ads, vxlink-link.adb, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index f399cda..1704a2f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6780,9 +6780,9 @@ package body Checks is and then Is_Integer_Type (Target_Base_Type) then Conv_Node := - OK_Convert_To ( - Typ => Target_Base_Type, - Expr => Duplicate_Subexpr (N)); + OK_Convert_To + (Typ => Target_Base_Type, + Expr => Duplicate_Subexpr (N)); -- Common case diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index e70765a..26a8d28 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -592,18 +592,20 @@ package body Contracts is null; -- Otherwise analyze the pre/postconditions. Their expressions - -- might include references to types that are not frozen yet, - -- in the case where the body is a rewritten expression function - -- that is a completion, so freeze all types within before - -- constructing the contract code. + -- might include references to types that are not frozen yet, in the + -- case where the body is a rewritten expression function that is a + -- completion, so freeze all types within before constructing the + -- contract code. else declare - Bod : Node_Id; + Bod : Node_Id; Freeze_Types : Boolean := False; + begin if Present (Freeze_Id) then Bod := Unit_Declaration_Node (Freeze_Id); + if Nkind (Bod) = N_Subprogram_Body and then Was_Expression_Function (Bod) and then Ekind (Subp_Id) = E_Function @@ -617,8 +619,11 @@ package body Contracts is Prag := Pre_Post_Conditions (Items); while Present (Prag) loop if Freeze_Types then - Freeze_Expr_Types (Subp_Id, Standard_Boolean, - Expression (Corresponding_Aspect (Prag)), Bod); + Freeze_Expr_Types + (Def_Id => Subp_Id, + Typ => Standard_Boolean, + Expr => Expression (Corresponding_Aspect (Prag)), + N => Bod); end if; Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d1d9c12..f65230f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6212,7 +6212,7 @@ package body Exp_Aggr is Establish_Transient_Scope (N, Manage_Sec_Stack => False); end if; - -- An array of limited components is built in place. + -- An array of limited components is built in place if Is_Limited_Type (Typ) then Maybe_In_Place_OK := True; @@ -6258,7 +6258,7 @@ package body Exp_Aggr is -- oversight: the rules in 7.6 (17) are clear. if (not Has_Default_Init_Comps (N) - or else Is_Limited_Type (Etype (N))) + or else Is_Limited_Type (Etype (N))) and then Comes_From_Source (Parent_Node) and then Parent_Kind = N_Object_Declaration and then Present (Expression (Parent_Node)) @@ -6385,7 +6385,6 @@ package body Exp_Aggr is if Has_Default_Init_Comps (N) and then not Maybe_In_Place_OK then - -- Ada 2005 (AI-287): This case has not been analyzed??? raise Program_Error; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 469a90e..d789748 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3672,29 +3672,35 @@ package body Exp_Attr is if Is_Fixed_Point_Type (Etype (N)) then declare Loc : constant Source_Ptr := Sloc (N); - Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Expr : constant Node_Id := Expression (N); - Fst : constant Entity_Id := Root_Type (Etype (N)); + Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Expr : constant Node_Id := Expression (N); + Fst : constant Entity_Id := Root_Type (Etype (N)); Decl : Node_Id; begin - Decl := Make_Full_Type_Declaration (Sloc (N), - Equiv_T, - Type_Definition => - Make_Signed_Integer_Type_Definition (Loc, - Low_Bound => Make_Integer_Literal (Loc, - Intval => Corresponding_Integer_Value - (Type_Low_Bound (Fst))), - High_Bound => Make_Integer_Literal (Loc, - Intval => Corresponding_Integer_Value - (Type_High_Bound (Fst))))); + Decl := + Make_Full_Type_Declaration (Sloc (N), + Defining_Identifier => Equiv_T, + Type_Definition => + Make_Signed_Integer_Type_Definition (Loc, + Low_Bound => + Make_Integer_Literal (Loc, + Intval => + Corresponding_Integer_Value + (Type_Low_Bound (Fst))), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + Corresponding_Integer_Value + (Type_High_Bound (Fst))))); Insert_Action (N, Decl); - -- Verify that the conversion is possible. - Generate_Range_Check - (Expr, Equiv_T, CE_Overflow_Check_Failed); + -- Verify that the conversion is possible + + Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed); + + -- and verify that the result is in range - -- and verify that the result is in range. Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed); end; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 224f4c7..e08b748 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6402,12 +6402,13 @@ package body Exp_Ch6 is and then Is_Protected_Type (Etype (Prefix (Name (Parent (N))))) and then Is_Entity_Name (Name (N)) and then Scope (Entity (Name (N))) = - Etype (Prefix (Name (Parent (N)))) + Etype (Prefix (Name (Parent (N)))) then Rewrite (Name (N), Make_Selected_Component (Sloc (N), - Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), + Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), Selector_Name => Relocate_Node (Name (N)))); + Analyze_And_Resolve (N); return; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 1b8b8f2..ee04b22 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4030,8 +4030,8 @@ package body Exp_Ch7 is ----------------------- function First_Local_Scope (L : List_Id) return Entity_Id is - Stat : Node_Id; Scop : Entity_Id; + Stat : Node_Id; begin Stat := First (L); @@ -4099,6 +4099,7 @@ package body Exp_Ch7 is when others => null; end case; + Next (Stat); end loop; @@ -4119,8 +4120,8 @@ package body Exp_Ch7 is and then Present (Handled_Statement_Sequence (N)) and then Is_Compilation_Unit (Current_Scope) then - Ent := First_Local_Scope - (Statements (Handled_Statement_Sequence (N))); + Ent := + First_Local_Scope (Statements (Handled_Statement_Sequence (N))); if Present (Ent) then Elab_Proc := diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index c398948..4470c4e 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8241,6 +8241,7 @@ package body Exp_Ch9 is end if; Analyze (N); + Reset_Scopes_To (N, Entity (Identifier (N))); end Expand_N_Conditional_Entry_Call; @@ -10707,7 +10708,7 @@ package body Exp_Ch9 is Make_Defining_Identifier (Eloc, New_External_Name (Chars (Ename), 'A', Num_Accept)); - -- Link the acceptor to the original receiving entry. + -- Link the acceptor to the original receiving entry Set_Ekind (PB_Ent, E_Procedure); Set_Receiving_Entry (PB_Ent, Eent); @@ -14850,7 +14851,6 @@ package body Exp_Ch9 is --------------------- procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is - function Reset_Scope (N : Node_Id) return Traverse_Result; -- Temporaries may have been declared during expansion of the procedure -- created for an entry body or an accept alternative. Indicate that @@ -14880,8 +14880,8 @@ package body Exp_Ch9 is -- Ditto for a package declaration or a full type declaration, etc. elsif Nkind (N) = N_Package_Declaration - or else Nkind (N) in N_Declaration - or else Nkind (N) in N_Renaming_Declaration + or else Nkind (N) in N_Declaration + or else Nkind (N) in N_Renaming_Declaration then Set_Scope (Defining_Entity (N), E); return Skip; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c5b03c4..d688157 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -260,12 +260,10 @@ package body Exp_Unst is E := Ultimate_Alias (E); -- The body of a protected operation has a different name and - -- has been scanned at this point, and thus has an entry in - -- the subprogram table. + -- has been scanned at this point, and thus has an entry in the + -- subprogram table. - if E = Sub - and then Convention (E) = Convention_Protected - then + if E = Sub and then Convention (E) = Convention_Protected then E := Protected_Body_Subprogram (E); end if; @@ -551,9 +549,8 @@ package body Exp_Unst is -- Explicit dereference and selected component case - elsif Nkind_In (N, - N_Explicit_Dereference, - N_Selected_Component) + elsif Nkind_In (N, N_Explicit_Dereference, + N_Selected_Component) then Note_Uplevel_Bound (Prefix (N), Ref); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 632c879..314e3ee 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8402,26 +8402,23 @@ package body Exp_Util is declare Align_In_Bits : constant Nat := M * System_Storage_Unit; - Off : Uint; - Siz : Uint; + Comp : Entity_Id; + begin + Comp := C; + -- For a component inherited in a record extension, the -- clause is inherited but position and size are not set. if Is_Base_Type (Etype (P)) and then Is_Tagged_Type (Etype (P)) - and then Present (Original_Record_Component (C)) + and then Present (Original_Record_Component (Comp)) then - Off := - Component_Bit_Offset (Original_Record_Component (C)); - Siz := Esize (Original_Record_Component (C)); - else - Off := Component_Bit_Offset (C); - Siz := Esize (C); + Comp := Original_Record_Component (Comp); end if; - if Off mod Align_In_Bits /= 0 - or else Siz mod Align_In_Bits /= 0 + if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0 + or else Esize (Comp) mod Align_In_Bits /= 0 then return True; end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index d7f3f58..5036a79 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3619,7 +3619,7 @@ package body Freeze is if Is_Access_Type (F_Type) and then Esize (F_Type) > Ttypes.System_Address_Size and then (not Unnest_Subprogram_Mode - or else not Is_Access_Subprogram_Type (F_Type)) + or else not Is_Access_Subprogram_Type (F_Type)) then Error_Msg_N ("?x?type of & does not correspond to C pointer!", Formal); @@ -7654,10 +7654,9 @@ package body Freeze is Expr : Node_Id; N : Node_Id) is - function Cloned_Expression return Node_Id; - -- Build a duplicate of the expression of the return statement that - -- has no defining entities shared with the original expression. + -- Build a duplicate of the expression of the return statement that has + -- no defining entities shared with the original expression. function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; -- Freeze all types referenced in the subtree rooted at Node @@ -7680,8 +7679,8 @@ package body Freeze is if Nkind_In (Node, N_Iterator_Specification, N_Loop_Parameter_Specification) then - Set_Defining_Identifier (Node, - New_Copy (Defining_Identifier (Node))); + Set_Defining_Identifier + (Node, New_Copy (Defining_Identifier (Node))); end if; return OK; @@ -7741,9 +7740,9 @@ package body Freeze is return; end if; - -- This provides a better error message than generating - -- primitives whose compilation fails much later. Refine - -- the error message if possible. + -- This provides a better error message than generating primitives + -- whose compilation fails much later. Refine the error message if + -- possible. Check_Fully_Declared (Typ, Node); @@ -7773,10 +7772,10 @@ package body Freeze is Check_And_Freeze_Type (Scope (Entity (Node))); end if; - -- Freezing an access type does not freeze the designated type, - -- but freezing conversions between access to interfaces requires - -- that the interface types themselves be frozen, so that dispatch - -- table entities are properly created. + -- Freezing an access type does not freeze the designated type, but + -- freezing conversions between access to interfaces requires that + -- the interface types themselves be frozen, so that dispatch table + -- entities are properly created. -- Unclear whether a more general rule is needed ??? @@ -7787,10 +7786,10 @@ package body Freeze is Check_And_Freeze_Type (Designated_Type (Etype (Node))); end if; - -- An implicit dereference freezes the designated type. In the - -- case of a dispatching call whose controlling argument is an - -- access type, the dereference is not made explicit, so we must - -- check for such a call and freeze the designated type. + -- An implicit dereference freezes the designated type. In the case + -- of a dispatching call whose controlling argument is an access + -- type, the dereference is not made explicit, so we must check for + -- such a call and freeze the designated type. if Nkind (Node) in N_Has_Etype and then Present (Etype (Node)) diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 16981b8..5c8bb7d 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1103,9 +1103,9 @@ procedure Gnatlink is -- as it is in the same directory as the shared version. if Nlast >= Library_Version'Length - and then Next_Line - (Nlast - Library_Version'Length + 1 .. Nlast) - = Library_Version + and then + Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) = + Library_Version then -- Set Last to point to last character before the -- library version. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 23436c8..a7b24ab 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -326,14 +326,13 @@ package body Layout is Init_Size (E, 2 * System_Address_Size); -- If unnesting subprograms, subprogram access types contain the - -- address of both the subprogram and an activation record. But - -- if we set that, we'll get a warning on different unchecked - -- conversion sizes in the RTS. So leave unset ub that case. + -- address of both the subprogram and an activation record. But if we + -- set that, we'll get a warning on different unchecked conversion + -- sizes in the RTS. So leave unset ub that case. elsif Unnest_Subprogram_Mode and then Is_Access_Subprogram_Type (E) then - -- Init_Size (E, 2 * System_Address_Size); null; -- Normal case of thin pointer diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index beb9489..a4f9526 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -963,10 +963,11 @@ package body Lib.Writ is -- allow partial analysis on incomplete sources. if GNATprove_Mode then - Body_Fname := - Get_File_Name (Get_Body_Name (Uname), - Subunit => False, May_Fail => True); + Get_File_Name + (Uname => Get_Body_Name (Uname), + Subunit => False, + May_Fail => True); Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); @@ -981,8 +982,10 @@ package body Lib.Writ is else Body_Fname := - Get_File_Name (Get_Body_Name (Uname), - Subunit => False, May_Fail => False); + Get_File_Name + (Uname => Get_Body_Name (Uname), + Subunit => False, + May_Fail => False); Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); end if; diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 00fe71a..ce4538b 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -228,6 +228,7 @@ package body SPARK_Specific is end loop; if Nkind (Context) = N_Pragma then + -- When used for cross-references then aspects might not be -- yet linked to pragmas; when used for AST navigation in -- GNATprove this routine is expected to follow those links. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1a12622..00854c9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8754,6 +8754,7 @@ package body Sem_Ch13 is -- Case where predicates are present if Present (Expr) then + -- Test for raise expression present Test_REs (Expr); @@ -8764,44 +8765,45 @@ package body Sem_Ch13 is if Raise_Expression_Present then declare - Map : constant Elist_Id := New_Elmt_List; - New_V : Entity_Id := Empty; - - -- The unanalyzed expression will be copied and appear in - -- both functions. Normally expressions do not declare new - -- entities, but quantified expressions do, so we need to - -- create new entities for their bound variables, to prevent - -- multiple definitions in gigi. - - function Reset_Loop_Variable (N : Node_Id) - return Traverse_Result; + function Reset_Loop_Variable + (N : Node_Id) return Traverse_Result; - procedure Collect_Loop_Variables is + procedure Reset_Loop_Variables is new Traverse_Proc (Reset_Loop_Variable); ------------------------ -- Reset_Loop_Variable -- ------------------------ - function Reset_Loop_Variable (N : Node_Id) - return Traverse_Result + function Reset_Loop_Variable + (N : Node_Id) return Traverse_Result is begin if Nkind (N) = N_Iterator_Specification then - New_V := Make_Defining_Identifier - (Sloc (N), Chars (Defining_Identifier (N))); - - Set_Defining_Identifier (N, New_V); + Set_Defining_Identifier (N, + Make_Defining_Identifier + (Sloc (N), Chars (Defining_Identifier (N)))); end if; return OK; end Reset_Loop_Variable; + -- Local variables + + Map : constant Elist_Id := New_Elmt_List; + begin Append_Elmt (Object_Entity, Map); Append_Elmt (Object_Entity_M, Map); Expr_M := New_Copy_Tree (Expr, Map => Map); - Collect_Loop_Variables (Expr_M); + + -- The unanalyzed expression will be copied and appear in + -- both functions. Normally expressions do not declare new + -- entities, but quantified expressions do, so we need to + -- create new entities for their bound variables, to prevent + -- multiple definitions in gigi. + + Reset_Loop_Variables (Expr_M); end; end if; @@ -8862,8 +8864,8 @@ package body Sem_Ch13 is -- loops during analysis and expansion. declare - function Reset_Quantified_Variable_Scope (N : Node_Id) - return Traverse_Result; + function Reset_Quantified_Variable_Scope + (N : Node_Id) return Traverse_Result; procedure Reset_Quantified_Variables_Scope is new Traverse_Proc (Reset_Quantified_Variable_Scope); @@ -8872,8 +8874,8 @@ package body Sem_Ch13 is -- Reset_Quantified_Variable_Scope -- ------------------------------------- - function Reset_Quantified_Variable_Scope (N : Node_Id) - return Traverse_Result + function Reset_Quantified_Variable_Scope + (N : Node_Id) return Traverse_Result is begin if Nkind_In (N, N_Iterator_Specification, @@ -8882,6 +8884,7 @@ package body Sem_Ch13 is Set_Scope (Defining_Identifier (N), Predicate_Function (Typ)); end if; + return OK; end Reset_Quantified_Variable_Scope; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d12ccc9..cc84f9c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -13693,8 +13693,12 @@ package body Sem_Ch3 is Related_Nod : Node_Id) return Entity_Id is T_Sub : constant Entity_Id := - Create_Itype (E_Record_Subtype, - Related_Nod, Corr_Rec, 'C', Suffix_Index => -1); + Create_Itype + (Ekind => E_Record_Subtype, + Related_Nod => Related_Nod, + Related_Id => Corr_Rec, + Suffix => 'C', + Suffix_Index => -1); begin Set_Etype (T_Sub, Corr_Rec); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3e0cae1..b330426 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -398,7 +398,11 @@ package body Sem_Ch6 is -- As elsewhere, we do not emit freeze nodes within a generic unit. if not Inside_A_Generic then - Freeze_Expr_Types (Def_Id, Etype (Def_Id), Expr, N); + Freeze_Expr_Types + (Def_Id => Def_Id, + Typ => Etype (Def_Id), + Expr => Expr, + N => N); end if; -- For navigation purposes, indicate that the function is a body @@ -7241,16 +7245,16 @@ package body Sem_Ch6 is end if; end; - -- Functions can override abstract interface functions - -- Return types must be subtype conformant. + -- Functions can override abstract interface functions. Return + -- types must be subtype conformant. elsif Ekind (Def_Id) = E_Function and then Ekind (Subp) = E_Function and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), Parameter_Specifications (Parent (Subp))) - and then Conforming_Types (Etype (Def_Id), Etype (Subp), - Subtype_Conformant) + and then Conforming_Types + (Etype (Def_Id), Etype (Subp), Subtype_Conformant) then Candidate := Subp; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5a1a9f7..2002b75 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6081,10 +6081,10 @@ package body Sem_Res is then if Is_Expression_Function (Entity (Subp)) then - -- Force freeze of expression function in call. + -- Force freeze of expression function in call Set_Comes_From_Source (Subp, True); - Set_Must_Not_Freeze (Subp, False); + Set_Must_Not_Freeze (Subp, False); end if; Freeze_Expression (Subp); @@ -6092,7 +6092,7 @@ package body Sem_Res is -- For a predefined operator, the type of the result is the type imposed -- by context, except for a predefined operation on universal fixed. - -- Otherwise The type of the call is the type returned by the subprogram + -- Otherwise the type of the call is the type returned by the subprogram -- being called. if Is_Predefined_Op (Nam) then @@ -6128,14 +6128,21 @@ package body Sem_Res is Ret_Type : constant Entity_Id := Etype (Nam); begin - -- If this is a parameterless call there is no ambiguity - -- and the call has the type of the function. + -- If this is a parameterless call there is no ambiguity and the + -- call has the type of the function. if No (First_Actual (N)) then Set_Etype (N, Etype (Nam)); + if Present (First_Formal (Nam)) then Resolve_Actuals (N, Nam); end if; + + -- Annotate the tree by creating a call marker in case the + -- original call is transformed by expansion. The call marker + -- is automatically saved for later examination by the ABE + -- Processing phase. + Build_Call_Marker (N); elsif Is_Access_Type (Ret_Type) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a8ea805..2b31cf7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -24040,12 +24040,11 @@ package body Sem_Util is then return True; - -- OUtside of its scope, a synchronized type may just be - -- private. + -- Outside of its scope, a synchronized type may just be private elsif Is_Private_Type (Curr) and then Present (Full_View (Curr)) - and then Is_Concurrent_Type (Full_View (Curr)) + and then Is_Concurrent_Type (Full_View (Curr)) then return Scope_Within (Full_View (Curr), Outer); end if; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ae29661..1359c94 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4674,7 +4674,7 @@ package Sinfo is -------------------------- -- 4.5.7 If Expression -- - ---------------------------- + -------------------------- -- IF_EXPRESSION ::= -- if CONDITION then DEPENDENT_EXPRESSION diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 7978823..ab7eecb 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3540,17 +3540,14 @@ package body Sprint is -- where the aspects are printed inside the package specification. if Has_Aspects (Node) - and then not Nkind_In (Node, N_Package_Declaration, - N_Generic_Package_Declaration) - and then not Is_Empty_List (Aspect_Specifications (Node)) + and then not Nkind_In (Node, N_Generic_Package_Declaration, + N_Package_Declaration) and then not Is_Empty_List (Aspect_Specifications (Node)) then Sprint_Aspect_Specifications (Node, Semicolon => True); end if; - if Nkind (Node) in N_Subexpr - and then Do_Range_Check (Node) - then + if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then Write_Str ("}"); end if; -- cgit v1.1 From 35574a7b41b8e6a143504d416306b789f62f1338 Mon Sep 17 00:00:00 2001 From: Giuliano Belinassi Date: Thu, 23 Aug 2018 17:01:09 +0000 Subject: Fix typo 'exapnded' to 'expanded' 2018-08-23 Giuliano Belinassi gcc/ * genmatch.c (parser::parse_operation): Fix typo 'exapnded' to 'expanded'. gcc/ada/ * exp_unst.ads: Fix typo 'exapnded' to 'expanded'. From-SVN: r263818 --- gcc/ada/ChangeLog | 4 ++++ gcc/ada/exp_unst.ads | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0622701..06b1106 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2018-08-23 Giuliano Belinassi + + * exp_unst.ads: Fix typo 'exapnded' to 'expanded'. + 2018-08-21 Hristian Kirtchev * checks.adb, contracts.adb, exp_aggr.adb, exp_attr.adb, diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 3b67a0d..a5cdf06 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -477,7 +477,7 @@ package Exp_Unst is -- subprograms exist. Similarly overloading would cause a naming issue. -- In fact, the expanded code includes qualified names which eliminate this - -- problem. We omitted the qualification from the exapnded examples above + -- problem. We omitted the qualification from the expanded examples above -- for simplicity. But to see this in action, consider this example: -- function Mnames return Boolean is -- cgit v1.1 From 3d78e00879b42574c9b0084c30f1361f0cfb9101 Mon Sep 17 00:00:00 2001 From: Martin Liska Date: Mon, 27 Aug 2018 14:34:52 +0200 Subject: Come up with fndecl_built_in_p. 2018-08-27 Martin Liska * builtins.h (is_builtin_fn): Remove and fndecl_built_in_p. * builtins.c (is_builtin_fn): Likewise. * attribs.c (diag_attr_exclusions): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. (builtin_mathfn_code): Likewise. (fold_builtin_expect): Likewise. (fold_call_expr): Likewise. (fold_builtin_call_array): Likewise. (fold_call_stmt): Likewise. (set_builtin_user_assembler_name): Likewise. (is_simple_builtin): Likewise. * calls.c (gimple_alloca_call_p): Likewise. (maybe_warn_nonstring_arg): Likewise. * cfgexpand.c (expand_call_stmt): Likewise. * cgraph.c (cgraph_update_edges_for_call_stmt_node): Likewise. (cgraph_edge::verify_corresponds_to_fndecl): Likewise. (cgraph_node::verify_node): Likewise. * cgraphclones.c (build_function_decl_skip_args): Likewise. (cgraph_node::create_clone): Likewise. * config/arm/arm.c (arm_insert_attributes): Likewise. * config/i386/i386.c (ix86_gimple_fold_builtin): Likewise. * dse.c (scan_insn): Likewise. * expr.c (expand_expr_real_1): Likewise. * fold-const.c (operand_equal_p): Likewise. (fold_binary_loc): Likewise. * gimple-fold.c (gimple_fold_stmt_to_constant_1): Likewise. * gimple-low.c (lower_stmt): Likewise. * gimple-pretty-print.c (dump_gimple_call): Likewise. * gimple-ssa-warn-restrict.c (wrestrict_dom_walker::check_call): Likewise. * gimple.c (gimple_build_call_from_tree): Likewise. (gimple_call_builtin_p): Likewise. (gimple_call_combined_fn): Likewise. * gimplify.c (gimplify_call_expr): Likewise. (gimple_boolify): Likewise. (gimplify_modify_expr): Likewise. (gimplify_addr_expr): Likewise. * hsa-gen.c (gen_hsa_insns_for_call): Likewise. * ipa-cp.c (determine_versionability): Likewise. * ipa-fnsummary.c (compute_fn_summary): Likewise. * ipa-param-manipulation.c (ipa_modify_formal_parameters): Likewise. * ipa-split.c (visit_bb): Likewise. (split_function): Likewise. * ipa-visibility.c (cgraph_externally_visible_p): Likewise. * lto-cgraph.c (input_node): Likewise. * lto-streamer-out.c (write_symbol): Likewise. * omp-low.c (setjmp_or_longjmp_p): Likewise. (lower_omp_1): Likewise. * predict.c (strip_predict_hints): Likewise. * print-tree.c (print_node): Likewise. * symtab.c (symtab_node::output_to_lto_symbol_table_p): Likewise. * trans-mem.c (is_tm_irrevocable): Likewise. (is_tm_load): Likewise. (is_tm_simple_load): Likewise. (is_tm_store): Likewise. (is_tm_simple_store): Likewise. (is_tm_abort): Likewise. (tm_region_init_1): Likewise. * tree-call-cdce.c (gen_shrink_wrap_conditions): Likewise. * tree-cfg.c (verify_gimple_call): Likewise. (move_stmt_r): Likewise. (stmt_can_terminate_bb_p): Likewise. * tree-eh.c (lower_eh_constructs_2): Likewise. * tree-if-conv.c (if_convertible_stmt_p): Likewise. * tree-inline.c (remap_gimple_stmt): Likewise. (copy_bb): Likewise. (estimate_num_insns): Likewise. (fold_marked_statements): Likewise. * tree-sra.c (scan_function): Likewise. * tree-ssa-ccp.c (surely_varying_stmt_p): Likewise. (optimize_stack_restore): Likewise. (pass_fold_builtins::execute): Likewise. * tree-ssa-dce.c (mark_stmt_if_obviously_necessary): Likewise. (mark_all_reaching_defs_necessary_1): Likewise. * tree-ssa-dom.c (dom_opt_dom_walker::optimize_stmt): Likewise. * tree-ssa-forwprop.c (simplify_builtin_call): Likewise. (pass_forwprop::execute): Likewise. * tree-ssa-loop-im.c (stmt_cost): Likewise. * tree-ssa-math-opts.c (pass_cse_reciprocals::execute): Likewise. * tree-ssa-sccvn.c (fully_constant_vn_reference_p): Likewise. * tree-ssa-strlen.c (get_string_length): Likewise. * tree-ssa-structalias.c (handle_lhs_call): Likewise. (find_func_aliases_for_call): Likewise. * tree-ssa-ter.c (find_replaceable_in_bb): Likewise. * tree-stdarg.c (optimize_va_list_gpr_fpr_size): Likewise. * tree-tailcall.c (find_tail_calls): Likewise. * tree.c (need_assembler_name_p): Likewise. (free_lang_data_in_decl): Likewise. (get_call_combined_fn): Likewise. * ubsan.c (is_ubsan_builtin_p): Likewise. * varasm.c (incorporeal_function_p): Likewise. * tree.h (DECL_BUILT_IN): Remove and replace with fndecl_built_in_p. (DECL_BUILT_IN_P): Transfort to fndecl_built_in_p. (fndecl_built_in_p): New. 2018-08-27 Martin Liska * gcc-interface/decl.c (update_profile): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. * gcc-interface/gigi.h (call_is_atomic_load): Likewise. * gcc-interface/utils.c (gnat_pushdecl): Likewise. 2018-08-27 Martin Liska * c-common.c (check_function_restrict): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. (check_builtin_function_arguments): Likewise. (reject_gcc_builtin): Likewise. * c-warn.c (sizeof_pointer_memaccess_warning): Likewise. 2018-08-27 Martin Liska * c-decl.c (locate_old_decl): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. (diagnose_mismatched_decls): Likewise. (merge_decls): Likewise. (warn_if_shadowing): Likewise. (pushdecl): Likewise. (implicitly_declare): Likewise. * c-parser.c (c_parser_postfix_expression_after_primary): Likewise. * c-tree.h (C_DECL_ISNT_PROTOTYPE): Likewise. * c-typeck.c (build_function_call_vec): Likewise. (convert_arguments): Likewise. 2018-08-27 Martin Liska * call.c (build_call_a): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. (build_cxx_call): Likewise. * constexpr.c (constexpr_fn_retval): Likewise. (cxx_eval_builtin_function_call): Likewise. (cxx_eval_call_expression): Likewise. (potential_constant_expression_1): Likewise. * cp-gimplify.c (cp_gimplify_expr): Likewise. (cp_fold): Likewise. * decl.c (decls_match): Likewise. (validate_constexpr_redeclaration): Likewise. (duplicate_decls): Likewise. (make_rtl_for_nonlocal_decl): Likewise. * name-lookup.c (consider_binding_level): Likewise. (cp_emit_debug_info_for_using): Likewise. * semantics.c (finish_call_expr): Likewise. * tree.c (builtin_valid_in_constant_expr_p): Likewise. 2018-08-27 Martin Liska * go-gcc.cc (Gcc_backend::call_expression): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. 2018-08-27 Martin Liska * lto-lang.c (handle_const_attribute): Use new function fndecl_built_in_p and remove check for FUNCTION_DECL if possible. * lto-symtab.c (lto_symtab_merge_p): Likewise. (lto_symtab_merge_decls_1): Likewise. (lto_symtab_merge_symbols): Likewise. * lto.c (lto_maybe_register_decl): Likewise. (read_cgraph_and_symbols): Likewise. From-SVN: r263880 --- gcc/ada/ChangeLog | 8 ++++++++ gcc/ada/gcc-interface/decl.c | 2 +- gcc/ada/gcc-interface/gigi.h | 2 +- gcc/ada/gcc-interface/utils.c | 2 +- 4 files changed, 11 insertions(+), 3 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 06b1106..58f336b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2018-08-27 Martin Liska + + * gcc-interface/decl.c (update_profile): Use new function + fndecl_built_in_p and remove check for FUNCTION_DECL if + possible. + * gcc-interface/gigi.h (call_is_atomic_load): Likewise. + * gcc-interface/utils.c (gnat_pushdecl): Likewise. + 2018-08-23 Giuliano Belinassi * exp_unst.ads: Fix typo 'exapnded' to 'expanded'. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index b1dc379..6f605bd 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5421,7 +5421,7 @@ update_profile (Entity_Id gnat_subprog) if (DECL_P (gnu_type)) { /* Builtins cannot have their address taken so we can reset them. */ - gcc_assert (DECL_BUILT_IN (gnu_type)); + gcc_assert (fndecl_built_in_p (gnu_type)); save_gnu_tree (gnat_subprog, NULL_TREE, false); save_gnu_tree (gnat_subprog, gnu_type, false); return; diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index b890195..eb64a8b 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -1081,7 +1081,7 @@ call_is_atomic_load (tree exp) { tree fndecl = get_callee_fndecl (exp); - if (!(fndecl && DECL_BUILT_IN_CLASS (fndecl) == BUILT_IN_NORMAL)) + if (!(fndecl && fndecl_built_in_p (fndecl, BUILT_IN_NORMAL))) return false; enum built_in_function code = DECL_FUNCTION_CODE (fndecl); diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index cc1fe77..313d984 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -773,7 +773,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) debugger at the proper time. */ if (DECL_EXTERNAL (decl) && TREE_CODE (decl) == FUNCTION_DECL - && DECL_BUILT_IN (decl)) + && fndecl_built_in_p (decl)) vec_safe_push (builtin_decls, decl); else if (global_bindings_p ()) vec_safe_push (global_decls, decl); -- cgit v1.1 From 92a285c1a7bad310d7223a7aa5d70e6a5fc3e644 Mon Sep 17 00:00:00 2001 From: Martin Liska Date: Mon, 27 Aug 2018 14:04:23 +0000 Subject: Replace 8 spaces with a tabular in ChangeLog files. From-SVN: r263886 --- gcc/ada/ChangeLog | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 58f336b..b61c605 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,8 +1,8 @@ 2018-08-27 Martin Liska * gcc-interface/decl.c (update_profile): Use new function - fndecl_built_in_p and remove check for FUNCTION_DECL if - possible. + fndecl_built_in_p and remove check for FUNCTION_DECL if + possible. * gcc-interface/gigi.h (call_is_atomic_load): Likewise. * gcc-interface/utils.c (gnat_pushdecl): Likewise. @@ -296,7 +296,7 @@ * gcc-interface/Makefile.in (xoscons): Likewise. 2018-07-31 Alexandre Oliva - Olivier Hainque + Olivier Hainque * gcc-interface/trans.c: Include debug.h. (file_map): New static variable. -- cgit v1.1 From 1fb90d5be8591b6d2ad021a05be5c4ef3b7bfc09 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 13 Sep 2018 17:05:40 +0000 Subject: re PR ada/81103 (gcc/ada/terminals.c: please remove unused termio.h) PR ada/81103 * terminals.c: Do not include termio.h. From-SVN: r264277 --- gcc/ada/ChangeLog | 7 ++++++- gcc/ada/terminals.c | 9 --------- 2 files changed, 6 insertions(+), 10 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b61c605..b3638be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-09-13 Eric Botcazou + + PR ada/81103 + * terminals.c: Do not include termio.h. + 2018-08-27 Martin Liska * gcc-interface/decl.c (update_profile): Use new function @@ -367,7 +372,7 @@ 2018-07-31 Eric Botcazou - * libgnarl/s-osinte__solaris.ads (upad64_t): New private type. + * libgnarl/s-osinte__solaris.ads (upad64_t): New private type. (mutex_t): Use it for 'lock' and 'data' components. (cond_t): Likewise for 'data' and use single 'flags' component. diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 7025f57..bd2cdd0 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -1107,14 +1107,6 @@ __gnat_setup_winsize (void *desc, int rows, int columns) #include #include #include - -/* On some system termio is either absent or including it will disable termios - (HP-UX) */ -#if !defined (__hpux__) && !defined (BSD) && !defined (__APPLE__) \ - && !defined (__rtems__) && !defined (__QNXNTO__) -# include -#endif - #include #include #include @@ -1130,7 +1122,6 @@ __gnat_setup_winsize (void *desc, int rows, int columns) # include #endif #if defined (__hpux__) -# include # include #endif -- cgit v1.1 From 131a075cc1794f08ebd743dbc13e102bea3d160c Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 13 Sep 2018 17:13:05 +0000 Subject: * Makefile.rtl (arm% linux-gnueabi%): Always set EH_MECHANISM to -arm. From-SVN: r264278 --- gcc/ada/ChangeLog | 4 ++++ gcc/ada/Makefile.rtl | 7 +------ 2 files changed, 5 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b3638be..9af9fab6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,9 @@ 2018-09-13 Eric Botcazou + * Makefile.rtl (arm% linux-gnueabi%): Always set EH_MECHANISM to -arm. + +2018-09-13 Eric Botcazou + PR ada/81103 * terminals.c: Do not include termio.h. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 9542fe0..936a16d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -2140,15 +2140,10 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),) $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads Date: Mon, 24 Sep 2018 10:29:07 +0000 Subject: re PR ada/87396 (ada/gcc-interface/decl.c:8798:53:Value Conversion Issue: implicit conversion from 'int' to 'char' changes value from 132 to -124: -Wconstant-conversion) PR ada/87396 * fe.h (Get_Attribute_Definition_Clause): Use 'unsigned char' instead of 'char' as the type of the second parameter. From-SVN: r264525 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/fe.h | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9af9fab6..e51a2a3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-09-24 Eric Botcazou + + PR ada/87396 + * fe.h (Get_Attribute_Definition_Clause): Use 'unsigned char' instead + of 'char' as the type of the second parameter. + 2018-09-13 Eric Botcazou * Makefile.rtl (arm% linux-gnueabi%): Always set EH_MECHANISM to -arm. diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 1928609..2d07aa5 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -85,7 +85,7 @@ extern void Set_RM_Size (Entity_Id, Uint); extern Boolean Is_Entity_Name (Node_Id); #define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause -extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); +extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char); /* errout: */ -- cgit v1.1