[PATCH] c-pragma: adding a data field to pragma_handler
This patch is about the pragmas.
In c-family/c-pragma.h, we declare a pragma_handler which is a function
accepting cpp_reader as parameter.
I have changed this handler in order to accept a second parameter which
is a void *, allowing to give extra datas to the handler. I think this
data field might be of general use: we can have condition or data at
register time that we want to express in the handler. I guess this is a
common way to pass data to an handler function.
I would like your opinion on this patch! Thanks!
Pierre Vittet
Changelog
2011-06-01 Pierre Vittet
* c-pragma.h (pragma_handler,internal_pragma_handler, c_register_pragma,
c_register_pragma_with_expansion): create internal_pragma_handler, add a
new void * data parameter.
* c-pragma.c (handle_pragma_pack, handle_pragma_weak,
handle_pragma_redefine_extname, handle_pragma_visibility,
handle_pragma_diagnostic, handle_pragma_target, handle_pragma_optimize,
handle_pragma_push_options, handle_pragma_pop_options,
handle_pragma_reset_options, handle_pragma_message,
handle_pragma_float_const_decimal64, registered_pragmas,
c_register_pragma_1, c_register_pragma,
c_register_pragma_with_expansion,
init_pragma): add support of the void * data field.
Index: gcc/c-family/c-pragma.h
===
--- gcc/c-family/c-pragma.h (revision 174521)
+++ gcc/c-family/c-pragma.h (working copy)
@@ -84,10 +84,19 @@ extern bool pop_visibility (int);
extern void init_pragma (void);
/* Front-end wrappers for pragma registration. */
-typedef void (*pragma_handler)(struct cpp_reader *);
-extern void c_register_pragma (const char *, const char *, pragma_handler);
-extern void c_register_pragma_with_expansion (const char *, const char *,
- pragma_handler);
+/* The void * allows to pass extra data to the handler. */
+typedef void (*pragma_handler)(struct cpp_reader *, void * );
+/* Internally use to keep the data of the handler. */
+struct internal_pragma_handler_d{
+ pragma_handler handler;
+ void * data;
+};
+typedef struct internal_pragma_handler_d internal_pragma_handler;
+
+extern void c_register_pragma (const char * space, const char * name,
+ pragma_handler handler, void * data);
+extern void c_register_pragma_with_expansion (const char * space,
+ const char * name, pragma_handler handler , void *
data);
extern void c_invoke_pragma_handler (unsigned int);
extern void maybe_apply_pragma_weak (tree);
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -53,7 +53,7 @@ typedef struct GTY(()) align_stack {
static GTY(()) struct align_stack * alignment_stack;
-static void handle_pragma_pack (cpp_reader *);
+static void handle_pragma_pack (cpp_reader *, void * data);
/* If we have a "global" #pragma pack() in effect when the first
#pragma pack(push,) is encountered, this stores the value of
@@ -133,7 +133,7 @@ pop_alignment (tree id)
#pragma pack (pop)
#pragma pack (pop, ID) */
static void
-handle_pragma_pack (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_pack (cpp_reader * ARG_UNUSED (dummy), void * ARG_UNUSED (data))
{
tree x, id = 0;
int align = -1;
@@ -247,7 +247,7 @@ DEF_VEC_ALLOC_O(pending_weak,gc);
static GTY(()) VEC(pending_weak,gc) *pending_weaks;
static void apply_pragma_weak (tree, tree);
-static void handle_pragma_weak (cpp_reader *);
+static void handle_pragma_weak (cpp_reader *, void * data);
static void
apply_pragma_weak (tree decl, tree value)
@@ -334,7 +334,7 @@ maybe_apply_pending_pragma_weaks (void)
/* #pragma weak name [= value] */
static void
-handle_pragma_weak (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_weak (cpp_reader * ARG_UNUSED (dummy), void * ARG_UNUSED (data))
{
tree name, value, x, decl;
enum cpp_ttype t;
@@ -411,11 +411,12 @@ DEF_VEC_ALLOC_O(pending_redefinition,gc);
static GTY(()) VEC(pending_redefinition,gc) *pending_redefine_extname;
-static void handle_pragma_redefine_extname (cpp_reader *);
+static void handle_pragma_redefine_extname (cpp_reader *, void * data);
/* #pragma redefine_extname oldname newname */
static void
-handle_pragma_redefine_extname (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_redefine_extname (cpp_reader * ARG_UNUSED (dummy),
+void * ARG_UNUSED (data))
{
tree oldname, newname, decl, x;
enum cpp_ttype t;
@@ -481,7 +482,8 @@ static GTY(()) tree pragma_extern_prefix;
/* #pragma extern_prefix "prefix" */
static void
-handle_pragma_extern_prefix (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_extern_prefix (cpp_reader * ARG_UNUSED (dummy),
+ voi
Re: [PATCH, MELT] correct meltgc_read_from_val without location
Hello,
here is an improvment to
http://gcc.gnu.org/ml/gcc-patches/2011-06/msg01888.html.
The function meltgc_read_from_val (in melt-runtime.c) takes two
arguments, a string value and a second one which is a location. In the
comments, it is written that we can pass a NULL pointer if we have no
location (it is a direct string). However, this conduct MELT to crash
because it doesn't handle correctly the absence of file.
In the first patch, I modified makesexpr to create a location with a
'virtual' file. This works however, as this function is used recursively
this is not very elegant.
This patch is more elegant, it adds a boolean field to the struct
reading_st to declare if there is no file location.
meltgc_read_* functions are modified to test if there is a given
location, and if no, it create a location with a virtual file and set
the boolean to false, conducting to avoid crash.
I have been able to build MELT with this pass and test it without problem.
On 24/06/2011 18:13, Pierre Vittet wrote:
Hello,
The function meltgc_read_from_val (in melt-runtime.c) takes two
arguments, a string value and a second one which is a location.
In the comments, it is written that we can pass a NULL pointer if we
have no location (it is a direct string). However, this conduct MELT to
crash because it doesn't handle correctly the absence of file.
This patch correct this, if there is no file, it create a "virtual" one
which is named "stringBuffer".
Pierre Vittet
correct_read_from_val_without_location-175348.diff
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175348)
+++ gcc/melt-runtime.c (working copy)
@@ -6292,6 +6292,7 @@ struct reading_st
int rcol;/* current column */
source_location rsrcloc; /* current source location */
melt_ptr_t *rpfilnam;/* pointer to location of file name string */
+ bool has_file_location; /* precise if the string comes from a file */
};
#define MELT_READ_TABULATION_FACTOR 8
@@ -6326,7 +6327,7 @@ melt_linemap_compute_current_location (struct read
{
int colnum = 1;
int cix = 0;
- if (!rd || !rd->rcurlin)
+ if (!rd || !rd->rcurlin || !rd->has_file_location)
return;
for (cix=0; cixrcol; cix++) {
char c = rd->rcurlin[cix];
@@ -8314,6 +8315,7 @@ meltgc_read_file (const char *filnam, const char *
rd = &rds;
locnamv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF
(DISCR_STRING), locnam);
rds.rpfilnam = (melt_ptr_t *) & locnamv;
+ rds.has_file_location = true;
seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
while (!rdeof ())
{
@@ -8371,7 +8373,16 @@ meltgc_read_from_rawstring (const char *rawstr, co
rds.rsrcloc = loch;
rd = &rds;
if (locnam)
-locnamv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF
(DISCR_STRING), locnam);
+{
+ rds.has_file_location = true;
+ locnamv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF
(DISCR_STRING), locnam);
+}
+ else
+{
+ rds.has_file_location = false;
+ locnamv = meltgc_new_string ((meltobject_ptr_t)
MELT_PREDEF(DISCR_STRING),
+ "stringBuffer");
+}
seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
rds.rpfilnam = (melt_ptr_t *) & locnamv;
while (rdcurc ())
@@ -8415,6 +8426,7 @@ meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_
locnamv = locnam_p;
rbuf = 0;
strmagic = melt_magic_discr ((melt_ptr_t) strv);
+ seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
switch (strmagic)
{
case MELTOBMAG_STRING:
@@ -8441,7 +8453,14 @@ meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_
rds.rpath = 0;
rds.rlineno = 0;
rds.rcurlin = rbuf;
+ rds.has_file_location = true;
rd = &rds;
+ if (locnamv == NULL){
+rds.has_file_location = false;
+locnamv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING),
+ "stringBuffer");
+rd->rpfilnam = (melt_ptr_t *) &locnamv;
+ }
rds.rpfilnam = (melt_ptr_t *) & locnamv;
while (rdcurc ())
{
2011-06-29 Pierre Vittet
* melt-runtime.c (struct reading_st): add a boolean has_file_location
field.
(melt_linemap_compute_current_location): return immediately if no file
location.
(meltgc_read_file, meltgc_read_from_rawstring, meltgc_read_from_val):
set has_file_location accordingly
(meltgc_read_from_val): create seqv list (it was used without being
created).
Re: [GCC-MELT-95] [Melt] Fix foreach_edge_bb_precs
On 25/07/2011 10:46, Romain Geissler wrote: Hello, This iteratoc won't work because of a little typo error (the previous edge field is preDs and not preCs). To avoid future errors, i apply the global /precs/preds/ change (and thus the iterator is renamed). Romain Geissler Hello, I wrote the initial iterator and agree with your change. I guess Basile will commit it soon. Pierre
[PATCH, MELT] fixing upgrade-warmelt target
Hello, I am trying to fix upgrade-warmelt into last revision of MELT. We are using some move-if-change on meltdesc file (in melt-stage3 for example) to make a save (to a meltdesc\~) but we still need the meltdesc file for the generated files. So I replaced move-ifchange by a cp and it goes beyond (but there are still issues. Pierre Vittet Index: melt-build.tpl === --- melt-build.tpl (révision 178131) +++ melt-build.tpl (copie de travail) @@ -579,7 +579,7 @@ ENDFOR melt_translator_file+] [+FOR melt_translator_file+] @echo upgrading MELT translator [+base+] ## dont indent the [+base+]+meltdesc.c - $(melt_make_move) $(MELT_LAST_STAGE)/[+base+]+meltdesc.c $(MELT_LAST_STAGE)/[+base+]+meltdesc.c~; \ + cp $(MELT_LAST_STAGE)/[+base+]+meltdesc.c $(MELT_LAST_STAGE)/[+base+]+meltdesc.c~; \ sed s/$(MELT_LAST_STAGE)/MELT-STAGE-ZERO/g $(MELT_LAST_STAGE)/[+base+]+meltdesc.c > $(srcdir)/melt/generated/[+base+]+meltdesc.c for f in $(MELT_LAST_STAGE)/[+base+].c $(MELT_LAST_STAGE)/[+base+]+[0-9]*.c ; do \ bf=`basename $$f`; \ 2011-08-27 Pierre Vittet * melt-build.tpl (warmelt-upgrade-translator): replace move-if-change by a cp. Index: Makefile.in === --- Makefile.in (révision 178131) +++ Makefile.in (copie de travail) @@ -5516,7 +5516,7 @@ upgrade-warmelt: $(WARMELT_LAST) for f in $(wildcard meltrunsup*.[ch]); do \ cp $$f $$f-tmp; \ cp $(srcdir)/melt/generated/$$f $$f-old; \ - $(SHELL) $(srcdir)/../move-if-change $$f-tmp $(srcdir)/melt/generated/$$f; \ + $(SHELL) cp $$f-tmp $(srcdir)/melt/generated/$$f; \ done $(RM) melt-runtime.o melt-runtime.i s-gtype */warmelt*.o $(MAKE) s-gtype 2011-08-27 Pierre Vittet * Makefile.in (upgrade-warmelt): replace move-if-change by a cp.
Re: [PATCH, MELT, minor] add a primitive read_strv
Hello,
this is a ping for
http://gcc.gnu.org/ml/gcc-patches/2011-07/msg01503.html. I thought this
was integrated into MELT but it does not look to be in the current trunk.
It just add a primitive read_strv allowing to use meltgc_read_from_val
to get a list of s-expression from a boxed C string of a strbuf.
Pierre Vittet
Index: gcc/melt/warmelt-base.melt
===
--- gcc/melt/warmelt-base.melt (revision 176434)
+++ gcc/melt/warmelt-base.melt (working copy)
@@ -272,6 +272,11 @@ number $NUM opaque location number $LOC.}#
:doc #{Read from file named by the $FILNAM string balue a list of MELT
s-expressions.}#
#{(meltgc_read_file (melt_string_str((melt_ptr_t)($filnam)), (char*)0))}#)
+(defprimitive read_strv (strv) :value
+ :doc #{Return the list of sexpr contained in $STRV. $STRV can be a boxed
+ string or a strbuf value.}#
+ #{(meltgc_read_from_val ($strv, NULL))}#
+)
;; to signal an error in a source with some additional string value
(defprimitive error_strv (loc :cstring cmsg :value strv) :void
@@ -2441,6 +2446,7 @@ polyhedron values.}#
pair_set_head
ppstrbuf_mixbigint
read_file
+ read_strv
register_pass_execution_hook
register_pragma_handler
register_pre_genericize_hook
2011-07-18 Pierre Vittet
* melt/warmelt-base.melt (read_strv): New primitive.
[PATCH, MELT] add primitive isnull_tree
Hello,
This is a small patch adding primitive isnull_tree (as there is already
a primitive isnull_basicblock).
Pierre Vittet
Index: gcc/melt/xtramelt-ana-base.melt
===
--- gcc/melt/xtramelt-ana-base.melt (révision 178282)
+++ gcc/melt/xtramelt-ana-base.melt (copie de travail)
@@ -1447,12 +1447,15 @@
(defprimitive gimpleseq_content (v) :gimple_seq
#{(melt_gimpleseq_content((melt_ptr_t)($v)))}# )
+
-
-
(defprimitive is_tree (v) :long
#{(melt_magic_discr((melt_ptr_t)($v)) == MELTOBMAG_TREE)}# )
+(defprimitive isnull_tree (:tree tr) :long
+ #{$tr == (tree)0}#
+)
+
(defprimitive make_tree (discr :tree g) :value
#{(meltgc_new_tree((meltobject_ptr_t)($discr),($g)))}# )
@@ -3597,7 +3600,8 @@ and discriminant $DIS, usually $DISCR_MIXED_LOCATI
is_mapgimple
is_maploop
is_maptree
- is_tree
+ is_tree
+ isnull_tree
isnull_basicblock
loop_body_tuple
loop_can_be_parallel
2011-08-30 Pierre Vittet
* melt/xtramelt-ana-base.melt(isnull_tree): Add primitive.
[PATCH, libiberty] correct md5_process_bytes with unaligned pointers
Hello,
The patch is the result of the following threads:
Here is a patch correcting md5_process_bytes when we are in the case of
unaligned pointers.A pair of brace was missing, leading the buffer to be
shift 2 times losing a part of its content.
The patch also remove a preprocessor #if testing if
_STRING_ARCH_unaligned is defined. This symbol is never defined in gcc
and could be only used in CFLAGS. Looking at the code, it does not looks
usefull to define it (and it is only tested on libiberty/md5.c and
libiberty/sha1.c), as we already check the pointer alignement, so
removing it clean the code. I searched on google, and it does not looks
to be used. Does anyone want it or thing that it should not be removed?
Ok for trunk ?
Thanks!
Pierre Vittet
PS: I also write a small gcc plugin, allowing to easily test
md5_process_bytes, if can change your environment in a way where the
pointer buffer is not aligned, you should get the bug.
Index: libiberty/md5.c
===
--- libiberty/md5.c (révision 178905)
+++ libiberty/md5.c (copie de travail)
@@ -227,7 +227,6 @@ md5_process_bytes (const void *buffer, size_t len,
/* Process available complete blocks. */
if (len > 64)
{
-#if !_STRING_ARCH_unaligned
/* To check alignment gcc has an appropriate operator. Other
compilers don't. */
# if __GNUC__ >= 2
@@ -244,10 +243,11 @@ md5_process_bytes (const void *buffer, size_t len,
len -= 64;
}
else
-#endif
- md5_process_block (buffer, len & ~63, ctx);
- buffer = (const void *) ((const char *) buffer + (len & ~63));
- len &= 63;
+ {
+ md5_process_block (buffer, len & ~63, ctx);
+ buffer = (const void *) ((const char *) buffer + (len & ~63));
+ len &= 63;
+ }
}
/* Move remaining bytes in internal buffer. */
2011-09-16 Pierre Vittet
* md5.c (md5_process_bytes): Remove unused _STRING_ARCH_unaligned, add
missing braces.
micro_plugin_md5.tar.gz
Description: GNU Zip compressed data
Re: [PATCH, libiberty] correct md5_process_bytes with unaligned pointers
Hello, Ping! I would like to get a return on this patch. I don't know quite well the status of libiberty in GNU, please if I must this patch on another mailing list, please say me on which. Thanks! Pierre Vittet
[PATCH, MELT] correct meltgc_string_hex_md5sum_file_sequence
Hello
Here is a patch allowing to compute correctly the md5 of a file sequence
even with the bug rapported here:
http://gcc.gnu.org/ml/gcc-patches/2011-09/msg00963.html.
The function will work with both gcc 4.6 without the patch and a gcc
with the patch applied.
The problem cames from the fact that we were calling md5_process_bytes
several times with a buffer of a size which was not a multiple of 64.
Doing so, the next buffer was modified to take those data in account and
doing so, we had not always an aligned pointer.
We now concatenate file stream and so we can have a buffer with a
multiple of 64 size, so we can call md5_process_block. We only call
md5_process_bytes for the last data.
Thanks!
Pierre Vittet
2011-09-19 Pierre Vittet
* melt-runtime.c (meltgc_string_hex_md5sum_file_sequence): Concatenate
files stream to call md5_process_block, we only call md5_process_bytes
for the last datas.
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (révision 178881)
+++ gcc/melt-runtime.c (copie de travail)
@@ -5374,7 +5374,11 @@ melt_compile_source (const char *srcbase, const ch
}
/* compute the hexadecimal encoded md5sum string of a tuple of file
-paths, or NULL on failure */
+paths, or NULL on failure.
+When we finish to proceed a file, we immediatly add the beginning of the
+following file to bufblock to keep a size of a multiple of 64. This permit
+to call md5_process_block. We only call md5_process_bytes for the last
+data. */
melt_ptr_t
meltgc_string_hex_md5sum_file_sequence (melt_ptr_t pathtup_p)
{
@@ -5385,6 +5389,7 @@ melt_compile_source (const char *srcbase, const ch
FILE *fil = NULL;
int nbtup = 0;
int cnt = 0;
+ int new_file_cnt = 0;
struct md5_ctx ctx;
MELT_ENTERFRAME(3, NULL);
#define resv meltfram__.mcfr_varptr[0]
@@ -5394,12 +5399,12 @@ melt_compile_source (const char *srcbase, const ch
memset (&ctx, 0, sizeof(ctx));
memset (md5srctab, 0, sizeof (md5srctab));
memset (md5hex, 0, sizeof (md5hex));
- memset (bufblock, 0, sizeof (bufblock));
if (melt_magic_discr ((melt_ptr_t)pathtupv) != MELTOBMAG_MULTIPLE)
goto end;
md5_init_ctx (&ctx);
nbtup = melt_multiple_length ((melt_ptr_t)pathtupv);
/* this loop does not garbage collect! */
+ memset (bufblock, 0, sizeof (bufblock));
for (ix=0; ix < nbtup; ix++)
{
const char *curpath = NULL;
@@ -5414,22 +5419,33 @@ melt_compile_source (const char *srcbase, const ch
goto end;
while (!feof (fil))
{
- memset (bufblock, 0, sizeof (bufblock));
- cnt = fread (bufblock, 1, sizeof(bufblock), fil);
+ if (cnt != 0) /*means that we havent process bufblock from previous
+ file.*/
+{
+ new_file_cnt =fread (bufblock+cnt,
sizeof(char),sizeof(bufblock)-cnt, fil);
+ cnt = cnt + new_file_cnt;
+
+}
+ else
+{
+ cnt = fread (bufblock, sizeof(char), sizeof(bufblock), fil);
+}
if (cnt ==sizeof(bufblock))
{
/* an entire block has been read. */
- md5_process_bytes (bufblock, sizeof(bufblock), &ctx);
+ md5_process_block (bufblock, sizeof(bufblock), &ctx);
+ memset (bufblock, '\0', sizeof (bufblock));
+ cnt = 0;
}
- else
-{
- md5_process_bytes (bufblock, (size_t) cnt, &ctx);
-}
}
fclose (fil);
fil = NULL;
curpath = NULL;
}
+ if (cnt !=0) /*We still have some data in the buffer*/
+ {
+ md5_process_bytes (bufblock, (size_t) cnt, &ctx);
+ }
md5_finish_ctx (&ctx, md5srctab);
memset (md5hex, 0, sizeof(md5hex));
for (ix=0; ix<16; ix++) {
[PATCH, MELT] add pragma support in MELT plugin
Hello,
The following patch allows to use pragma in a MELT plugin.
For exemple we can recover the following pragmas:
#pragma GCCPLUGIN melt op
or
#pragma GCCPLUGIN melt op (arg1, arg2, ...)
with argX a name, a string, or a number.
It is easy to change the pragma space ("GCCPLUGIN") and name ("melt"),
so I am open to suggestion.
This plugin works on the MELT heart and so It need to regenerate the source.
The first .diff (addPragma-warmelt-first) contains the
gcc/melt/warmelt-first.melt file: I have added a field in the MELT
class_system_data class which allows the user to add a function handling
pragma.
After adding this diff, it is needed to use 'make upgrade-warmelt' in
the gcc directory to regenerate gcc/melt/generated.
After this, it is possible to add the second diff (addPragma-runtime):
it contains change in gcc/melt-runtime.c and gcc/melt-runtime.h: it adds
the melt_pragma_callback which register the pragma handler defined in
the same file. The pragma handler calls the function defined by the user
and gives it the trees corresponding to the pragma operator and argument.
I have been obliged to use weak symbols for pragma_lex and
c_register_pragma as they are not defined when using lto. This is a
temporary solution that I commented.
I am going to send a test in the Testsuite, but I have already tried it
successfully with something like that:
(defun my_simple_pragma_handler(val1 lstarg)
(debug_msg val1 "debugging melt pragma")
)
(put_fields
initial_system_data
:sysdata_meltpragma_definer my_simple_pragma_handler
)
Pierre Vittet
Index: gcc/melt/warmelt-first.melt
===
--- gcc/melt/warmelt-first.melt (revision 174379)
+++ gcc/melt/warmelt-first.melt (working copy)
@@ -436,6 +436,7 @@ don't instanciate this class!}#
sysdata_pass_dict;stringmap for passes
sysdata_exit_finalizer ;;closure to be called after the
passes, at finalization
sysdata_meltattr_definer ;;closure to be called for melt
attributes
+ sysdata_meltpragma_definer ;;closure to be called for melt pragma
sysdata_patmacro_exporter;closure to export a patmacro
sysdata_debugmsg ;closure for debugmsg
sysdata_stdout ;raw file for stdout
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 174379)
+++ gcc/melt-runtime.c (working copy)
@@ -75,6 +75,7 @@ along with GCC; see the file COPYING3. If not se
#include "plugin.h"
#include "cppdefault.h"
+#include "c-pragma.h"
#if BUILDING_GCC_VERSION > 4005
/* GCC 4.6 has realmpfr.h which includes */
#include "realmpfr.h"
@@ -8930,7 +8931,124 @@ melt_attribute_callback(void *gcc_data ATTRIBUTE_U
register_attribute(&melt_attr_spec);
}
+/*We declare weak functions because they cannot be linked when we use lto (it
+loses langage specific informations).
+If you use one of those functions you must check them to be not NULL.
+*/
+extern enum cpp_ttype __attribute__((weak)) pragma_lex (tree *);
+extern void __attribute__((weak)) c_register_pragma (const char *, const char
+*, pragma_handler);
+#define GCC_BAD(gmsgid) \
+ do { warning (OPT_Wpragmas, gmsgid); goto end; } while (0)
+
+
+void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev);
+
+/* handle a melt pragma*/
+static void
+handle_melt_pragma (cpp_reader *ARG_UNUSED(dummy))
+{
+ enum cpp_ttype token;
+ /*list containing the pragma argument*/
+ tree x;
+ MELT_ENTERFRAME (3, NULL);
+#define seqv meltfram__.mcfr_varptr[0]
+#define treev meltfram__.mcfr_varptr[1]
+#define optreev meltfram__.mcfr_varptr[2]
+ if(! pragma_lex || ! c_register_pragma)
+GCC_BAD("Cannot use pragma symbol at this level (maybe you use -flto which
\
+is incompatible).");
+
+ token = pragma_lex (&x);
+ if(token != CPP_NAME)
+GCC_BAD ("malformed #pragma melt, ignored");
+ optreev = meltgc_new_tree((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x);
+ /*If the pragma has the form #pragma PLUGIN melt id (...) then optreev is the
+ tree containing "id".
+ Next element should be a parenthese opening. */
+ token = pragma_lex (&x);
+ if (token != CPP_OPEN_PAREN){
+if (token != CPP_EOF)
+ GCC_BAD ("malformed #pragma melt, ignored");
+
+else{ /* we have a pragma of the type '#pragma PLUGIN melt instr' */
+ melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) NULL);
+}
+ }
+ else{/* opening parenthesis */
+seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
+do {
+ token = pragma_lex (&x);
+ if(token != CPP_NAME && token != CPP_STRING && token != CPP_NUMBER)
+
Re: [PATCH] c-pragma: adding a data field to pragma_handler
Thank you for your answer!
I send you a new patch
I have corrected the errors you raised.
I have make my patch compatible with the old use of c_register_pragma
and c_register_pragma_with_expansion.
I don't know what is the best solution, maybe changing every call
c_register_pragma allows to keep a more clear code. I can do it, if you
think it is better.
I have successfully compiled gcc with my patch and I have tried it with
a modified version of gcc/testsuite/g++.dg/plugin/pragma_plugin.c.
Pierre Vittet
On 02/06/2011 19:51, Tom Tromey wrote:
"Pierre" == Pierre writes:
Pierre> I have changed this handler in order to accept a second parameter
Pierre> which is a void *, allowing to give extra datas to the handler. I
Pierre> think this data field might be of general use: we can have condition
Pierre> or data at register time that we want to express in the handler. I
Pierre> guess this is a common way to pass data to an handler function.
I can't approve or reject this patch, but the idea seems reasonable
enough to me.
Pierre> I would like your opinion on this patch! Thanks!
It has a number of formatting issues.
Pierre> +typedef void (*pragma_handler)(struct cpp_reader *, void * );
No space after the final "*".
Pierre> +/* Internally use to keep the data of the handler. */
Pierre> +struct internal_pragma_handler_d{
Space before the "{".
Pierre> + pragma_handler handler;
Pierre> + void * data;
No space. Lots of instances of this.
Pierre> /* A vector of registered pragma callbacks. */
Pierre> +/*This is never freed as we need it during the whole execution */
Coalesce the two comments. The comment formatting is wrong, see GNU
standards.
Pierre> ns_name.space = space;
Pierre> ns_name.name = name;
Pierre> +
Pierre> VEC_safe_push (pragma_ns_name, heap,
registered_pp_pragmas,&ns_name);
Gratuitous newline addition.
Pierre> + ihandler->handler = handler;
Pierre> + ihandler->data = data;
I didn't see anything that initialized ihandler.
Pierre> + VEC_safe_push (internal_pragma_handler, heap,
registered_pragmas,
Pierre> +&ihandler);
I think you wanted just `internal_pragma_handler ihandler', no "*", for
the definition.
Pierre> +c_register_pragma (const char *space, const char *name,
pragma_handler handler,
Pierre> + void * data)
There are lots of calls to this that you did not update.
Do a recursive grep to see.
One way to avoid a massive change is to add a new "overload" that passes
in the data to c_register_pragma_1; and then change the "legacy"
functions to pass NULL.
I don't know if that approach is ok (it is typical in gdb...), so if
not, you have to update all callers.
Tom
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -53,7 +53,7 @@ typedef struct GTY(()) align_stack {
static GTY(()) struct align_stack * alignment_stack;
-static void handle_pragma_pack (cpp_reader *);
+static void handle_pragma_pack (cpp_reader *, void * data);
/* If we have a "global" #pragma pack() in effect when the first
#pragma pack(push,) is encountered, this stores the value of
@@ -133,7 +133,7 @@ pop_alignment (tree id)
#pragma pack (pop)
#pragma pack (pop, ID) */
static void
-handle_pragma_pack (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_pack (cpp_reader * ARG_UNUSED (dummy), void * ARG_UNUSED (data))
{
tree x, id = 0;
int align = -1;
@@ -247,7 +247,7 @@ DEF_VEC_ALLOC_O(pending_weak,gc);
static GTY(()) VEC(pending_weak,gc) *pending_weaks;
static void apply_pragma_weak (tree, tree);
-static void handle_pragma_weak (cpp_reader *);
+static void handle_pragma_weak (cpp_reader *, void * data);
static void
apply_pragma_weak (tree decl, tree value)
@@ -334,7 +334,7 @@ maybe_apply_pending_pragma_weaks (void)
/* #pragma weak name [= value] */
static void
-handle_pragma_weak (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_weak (cpp_reader * ARG_UNUSED (dummy), void * ARG_UNUSED (data))
{
tree name, value, x, decl;
enum cpp_ttype t;
@@ -411,11 +411,12 @@ DEF_VEC_ALLOC_O(pending_redefinition,gc);
static GTY(()) VEC(pending_redefinition,gc) *pending_redefine_extname;
-static void handle_pragma_redefine_extname (cpp_reader *);
+static void handle_pragma_redefine_extname (cpp_reader *, void * data);
/* #pragma redefine_extname oldname newname */
static void
-handle_pragma_redefine_extname (cpp_reader * ARG_UNUSED (dummy))
+handle_pragma_redefine_extname (cpp_reader * ARG_UNUSED (dummy),
+void * ARG_UNUSED (data))
{
tree oldname, newname, decl, x;
enum cpp_ttype t;
@@ -481,7 +482,8 @@ static GTY(()) tree
Re: [PATCH] c-pragma: adding a data field to pragma_handler
Hello,
I am sorry, my editor (vim) was not correctly configure (I used
http://gcc.gnu.org/ml/gcc/2011-03/msg00425.html to improve it). I guess
it is ok now.
If I still have issue, I will post on the mailing list if there is some
tips for vim otherway I will use Emacs (I am not very comfortable with
it for now ;).
Pierre Vittet
On 03/06/2011 17:47, Basile Starynkevitch wrote:
On Fri, 03 Jun 2011 17:31:25 +0200
Pierre Vittet wrote:
Thank you for your answer!
I send you a new patch
I have corrected the errors you raised.
I have make my patch compatible with the old use of c_register_pragma
and c_register_pragma_with_expansion.
I find the patch quite interesting, but I cannot approve it.
void
+c_register_pragma_with_expansion_and_data (const char *space, const char *name,
+
pragma_handler_2arg handler,
+ void * data)
Perhaps there are some spaces (vs tabs) issues here.
Cheers
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1148,12 +1148,12 @@ handle_pragma_float_const_decimal64 (cpp_reader *A
}
/* A vector of registered pragma callbacks. */
+/* This is never freed as we need it during the whole execution. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
-DEF_VEC_O (pragma_handler);
-DEF_VEC_ALLOC_O (pragma_handler, heap);
+static VEC(internal_pragma_handler, heap) *registered_pragmas;
-static VEC(pragma_handler, heap) *registered_pragmas;
-
typedef struct
{
const char *space;
@@ -1216,7 +1216,7 @@ c_pp_lookup_pragma (unsigned int id, const char **
static void
c_register_pragma_1 (const char *space, const char *name,
-pragma_handler handler, bool allow_expansion)
+ internal_pragma_handler ihandler, bool allow_expansion)
{
unsigned id;
@@ -1235,8 +1235,9 @@ c_register_pragma_1 (const char *space, const char
}
else
{
- VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler);
- id = VEC_length (pragma_handler, registered_pragmas);
+ VEC_safe_push (internal_pragma_handler, heap, registered_pragmas,
+ &ihandler);
+ id = VEC_length (internal_pragma_handler, registered_pragmas);
id += PRAGMA_FIRST_EXTERNAL - 1;
/* The C++ front end allocates 6 bits in cp_token; the C front end
@@ -1248,28 +1249,90 @@ c_register_pragma_1 (const char *space, const char
allow_expansion, false);
}
+/* Register a C pragma handler, using a space and a name. It disallows pragma
+expansion (if you want it, use c_register_pragma_with_expansion instead). */
void
-c_register_pragma (const char *space, const char *name, pragma_handler handler)
+c_register_pragma (const char *space, const char *name,
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, false);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, false);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+extra data field which can be used by the handler. It disallows pragma
+expansion (if you want it, use c_register_pragma_with_expansion instead). */
void
+c_register_pragma_with_data (const char *space, const char *name,
+ pragma_handler_2arg handler, void * data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, false);
+}
+
+/* Register a C pragma handler, using a space and a name. It allows pragma
+expansion as in the following exemple:
+ #define NUMBER 10
+ #pragma count (NUMBER)
+Name expansion is still disallowed. */
+void
c_register_pragma_with_expansion (const char *space, const char *name,
- pragma_handler handler)
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, true);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, true);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+extra data field which can be used by the handler. It allows pragma expansion
+as in the following exemple:
+ #define NUMBER 10
+ #pragma count (NUMBER)
+Name expansion is still disallowed. */
void
+c_register_pragma_with_expansion_and_data (const char *space, const char *name,
+ pragma_hand
Re: [PATCH] c-pragma: adding a data field to pragma_handler
I have written a test for this patch and run it (it works correctly). I
guess there is no reason why it should not be accepted now.
To recap, this patch add a void * data field to the pragma handler,
allowing to pass extra data. If we want to use this field, we need to
use the function c_register_pragma_with_data or
c_register_pragma_with_expansion_and_data. The old
c_register_pragma(_with_expansion) is kept compatible.
I give two diff and two ChangeLog, the first are for the patch itself,
the second are for the test.
I have tried to make things as good as possible, if there is a remark,
please, send me it. Especially, I am not sure about the format of my
ChangeLog, if there is an issue, I am ready to change it.
Changelog gcc:
2011-06-08 Pierre Vittet
* c-pragma.h (pragma_handler_1arg, pragma_handler_2arg,
gen_pragma_handler, internal_pragma_handler, c_register_pragma,
c_register_pragma_with_data, c_register_pragma_with_expansion,
c_register_pragma_with_expansion_and_data): allows to add data to a
pragma handler using a new c_register. Old c_register keep old
behaviour for compatibility.
* c-pragma.c (registered_pragmas, c_register_pragma_1,
c_register_pragma, c_register_pragma_with_data,
c_register_pragma_with_expansion,
c_register_pragma_with_expansion_and_data, c_invoke_pragma_handler,
init_pragma): allows to add data to a pragma handler using a new
c_register. Old registers keep old behaviour for compatibility.
Changelog testsuite
2011-06-08 Pierre Vittet
* g++.dg/plugin/pragma_plugin_with_data.c: New test.
Thanks!
Pierre Vittet
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1148,12 +1148,12 @@ handle_pragma_float_const_decimal64 (cpp_reader *A
}
/* A vector of registered pragma callbacks. */
+/* This is never freed as we need it during the whole execution. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
-DEF_VEC_O (pragma_handler);
-DEF_VEC_ALLOC_O (pragma_handler, heap);
+static VEC(internal_pragma_handler, heap) *registered_pragmas;
-static VEC(pragma_handler, heap) *registered_pragmas;
-
typedef struct
{
const char *space;
@@ -1216,7 +1216,7 @@ c_pp_lookup_pragma (unsigned int id, const char **
static void
c_register_pragma_1 (const char *space, const char *name,
-pragma_handler handler, bool allow_expansion)
+ internal_pragma_handler ihandler, bool allow_expansion)
{
unsigned id;
@@ -1235,8 +1235,9 @@ c_register_pragma_1 (const char *space, const char
}
else
{
- VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler);
- id = VEC_length (pragma_handler, registered_pragmas);
+ VEC_safe_push (internal_pragma_handler, heap, registered_pragmas,
+ &ihandler);
+ id = VEC_length (internal_pragma_handler, registered_pragmas);
id += PRAGMA_FIRST_EXTERNAL - 1;
/* The C++ front end allocates 6 bits in cp_token; the C front end
@@ -1248,28 +1249,90 @@ c_register_pragma_1 (const char *space, const char
allow_expansion, false);
}
+/* Register a C pragma handler, using a space and a name. It disallows pragma
+expansion (if you want it, use c_register_pragma_with_expansion instead). */
void
-c_register_pragma (const char *space, const char *name, pragma_handler handler)
+c_register_pragma (const char *space, const char *name,
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, false);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, false);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+extra data field which can be used by the handler. It disallows pragma
+expansion (if you want it, use c_register_pragma_with_expansion instead). */
void
+c_register_pragma_with_data (const char *space, const char *name,
+ pragma_handler_2arg handler, void * data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, false);
+}
+
+/* Register a C pragma handler, using a space and a name. It allows pragma
+expansion as in the following exemple:
+ #define NUMBER 10
+ #pragma count (NUMBER)
+Name expansion is still disallowed. */
+void
c_register_pragma_with_expansion (const char *space, const char *name,
- pragma_handler handler)
+ pragma_handler_1arg
Re: [PATCH] c-pragma: adding a data field to pragma_handler
You are right, the new version is in the diff.
The diff for the test hasn't changed and is in the previous mail.
In the previous version of the file, the registered_pragmas was not
better freed. I don't know if it is really important (it would need a
callback at the end of the front-end passes).
Thanks.
On 09/06/2011 08:16, Basile Starynkevitch wrote:
On Wed, 08 Jun 2011 23:26:39 +0200
Pierre Vittet wrote:
I have written a test for this patch and run it (it works correctly). I
guess there is no reason why it should not be accepted now.
To recap, this patch add a void * data field to the pragma handler,
allowing to pass extra data. If we want to use this field, we need to
use the function c_register_pragma_with_data or
c_register_pragma_with_expansion_and_data. The old
c_register_pragma(_with_expansion) is kept compatible.
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1148,12 +1148,12 @@ handle_pragma_float_const_decimal64 (cpp_reader
*A }
/* A vector of registered pragma callbacks. */
+/* This is never freed as we need it during the whole execution. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
Sorry to be picky Pierre, but that comment is not correct. It should be
instead.
/* A vector of registered pragma callbacks, which is never freed. */
What I mean is that you are right that the vector is never freed, but
it is not because it is needed during the entire execution, since
middle-end and back-end passes don't know about pragmas.
I hope your patch will be ok-ed with that small change.
Perhaps a future patch would free that registered_pragmas vector, but I
feel that is not necessary, since it is not a big vector in practice.
Regards.
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1147,13 +1147,12 @@ handle_pragma_float_const_decimal64 (cpp_reader *A
}
}
-/* A vector of registered pragma callbacks. */
+/* A vector of registered pragma callbacks, which is never freed. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
-DEF_VEC_O (pragma_handler);
-DEF_VEC_ALLOC_O (pragma_handler, heap);
+static VEC(internal_pragma_handler, heap) *registered_pragmas;
-static VEC(pragma_handler, heap) *registered_pragmas;
-
typedef struct
{
const char *space;
@@ -1216,7 +1215,7 @@ c_pp_lookup_pragma (unsigned int id, const char **
static void
c_register_pragma_1 (const char *space, const char *name,
-pragma_handler handler, bool allow_expansion)
+ internal_pragma_handler ihandler, bool allow_expansion)
{
unsigned id;
@@ -1235,8 +1234,9 @@ c_register_pragma_1 (const char *space, const char
}
else
{
- VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler);
- id = VEC_length (pragma_handler, registered_pragmas);
+ VEC_safe_push (internal_pragma_handler, heap, registered_pragmas,
+ &ihandler);
+ id = VEC_length (internal_pragma_handler, registered_pragmas);
id += PRAGMA_FIRST_EXTERNAL - 1;
/* The C++ front end allocates 6 bits in cp_token; the C front end
@@ -1248,28 +1248,90 @@ c_register_pragma_1 (const char *space, const char
allow_expansion, false);
}
+/* Register a C pragma handler, using a space and a name. It disallows pragma
+expansion (if you want it, use c_register_pragma_with_expansion instead). */
void
-c_register_pragma (const char *space, const char *name, pragma_handler handler)
+c_register_pragma (const char *space, const char *name,
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, false);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, false);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+extra data field which can be used by the handler. It disallows pragma
+expansion (if you want it, use c_register_pragma_with_expansion instead). */
void
+c_register_pragma_with_data (const char *space, const char *name,
+ pragma_handler_2arg handler, void * data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, false);
+}
+
+/* Register a C pragma handler, using a space and a name. It allows pragma
+expansion as in the following exemple:
+ #define NUMBER 10
+ #pragma count (NUMBER)
+Name expansion is stil
Re: [PATCH] c-pragma: adding a data field to pragma_handler
thanks!
I formatted as you requested.
I cannot commit myself as I haven't a "write after approval" status,
maye you can do it, or I can wait my GSOC mentor, Basile Starynkevitch
to do this (He mights be busy for a few days).
Pierre Vittet
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1147,13 +1147,12 @@ handle_pragma_float_const_decimal64 (cpp_reader *A
}
}
-/* A vector of registered pragma callbacks. */
+/* A vector of registered pragma callbacks, which is never freed. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
-DEF_VEC_O (pragma_handler);
-DEF_VEC_ALLOC_O (pragma_handler, heap);
+static VEC(internal_pragma_handler, heap) *registered_pragmas;
-static VEC(pragma_handler, heap) *registered_pragmas;
-
typedef struct
{
const char *space;
@@ -1216,7 +1215,7 @@ c_pp_lookup_pragma (unsigned int id, const char **
static void
c_register_pragma_1 (const char *space, const char *name,
-pragma_handler handler, bool allow_expansion)
+ internal_pragma_handler ihandler, bool allow_expansion)
{
unsigned id;
@@ -1235,8 +1234,9 @@ c_register_pragma_1 (const char *space, const char
}
else
{
- VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler);
- id = VEC_length (pragma_handler, registered_pragmas);
+ VEC_safe_push (internal_pragma_handler, heap, registered_pragmas,
+ &ihandler);
+ id = VEC_length (internal_pragma_handler, registered_pragmas);
id += PRAGMA_FIRST_EXTERNAL - 1;
/* The C++ front end allocates 6 bits in cp_token; the C front end
@@ -1248,28 +1248,95 @@ c_register_pragma_1 (const char *space, const char
allow_expansion, false);
}
+/* Register a C pragma handler, using a space and a name. It disallows pragma
+ expansion (if you want it, use c_register_pragma_with_expansion instead).
*/
void
-c_register_pragma (const char *space, const char *name, pragma_handler handler)
+c_register_pragma (const char *space, const char *name,
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, false);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, false);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+ extra data field which can be used by the handler. It disallows pragma
+ expansion (if you want it, use c_register_pragma_with_expansion_and_data
+ instead). */
void
+c_register_pragma_with_data (const char *space, const char *name,
+ pragma_handler_2arg handler, void * data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, false);
+}
+
+/* Register a C pragma handler, using a space and a name. It allows pragma
+ expansion as in the following example:
+
+ #define NUMBER 10
+ #pragma count (NUMBER)
+
+ Name expansion is still disallowed. */
+void
c_register_pragma_with_expansion (const char *space, const char *name,
- pragma_handler handler)
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, true);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, true);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+ extra data field which can be used by the handler. It allows pragma
+ expansion as in the following example:
+
+ #define NUMBER 10
+ #pragma count (NUMBER)
+
+ Name expansion is still disallowed. */
void
+c_register_pragma_with_expansion_and_data (const char *space, const char *name,
+ pragma_handler_2arg handler,
+ void *data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, true);
+}
+
+void
c_invoke_pragma_handler (unsigned int id)
{
- pragma_handler handler;
+ internal_pragma_handler *ihandler;
+ pragma_handler_1arg handler_1arg;
+ pragma_handler_2arg handler_2arg;
id -= PRAGMA_FIRST_EXTERNAL;
- handler = *VEC_index (pragma_handler, registered_pragmas, id);
-
- handler (parse_in);
+ ihandler = VEC_index (internal_pragma_handler, registered_pragmas, id);
+ if (ihandler->extra_data)
+{
+
Re: [PATCH] c-pragma: adding a data field to pragma_handler
I guess this is better now.
Changelog (gcc/c-family):
2011-06-10 Pierre Vittet
* c-pragma.h (pragma_handler_1arg, pragma_handler_2arg): New handler.
(gen_pragma_handler): New union.
(internal_pragma_handler): New type.
(c_register_pragma_with_data,
c_register_pragma_with_expansion_and_data): New functions.
* c-pragma.c (registered_pragmas, c_register_pragma_1,
c_register_pragma, c_register_pragma_with_expansion,
c_invoke_pragma_handler): Changed to work with internal_pragma_handler.
(c_register_pragma_with_data,
c_register_pragma_with_expansion_and_data): New functions.
Changelog (gcc/testsuite):
2011-06-10 Pierre Vittet
* g++.dg/plugin/pragma_plugin_with_data.c: New test file.
* g++.dg/plugin/pragma_plugin_with_data-test-1.C: New test file.
* g++.dg/plugin/plugin.exp (plugin_test_list): Add the new test
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1147,13 +1147,12 @@ handle_pragma_float_const_decimal64 (cpp_reader *A
}
}
-/* A vector of registered pragma callbacks. */
+/* A vector of registered pragma callbacks, which is never freed. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
-DEF_VEC_O (pragma_handler);
-DEF_VEC_ALLOC_O (pragma_handler, heap);
+static VEC(internal_pragma_handler, heap) *registered_pragmas;
-static VEC(pragma_handler, heap) *registered_pragmas;
-
typedef struct
{
const char *space;
@@ -1216,7 +1215,7 @@ c_pp_lookup_pragma (unsigned int id, const char **
static void
c_register_pragma_1 (const char *space, const char *name,
-pragma_handler handler, bool allow_expansion)
+ internal_pragma_handler ihandler, bool allow_expansion)
{
unsigned id;
@@ -1235,8 +1234,9 @@ c_register_pragma_1 (const char *space, const char
}
else
{
- VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler);
- id = VEC_length (pragma_handler, registered_pragmas);
+ VEC_safe_push (internal_pragma_handler, heap, registered_pragmas,
+ &ihandler);
+ id = VEC_length (internal_pragma_handler, registered_pragmas);
id += PRAGMA_FIRST_EXTERNAL - 1;
/* The C++ front end allocates 6 bits in cp_token; the C front end
@@ -1248,28 +1248,95 @@ c_register_pragma_1 (const char *space, const char
allow_expansion, false);
}
+/* Register a C pragma handler, using a space and a name. It disallows pragma
+ expansion (if you want it, use c_register_pragma_with_expansion instead).
*/
void
-c_register_pragma (const char *space, const char *name, pragma_handler handler)
+c_register_pragma (const char *space, const char *name,
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, false);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, false);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+ extra data field which can be used by the handler. It disallows pragma
+ expansion (if you want it, use c_register_pragma_with_expansion_and_data
+ instead). */
void
+c_register_pragma_with_data (const char *space, const char *name,
+ pragma_handler_2arg handler, void * data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, false);
+}
+
+/* Register a C pragma handler, using a space and a name. It allows pragma
+ expansion as in the following example:
+
+ #define NUMBER 10
+ #pragma count (NUMBER)
+
+ Name expansion is still disallowed. */
+void
c_register_pragma_with_expansion (const char *space, const char *name,
- pragma_handler handler)
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, true);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, true);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+ extra data field which can be used by the handler. It allows pragma
+ expansion as in the following example:
+
+ #define NUMBER 10
+ #pragma count (NUMBER)
+
+ Name expansion is still disallowed. */
void
+c_register_pragma_with_expansion_and_data (const char *space, const char *name,
+ pragma_handler_2arg handler,
+ void *data)
+{
+ internal_pragma
[APPROVED PATCH] c-pragma: adding a data field to pragma_handler
Thoses two patchs have already been approved (see
http://gcc.gnu.org/ml/gcc-patches/2011-06/msg01159.html).
I haven't write permission currently, could someone commit them?
ChangeLogs have to be applied on gcc/c-family/ChangeLog .
Thanks !
Pierre Vittet
Index: gcc/c-family/c-pragma.c
===
--- gcc/c-family/c-pragma.c (revision 174521)
+++ gcc/c-family/c-pragma.c (working copy)
@@ -1147,13 +1147,12 @@ handle_pragma_float_const_decimal64 (cpp_reader *A
}
}
-/* A vector of registered pragma callbacks. */
+/* A vector of registered pragma callbacks, which is never freed. */
+DEF_VEC_O (internal_pragma_handler);
+DEF_VEC_ALLOC_O (internal_pragma_handler, heap);
-DEF_VEC_O (pragma_handler);
-DEF_VEC_ALLOC_O (pragma_handler, heap);
+static VEC(internal_pragma_handler, heap) *registered_pragmas;
-static VEC(pragma_handler, heap) *registered_pragmas;
-
typedef struct
{
const char *space;
@@ -1216,7 +1215,7 @@ c_pp_lookup_pragma (unsigned int id, const char **
static void
c_register_pragma_1 (const char *space, const char *name,
-pragma_handler handler, bool allow_expansion)
+ internal_pragma_handler ihandler, bool allow_expansion)
{
unsigned id;
@@ -1235,8 +1234,9 @@ c_register_pragma_1 (const char *space, const char
}
else
{
- VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler);
- id = VEC_length (pragma_handler, registered_pragmas);
+ VEC_safe_push (internal_pragma_handler, heap, registered_pragmas,
+ &ihandler);
+ id = VEC_length (internal_pragma_handler, registered_pragmas);
id += PRAGMA_FIRST_EXTERNAL - 1;
/* The C++ front end allocates 6 bits in cp_token; the C front end
@@ -1248,28 +1248,95 @@ c_register_pragma_1 (const char *space, const char
allow_expansion, false);
}
+/* Register a C pragma handler, using a space and a name. It disallows pragma
+ expansion (if you want it, use c_register_pragma_with_expansion instead).
*/
void
-c_register_pragma (const char *space, const char *name, pragma_handler handler)
+c_register_pragma (const char *space, const char *name,
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, false);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, false);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+ extra data field which can be used by the handler. It disallows pragma
+ expansion (if you want it, use c_register_pragma_with_expansion_and_data
+ instead). */
void
+c_register_pragma_with_data (const char *space, const char *name,
+ pragma_handler_2arg handler, void * data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, false);
+}
+
+/* Register a C pragma handler, using a space and a name. It allows pragma
+ expansion as in the following example:
+
+ #define NUMBER 10
+ #pragma count (NUMBER)
+
+ Name expansion is still disallowed. */
+void
c_register_pragma_with_expansion (const char *space, const char *name,
- pragma_handler handler)
+ pragma_handler_1arg handler)
{
- c_register_pragma_1 (space, name, handler, true);
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_1arg = handler;
+ ihandler.extra_data = false;
+ ihandler.data = NULL;
+ c_register_pragma_1 (space, name, ihandler, true);
}
+/* Register a C pragma handler, using a space and a name, it also carries an
+ extra data field which can be used by the handler. It allows pragma
+ expansion as in the following example:
+
+ #define NUMBER 10
+ #pragma count (NUMBER)
+
+ Name expansion is still disallowed. */
void
+c_register_pragma_with_expansion_and_data (const char *space, const char *name,
+ pragma_handler_2arg handler,
+ void *data)
+{
+ internal_pragma_handler ihandler;
+
+ ihandler.handler.handler_2arg = handler;
+ ihandler.extra_data = true;
+ ihandler.data = data;
+ c_register_pragma_1 (space, name, ihandler, true);
+}
+
+void
c_invoke_pragma_handler (unsigned int id)
{
- pragma_handler handler;
+ internal_pragma_handler *ihandler;
+ pragma_handler_1arg handler_1arg;
+ pragma_handler_2arg handler_2arg;
id -= PRAGMA_FIRST_EXTERNAL;
- handler = *VEC_index (pragma_handler, registered_pragmas, id);
-
- handler (parse_in);
+ ihandler = VEC_index (internal_pragma_handler, registered_pragmas, id);
+ if (ihandler->extra_data)
+{
+
[PATCH, MELT] fix minor issue with meltgc_new_split_string
Hello,
I got a bug when using meltgc_new_split_string (in melt-runtime.c) with
a string (argument str) like this one "mystringanotherString"
with the separator. The function is not working on a string that
start with the separator.
I guess this case can happen in real case, for exemple when an user give
arguments with a space as a separator.
The function was also not working properly on a string like this one:
"firstStrsecondStr".
With the patch, we get a correct list, ignoring the possible presence of
a first separator and of separator immediatly followed by another.
I took this opportunity to add a small comment to the function (in the
second diff).
ChangeLog
2011-06-21 Pierre Vittet
* melt-runtime.c (meltgc_new_split_string): Fix issue.
2011-06-21 Pierre Vittet
* melt-runtime.c (meltgc_new_split_string): Add comment.
Pierre Vittet
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175247)
+++ gcc/melt-runtime.c (working copy)
@@ -4638,6 +4638,12 @@ meltgc_new_split_string (const char*str, int sep,
{
cursep = NULL;
strv = NULL;
+ /* avoid errors when we have str which starts with the separator or when
+ we have a separator immediatly followed by another one (like
+ 'first::second').
+ */
+ while (*pc == sep)
+pc++;
if (ISSPACE (sep))
for (cursep=pc; *cursep && !ISSPACE (*cursep); cursep++);
else
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175247)
+++ gcc/melt-runtime.c (working copy)
@@ -4604,7 +4604,8 @@ end:
#undef str_strv
}
-
+/* Split a string into a list of string value using sep as separating
character.
+*/
melt_ptr_t
meltgc_new_split_string (const char*str, int sep, melt_ptr_t discr_p)
{
[PATCH, MELT] loading extra module before setting options
Hello,
In the function load_melt_modules_and_do_mode of melt-runtime.c, we
first load initial modules, then we set options, and then we look at
extra modules.
With this patch, we load extra modules before we set options, because
extra modules can contain code to handle options.
This change has been compiled and tested without errors.
ChangeLog:
2011-06-22 Pierre Vittet
* melt-runtime.c (load_melt_modules_and_do_mode): load extra module
before
setting options
Pierre Vittet
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175330)
+++ gcc/melt-runtime.c (working copy)
@@ -8721,65 +8721,6 @@ load_melt_modules_and_do_mode (void)
}
/**
- * Then we set MELT options.
- **/
- MELT_LOCATION_HERE ("before setting options");
- optstr = melt_argument ("option");
- debugeprintf ("load_initial_melt_modules optstr %s", optstr);
- if (optstr && optstr[0]
- && (optsetv=melt_get_inisysdata (FSYSDAT_OPTION_SET)) != NULL
- && melt_magic_discr ((melt_ptr_t) optsetv) == MELTOBMAG_CLOSURE)
-{
- char *optc = 0;
- char *optname = 0;
- char *optvalue = 0;
- for (optc = CONST_CAST (char *, optstr);
- optc && *optc;
- )
- {
- optname = optvalue = NULL;
- if (!ISALPHA(*optc))
- melt_fatal_error ("invalid MELT option name %s [should start with
letter]",
- optc);
- optname = optc;
- while (*optc && (ISALNUM(*optc) || *optc=='_' || *optc=='-'))
- optc++;
- if (*optc == '=') {
- *optc = (char)0;
- optc++;
- optvalue = optc;
- while (*optc && *optc != ',')
- optc++;
- }
- if (*optc==',') {
- *optc = (char)0;
- optc++;
- }
- optsymbv = meltgc_named_symbol (optname, MELT_CREATE);
- {
- union meltparam_un pararg[1];
- memset (¶rg, 0, sizeof (pararg));
- pararg[0].meltbp_cstring = optvalue;
- MELT_LOCATION_HERE ("option set before apply");
- debugeprintf ("MELT option %s value %s", optname,
- optvalue?optvalue:"_");
- optresv =
- melt_apply ((meltclosure_ptr_t) optsetv,
- (melt_ptr_t) optsymbv,
- MELTBPARSTR_CSTRING, pararg, "", NULL);
- if (!optresv)
- warning (0, "unhandled MELT option %s", optname);
- }
- }
-
- /* after options setting, force a minor collection to ensure
-nothing is left in young region */
- MELT_LOCATION_HERE ("option set done");
- melt_garbcoll (0, MELT_ONLY_MINOR);
-}
- MELT_LOCATION_HERE ("after setting options");
-
- /**
* Then we handle extra modules if given.
**/
debugeprintf ("xtrastr %p %s", xtrastr, xtrastr);
@@ -8845,6 +8786,65 @@ load_melt_modules_and_do_mode (void)
debugeprintf ("no xtrastr %p", xtrastr);
/**
+ * Then we set MELT options.
+ **/
+ MELT_LOCATION_HERE ("before setting options");
+ optstr = melt_argument ("option");
+ debugeprintf ("load_initial_melt_modules optstr %s", optstr);
+ if (optstr && optstr[0]
+ && (optsetv=melt_get_inisysdata (FSYSDAT_OPTION_SET)) != NULL
+ && melt_magic_discr ((melt_ptr_t) optsetv) == MELTOBMAG_CLOSURE)
+{
+ char *optc = 0;
+ char *optname = 0;
+ char *optvalue = 0;
+ for (optc = CONST_CAST (char *, optstr);
+ optc && *optc;
+ )
+ {
+ optname = optvalue = NULL;
+ if (!ISALPHA(*optc))
+ melt_fatal_error ("invalid MELT option name %s [should start with
letter]",
+ optc);
+ optname = optc;
+ while (*optc && (ISALNUM(*optc) || *optc=='_' || *optc=='-'))
+ optc++;
+ if (*optc == '=') {
+ *optc = (char)0;
+ optc++;
+ optvalue = optc;
+ while (*optc && *optc != ',')
+ optc++;
+ }
+ if (*optc==',') {
+ *optc = (char)0;
+ optc++;
+ }
+ optsymbv = meltgc_named_symbol (optname, MELT_CREATE);
+ {
+ union meltparam_un pararg[1];
+ memset (¶rg, 0, sizeof (pararg));
+ pararg[0].meltbp_cstring = optvalue;
+ MELT_LOCATION_HERE ("option set before apply");
+ debugeprintf ("MELT option %s value %s", optname,
+ optvalue?optvalue:"_");
+ optresv =
[PATCH, MELT] pragma support in MELT
Hello,
This patch completes the pragma support in MELT. Now, a plugin can
register several pragmas (with different name) in the following format
(for GCC > 4.6):
#pragma MELT (,...).
This pragma can be easily handle in a MELT function, giving the operator
and the list of arguments as parameters.
For GCC<=4.6, there is a minimal pragma support, we can handle following
pragma:
#pragma GCCPLUGIN melt (,...)
with only melt as name.
ChangeLog:
2011-06-24 Pierre Vittet
* melt-runtime.c (GCC_PRAGMA_BAD): Macro to return an error from the
pragma handling system.
[__GNUC__>4.6](melt_handle_melt_pragma, handle_melt_pragma,
melt_pragma_callback): Add functions for full pragma handling.
[__GNUC__<=4.6](melt_handle_melt_pragma, handle_melt_pragma,
melt_pragma_callback): Add functions for limited pragma handling.
(melt_startunit_callback): Register a callback for pragma.
* Makefile.in (CFAMILYINC): We need c-family header in include
headers.
Index: gcc/Makefile.in
===
--- gcc/Makefile.in (revision 175348)
+++ gcc/Makefile.in (working copy)
@@ -359,6 +359,9 @@ DECNUMFMT = $(srcdir)/../libdecnumber/$(enable_dec
DECNUMINC = -I$(DECNUM) -I$(DECNUMFMT) -I../libdecnumber
LIBDECNUMBER = ../libdecnumber/libdecnumber.a
+#c-family header
+CFAMILYINC=-I$(srcdir)/c-family
+
# Target to use when installing include directory. Either
# install-headers-tar, install-headers-cpio or install-headers-cp.
INSTALL_HEADERS_DIR = @build_install_headers_dir@
@@ -1096,8 +1099,8 @@ INCLUDES = -I. -I$(@D) -I$(srcdir) -I$(srcdir)/$(@
-I$(srcdir)/melt/generated \
-I$(srcdir)/../include @INCINTL@ \
$(CPPINC) $(GMPINC) $(DECNUMINC) \
- $(PPLINC) $(CLOOGINC)
-
+ $(PPLINC) $(CLOOGINC) \
+ $(CFAMILYINC)
.c.o:
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $< $(OUTPUT_OPTION)
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175348)
+++ gcc/melt-runtime.c (working copy)
@@ -74,7 +74,9 @@ along with GCC; see the file COPYING3. If not se
#include "md5.h"
#include "plugin.h"
#include "cppdefault.h"
+#include "c-pragma.h"
+
#if BUILDING_GCC_VERSION > 4005
/* GCC 4.6 has realmpfr.h which includes */
#include "realmpfr.h"
@@ -8938,7 +8940,284 @@ melt_attribute_callback(void *gcc_data ATTRIBUTE_U
register_attribute(&melt_attr_spec);
}
+/* We declare weak functions because they cannot be linked when we use lto (it
+ loses langage specific informations).
+ If you use one of those functions you must check them to be not NULL.
+*/
+extern enum cpp_ttype __attribute__((weak)) pragma_lex (tree *);
+
+
+#define GCC_PRAGMA_BAD(gmsgid) \
+ do { warning (OPT_Wpragmas, gmsgid); goto end; } while (0)
+
+
+
+/* Test for GCC > 4.6.0 */
+#if __GNUC__ > 4 || \
+(__GNUC__ == 4 && (__GNUC_MINOR__ > 6))
+/*Full pragma with data support.*/
+
+void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev,
+ int indice_handler);
+
+extern void __attribute__((weak)) c_register_pragma_with_expansion_and_data
+(const char *space, const char *name,
+ pragma_handler_2arg handler, void *data);
+
+/* handle a melt pragma: data contain the name of the command (as a string)*/
+static void
+handle_melt_pragma (cpp_reader *ARG_UNUSED(dummy), void * data)
+{
+ enum cpp_ttype token;
+ /*list containing the pragma argument*/
+ tree x;
+ int ihandler = (int) data;
+ MELT_ENTERFRAME (3, NULL);
+#define seqv meltfram__.mcfr_varptr[0]
+#define treev meltfram__.mcfr_varptr[1]
+#define optreev meltfram__.mcfr_varptr[2]
+ if(! pragma_lex || ! c_register_pragma_with_expansion_and_data)
+GCC_PRAGMA_BAD("Cannot use pragma symbol at this level \
+ (maybe you use -flto which is incompatible).");
+
+ token = pragma_lex (&x);
+ if(token != CPP_NAME)
+GCC_PRAGMA_BAD ("malformed #pragma melt, ignored");
+ optreev = meltgc_new_tree((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x);
+ /*If the pragma has the form #pragma PLUGIN melt id (...) then optreev is the
+ tree containing "id".
+ Next element should be a parenthese opening. */
+ token = pragma_lex (&x);
+ if (token != CPP_OPEN_PAREN){
+if (token != CPP_EOF)
+ GCC_PRAGMA_BAD ("malformed #pragma melt, ignored");
+
+else{ /* we have a pragma of the type '#pragma PLUGIN melt instr' */
+ melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) NULL,
+ ihandler);
+}
+ }
+ else{/* opening parenthesis */
+seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
+do {
+
[PATCH, MELT] correct meltgc_read_from_val without location
Hello,
The function meltgc_read_from_val (in melt-runtime.c) takes two
arguments, a string value and a second one which is a location.
In the comments, it is written that we can pass a NULL pointer if we
have no location (it is a direct string). However, this conduct MELT to
crash because it doesn't handle correctly the absence of file.
This patch correct this, if there is no file, it create a "virtual" one
which is named "stringBuffer".
Pierre Vittet
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175348)
+++ gcc/melt-runtime.c (working copy)
@@ -6326,7 +6326,7 @@ melt_linemap_compute_current_location (struct read
{
int colnum = 1;
int cix = 0;
- if (!rd || !rd->rcurlin)
+ if (!rd || !rd->rcurlin || !rd->rpfilnam)
return;
for (cix=0; cixrcol; cix++) {
char c = rd->rcurlin[cix];
@@ -6702,13 +6702,22 @@ static melt_ptr_t
makesexpr (struct reading_st *rd, int lineno, melt_ptr_t contents_p,
location_t loc, bool ismacrostring)
{
- MELT_ENTERFRAME (4, NULL);
+ MELT_ENTERFRAME (5, NULL);
#define sexprv meltfram__.mcfr_varptr[0]
#define contsv meltfram__.mcfr_varptr[1]
#define locmixv meltfram__.mcfr_varptr[2]
#define sexpclassv meltfram__.mcfr_varptr[3]
+#define locnamv meltfram__.mcfr_varptr[4]
contsv = contents_p;
gcc_assert (melt_magic_discr ((melt_ptr_t) contsv) == MELTOBMAG_LIST);
+ /* If there is no filename associated, we create a false one, named
+"stringBuffer". */
+ if(rd->rpfilnam == NULL)
+{
+ locnamv = meltgc_new_string ((meltobject_ptr_t)
MELT_PREDEF(DISCR_STRING),
+ "stringBuffer");
+ rd->rpfilnam = (melt_ptr_t *) &locnamv;
+}
if (loc == 0)
locmixv = meltgc_new_mixint ((meltobject_ptr_t) MELT_PREDEF
(DISCR_MIXED_INTEGER),
*rd->rpfilnam, (long) lineno);
@@ -6728,6 +6737,7 @@ makesexpr (struct reading_st *rd, int lineno, melt
meltgc_touch (sexprv);
MELT_EXITFRAME ();
return (melt_ptr_t) sexprv;
+#undef locnamv
#undef sexprv
#undef contsv
#undef locmixv
@@ -8414,6 +8424,7 @@ meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_
strv = strv_p;
locnamv = locnam_p;
rbuf = 0;
+ seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
strmagic = melt_magic_discr ((melt_ptr_t) strv);
switch (strmagic)
{
@@ -8442,7 +8453,10 @@ meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_
rds.rlineno = 0;
rds.rcurlin = rbuf;
rd = &rds;
- rds.rpfilnam = (melt_ptr_t *) & locnamv;
+ if(locnamv == NULL)
+rds.rpfilnam = NULL;
+ else
+rds.rpfilnam = (melt_ptr_t *) & locnamv;
while (rdcurc ())
{
bool got = FALSE;
2011-06-24 Pierre Vittet
* melt-runtime.c (melt_linemap_compute_current_location, makesexpr,
meltgc_read_from_val): Handle the case of reading a string sexp without
given location.
Re: [PATCH, MELT] pragma support in MELT
Hello,
This patch is an improvment of
http://gcc.gnu.org/ml/gcc-patches/2011-06/msg01861.html. It completes
pragma support into MELT. Main changes are mostly comments improvments,
better respect of coding standard and using long instead of int for
pragma index when we have several pragmas being registered. I also
removed the PRAGMA_BAD macro as it was said to be less readable, and
changed malformed pragma warnings into errors.
I tested the patch without seing any error or regression.
Pierre Vittet
2011-07-03 Pierre Vittet
* melt-runtime.c: include c-pragma.h.
[__GNUC__>4.6] (melt_handle_melt_pragma, handle_melt_pragma,
melt_pragma_callback): Add functions for full pragma handling.
[__GNUC__<=4.6] (melt_handle_melt_pragma, handle_melt_pragma,
melt_pragma_callback): Add functions for limited pragma handling.
(melt_really_initialize): Register a callback for pragma.
* Makefile.in (CFAMILYINC): We need c-family header in include headers.
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 175724)
+++ gcc/melt-runtime.c (working copy)
@@ -74,6 +74,7 @@ along with GCC; see the file COPYING3. If not se
#include "md5.h"
#include "plugin.h"
#include "cppdefault.h"
+#include "c-pragma.h"
#if BUILDING_GCC_VERSION > 4005
/* GCC 4.6 has realmpfr.h which includes */
@@ -8982,7 +8983,296 @@ melt_attribute_callback(void *gcc_data ATTRIBUTE_U
register_attribute(&melt_attr_spec);
}
+/* We declare weak functions because they cannot be linked when we use lto (it
+ loses langage specific informations).
+ If you use one of those functions you must check them to be not NULL.
+*/
+extern enum cpp_ttype __attribute__((weak)) pragma_lex (tree *);
+/* Test for GCC > 4.6.0. */
+#if __GNUC__ > 4 || \
+(__GNUC__ == 4 && (__GNUC_MINOR__ > 6))
+/* Full pragma with data support. */
+
+/* Call the MELT function which handle pragma: it is one of the handler of the
+ list sysdata_meltpragmas. First argument is a tree containing the operator
+ and the second argument contains a list of tree (the arguments of the
+ pragma). Third argument is the index of the handler to use (in list
+ sysdata_meltpragmas). */
+void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev,
+ long i_handler);
+
+extern void __attribute__((weak)) c_register_pragma_with_expansion_and_data
+(const char *space, const char *name,
+ pragma_handler_2arg handler, void *data);
+
+/* Handle a melt pragma: data contains the index of the pragma handler. */
+static void
+handle_melt_pragma (cpp_reader *ARG_UNUSED(dummy), void *data)
+{
+ enum cpp_ttype token;
+ /* List containing the pragma arguments . */
+ tree x;
+ long i_handler = (long) data;
+ MELT_ENTERFRAME (3, NULL);
+#define seqv meltfram__.mcfr_varptr[0]
+#define treev meltfram__.mcfr_varptr[1]
+#define optreev meltfram__.mcfr_varptr[2]
+ if (!pragma_lex || !c_register_pragma_with_expansion_and_data)
+fatal_error ("Cannot use pragma symbol at this level \
+ (maybe you use -flto which is incompatible).");
+
+ token = pragma_lex (&x);
+ if (token != CPP_NAME)
+{
+ error ("malformed #pragma melt, ignored");
+ goto end;
+}
+ optreev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x);
+ /* If the pragma has the form #pragma MELT name id (...) then optreev is the
+ tree containing "id". */
+ /* Next element should be a parenthesis opening. */
+ token = pragma_lex (&x);
+ if (token != CPP_OPEN_PAREN)
+{
+ if (token != CPP_EOF)
+ {
+ error ("malformed #pragma melt, ignored");
+ goto end;
+ }
+ else{ /* We have a pragma of the type '#pragma MELT name instr'. */
+ melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) NULL,
+i_handler);
+ }
+}
+ else
+{/* Opening parenthesis. */
+ seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST));
+ do
+ {
+ token = pragma_lex (&x);
+ if(token != CPP_NAME && token != CPP_STRING && token != CPP_NUMBER)
+ {
+ error ("malformed #pragma melt, ignored");
+ goto end;
+ }
+ /* Convert gcc tree into a boxed tree. */
+ treev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE),
+ x);
+ /* Put the arg in IDENTIFIER_POINTER (x) in a list. */
+ meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) treev);
+ token = pragma_lex (&x);
+ } while (
Re: C++ mangling, function name to mangled name (or tree)
On 06/07/2011 18:25, Kevin André wrote: On Wed, Jul 6, 2011 at 18:00, Pierre Vittet wrote: I would like user of the plugin to give in arguments the name of the functions on which he would like a test to be run. That means that I must convert the string containing a function name (like "myclass::init") and get either the mangled name or the tree corresponding to the function. I know that there might be several results (functions with the same name and different arguments), a good policy for me would be to recover every concerned functions (at least for the moment). I guess what I want to do is possible, because there are already some tools doing it (like gdb). Are you absolutely sure about gdb? It could be doing it the other way around, i.e. start from the mangled names in the object file and demangle all of them. Then it would search for a function name in its list of demangled names. Just guessing, though :) Regards, Kevin André Hello, no I am not sure, but I guess it would really have an important cost to do it like you said. Would it no be easier to have a field containing the 'demangled' names? At least in debug since it has an important space complexity. Thanks! Pierre Vittet
[PATCH, MELT] new function register_data_handler
Hi, this patch add a new function allowing to add a pragma handler more
easily. In the past, we were directly modifying the :sysdata_meltpragmas
field of initial_system_data.
The pragma handler take a list of new pragma handler that we want to
add. The reason is that the field :sysdata_meltpragmas is a tuple (fixed
size, this is a mandatory because we uses index to recognize the handler
later). Each time we call register_data_handler, we recreate the tuple,
so we try to give a list of handler to call it not to often.
This function should works with a GCC 4.6 but should be used with care,
as we can only register a single pragma named "melt" (maybe we could use
another function specially for 4.6 ?).
Thanks!
Pierre Vittet
2011-07-07 Pierre Vittet
* melt/warmelt-base.melt (register_pragma_handler ): new function.
Index: gcc/melt/warmelt-base.melt
===
--- gcc/melt/warmelt-base.melt (revision 175906)
+++ gcc/melt/warmelt-base.melt (working copy)
@@ -1135,6 +1135,42 @@ registered with $REGISTER_PASS_EXECUTION_HOOK.}#
}#)
)))
+;;register a new pragma handler.
+(defun register_pragma_handler (lsthandler)
+ :doc #{register a list of new pragma handlers. As :sysdata_meltpragmas must
+ be a tuple (we use an index to recognize handlers), we have to recreate this
+ tuple each time we call this function. That why $LSTHANDLER is a list of
+ handlers (class_gcc_pragma) and not a single object. }#
+ (assert_msg "register_pragma_handler takes a list as argument."
+(is_list lsthandler))
+ (let ((oldtuple (get_field :sysdata_meltpragmas initial_system_data))
+(:long oldsize 0))
+(if notnull oldtuple)
+ (setq oldsize (multiple_length oldtuple))
+(let ((:long newsize (+i (multiple_length oldtuple)
+ (list_length lsthandler)))
+ (newtuple (make_multiple discr_multiple newsize))
+ (:long i 0))
+;;copy in oldhandlers in the newtuple
+(foreach_in_multiple
+(oldtuple)
+(curhander :long iunused)
+ (multiple_put_nth newtuple i curhander)
+ (setq i (+i i 1))
+)
+;;add new handler from lsthandler
+(foreach_in_list
+(lsthandler)
+(curpair curhandler)
+ (assert_msg "register_pragma_handler must be a list of class_gcc_pragma."
+(is_a curhandler class_gcc_pragma))
+ (multiple_put_nth newtuple i curhandler)
+ (setq i (+i i 1))
+)
+(put_fields initial_system_data :sysdata_meltpragmas newtuple)
+))
+)
+
the descriptions of values which are not ctype related.
(defclass class_value_descriptor
@@ -2361,6 +2397,7 @@ polyhedron values.}#
ppstrbuf_mixbigint
read_file
register_pass_execution_hook
+ register_pragma_handler
retrieve_value_descriptor_list
some_integer_greater_than
some_integer_multiple
[PATH, MELT] correct makefile, install-default-module-list
Hello, To compile the last revision of the MELT branch, I have been obliged to do the following change in the Makefile: We were trying to install the file gcc/melt-default-modules which doesn't exist, we now install melt-default-modules.modlis. The loops installing the different /melt-default-modules-*.modlis was incorrect, a ';' was missing in the install instruction. Pierre Vittet 2011-07-15 Pierre Vittet * Makefile.in (install-melt-default-modules-list): Fix bad file call. Index: gcc/Makefile.in === --- gcc/Makefile.in (revision 176307) +++ gcc/Makefile.in (working copy) @@ -5473,9 +5473,9 @@ install-melt-mk: melt-module.mk ## install the default modules list install-melt-default-modules-list: $(melt_default_modules_list).modlis $(wildcard $(melt_default_modules_list)-*.modlis) - $(INSTALL_DATA) $(melt_default_modules_list) $(DESTDIR)/$(melt_module_dir) - for f in $(wildcard $(melt_default_modules_list)-*.modlis) ; do \ - $(INSTALL_DATA) $$f $(DESTDIR)/$(melt_module_dir) \ + $(INSTALL_DATA) $(melt_default_modules_list).modlis $(DESTDIR)/$(melt_module_dir) + for f in $(wildcard $(melt_default_modules_list)-*.modlis) ; do \ + $(INSTALL_DATA) $$f $(DESTDIR)/$(melt_module_dir); \ done this phony target is given manually to copy the generated
[PATCH, MELT] Add PRE_GENERICIZE callback support in MELT
Hello, The following patch add support for PLUGIN_PRE_GENERICIZE callback. The add_sysdata_pre_genericize patch add a field (sysdata_pre_genericize) in initial system data, allowing to register a closure to be called on PLUGIN_PRE_GENERICIZE event. This patch must be first applied and a make warmelt-upgrade must be run in order to regenerate generated melt files. The add_pre_genericize_hook patch add a function (in melt-runtime.c) to be called on PLUGIN_PRE_GENERICIZE, which call the closure sysdata_pre_genericize defined by the users. Thanks Pierre Vittet 2011-07-15 Pierre Vittet * melt-runtime.h (enum FSYDAT*): Add a FSYSDAT_PRE_GENERICIZE field. * melt/warmelt-first.melt (class_system_data): add a sysdata_pre_genericize field. Index: gcc/melt/warmelt-first.melt === --- gcc/melt/warmelt-first.melt (revision 176032) +++ gcc/melt/warmelt-first.melt (working copy) @@ -441,6 +441,8 @@ don't instanciate this class!}# sysdata_stdout ;raw file for stdout sysdata_stderr ;raw file for stderr sysdata_dumpfile ;raw file for dump_file + sysdata_pre_genericize ;closure to be called for PLUGIN_PRE_GENERICIZE: + ;look at gcc/c-decl.c. sysdata_unit_starter ;closure to be called at ;compilation unit start sysdata_unit_finisher;closure to be called at Index: gcc/melt-runtime.h === --- gcc/melt-runtime.h (revision 176032) +++ gcc/melt-runtime.h (working copy) @@ -2324,6 +2324,7 @@ enum FSYSDAT_STDOUT, /* raw boxed file for stdout */ FSYSDAT_STDERR, /* raw boxed file for stderr */ FSYSDAT_DUMPFILE,/* raw boxed file for dump_file */ + FSYSDAT_PRE_GENERICIZE, /* closure for PLUGIN_PRE_GENERICIZE */ FSYSDAT_UNIT_STARTER,/* closure for start of compilation unit */ FSYSDAT_UNIT_FINISHER,/* closure for start of compilation unit */ FSYSDAT_OPTION_SET, /* closure to set options */ 2011-07-15 Pierre Vittet * melt-runtime.c (melt_really_initialize): Register a new Callback to PLUGIN_PRE_GENERICIZE. (melt_pre_genericize_callback): New function, use field sysdata_pre_genericize to transmit the callbacks. 2011-07-15 Pierre Vittet * melt-runtime.c (melt_really_initialize): Register a new Callback to PLUGIN_PRE_GENERICIZE. (melt_pre_genericize_callback): New function, use field sysdata_pre_genericize to transmit the callbacks.
Re: [PATCH, MELT] Add PRE_GENERICIZE callback support in MELT
Right, here is the new version of the patch (with the correct files).
I added, a function register_pre_genericize_hook in
melt/warmelt-base.melt to be called when we want to register a MELT
function to handle the callback, so we don't manually set
sysdata_pre_genericize field.
Pierre Vittet
On 15/07/2011 18:41, Romain Geissler wrote:
Le 15 juil. 2011 à 18:17, Pierre Vittet a écrit :
Hello,
The following patch add support for PLUGIN_PRE_GENERICIZE callback.
The add_sysdata_pre_genericize patch add a field (sysdata_pre_genericize) in
initial system data, allowing to register a closure to be called on
PLUGIN_PRE_GENERICIZE event. This patch must be first applied and a make
warmelt-upgrade must be run in order to regenerate generated melt files.
The add_pre_genericize_hook patch add a function (in melt-runtime.c) to be
called on PLUGIN_PRE_GENERICIZE, which call the closure sysdata_pre_genericize
defined by the users.
Thanks
Pierre Vittet
Great !
You forgot to attach the patch for melt-runtime.c (there is only the changelog)
I know your performing some simple static analysis, mostly based on matching
some c source code patterns (check that there is a if (fopen_result) just after
a fopen.
Is there a particular reason to do that as a pass (so at the gimple level)
rather that doing it just after the function has been parsed (eg upon
PLUGIN_PRE_GENERICIZE) ?
2011-07-15 Pierre Vittet
* melt-runtime.h (enum FSYDAT*): Add a FSYSDAT_PRE_GENERICIZE field.
* melt/warmelt-first.melt (class_system_data): add a
sysdata_pre_genericize field.
Index: gcc/melt/warmelt-first.melt
===
--- gcc/melt/warmelt-first.melt (revision 176032)
+++ gcc/melt/warmelt-first.melt (working copy)
@@ -441,6 +441,8 @@ don't instanciate this class!}#
sysdata_stdout ;raw file for stdout
sysdata_stderr ;raw file for stderr
sysdata_dumpfile ;raw file for dump_file
+ sysdata_pre_genericize ;closure to be called for
PLUGIN_PRE_GENERICIZE:
+ ;look at gcc/c-decl.c.
sysdata_unit_starter ;closure to be called at
;compilation unit start
sysdata_unit_finisher;closure to be called at
Index: gcc/melt-runtime.h
===
--- gcc/melt-runtime.h (revision 176032)
+++ gcc/melt-runtime.h (working copy)
@@ -2324,6 +2324,7 @@ enum
FSYSDAT_STDOUT, /* raw boxed file for stdout */
FSYSDAT_STDERR, /* raw boxed file for stderr */
FSYSDAT_DUMPFILE,/* raw boxed file for dump_file */
+ FSYSDAT_PRE_GENERICIZE, /* closure for PLUGIN_PRE_GENERICIZE */
FSYSDAT_UNIT_STARTER,/* closure for start of compilation
unit */
FSYSDAT_UNIT_FINISHER,/* closure for start of compilation unit */
FSYSDAT_OPTION_SET, /* closure to set options */
2011-07-15 Pierre Vittet
* melt-runtime.c (melt_really_initialize): Register a new Callback to
PLUGIN_PRE_GENERICIZE.
(melt_pre_genericize_callback): New function, use field
sysdata_pre_genericize to transmit the callbacks.
* melt/warmelt-base.melt (register_pre_genericize_hook): New function.
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 176032)
+++ gcc/melt-runtime.c (working copy)
@@ -9044,6 +9044,35 @@ melt_pragma_callback (void *gcc_data ATTRIBUTE_UNU
#endif /*GCC >4.6 for handling pragma support*/
+
+/* This function is used when PLUGIN_PRE_GENERICIZE callback is invoked. It
+ calls the closure registered in field sydata_pre_genericize of
+ initial_system_data. The first argument is the tree containing the function
+ declaration (as given in file gcc/c-decl.c). */
+static void
+melt_pre_genericize_callback (void *ptr_fndecl,
+ void *user_data ATTRIBUTE_UNUSED)
+{
+ MELT_ENTERFRAME (2, NULL);
+#define pregenclosv meltfram__.mcfr_varptr[0]
+#define fndeclv meltfram__.mcfr_varptr[1]
+ fndeclv = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE),
+((tree) ptr_fndecl));
+ pregenclosv = melt_get_inisysdata (FSYSDAT_PRE_GENERICIZE);
+ if (melt_magic_discr ((melt_ptr_t) pregenclosv) == MELTOBMAG_CLOSURE)
+{
+ MELT_LOCATION_HERE
+ ("melt_pre_genericize befire applying pre_genericize closure");
+ (void) melt_apply ((meltclosure_ptr_t) pregenclosv, (melt_ptr_t) fndeclv,
+"", NULL, "", NULL);
+}
+ MELT_EXITFRAME ();
+#undef fndeclv
+#undef pregenclosv
+}
+
+
+
/* the plugin callback when starting a compilation unit */
static void
melt_startunit_callback(void *gc
[PATCH, MELT, minor] add a primitive read_strv
Hello,
This minor patch add a primitive to get a list of s-expression from a
boxed C string of a strbuf.
This is only the MELT part, as the called C code was already written.
I compiled and test it.
Thanks!
Pierre Vittet
2011-07-18 Pierre Vittet
* melt/warmelt-base.melt (read_strv): New primitive.
Index: gcc/melt/warmelt-base.melt
===
--- gcc/melt/warmelt-base.melt (revision 176434)
+++ gcc/melt/warmelt-base.melt (working copy)
@@ -272,6 +272,11 @@ number $NUM opaque location number $LOC.}#
:doc #{Read from file named by the $FILNAM string balue a list of MELT
s-expressions.}#
#{(meltgc_read_file (melt_string_str((melt_ptr_t)($filnam)), (char*)0))}#)
+(defprimitive read_strv (strv) :value
+ :doc #{Return the list of sexpr contained in $STRV. $STRV can be a boxed
+ string or a strbuf value.}#
+ #{(meltgc_read_from_val ($strv, NULL))}#
+)
;; to signal an error in a source with some additional string value
(defprimitive error_strv (loc :cstring cmsg :value strv) :void
@@ -2441,6 +2446,7 @@ polyhedron values.}#
pair_set_head
ppstrbuf_mixbigint
read_file
+ read_strv
register_pass_execution_hook
register_pragma_handler
register_pre_genericize_hook
[PATCH, MELT] correct function meltgc_string_hex_md5sum_file_sequence
Hello,
this patch correct the function meltgc_string_hex_md5sum_file_sequence,
it now returns the same than "cat myfile1 myfile2 ... | md5sum".
fread was not correctly used + it looks like you can't mix function
md5_process_bytes and md5_process_blocks.
Pierre Vittet
Index: gcc/melt-runtime.c
===
--- gcc/melt-runtime.c (revision 176817)
+++ gcc/melt-runtime.c (working copy)
@@ -5426,6 +5426,7 @@ meltgc_string_hex_md5sum_file_sequence (melt_ptr_t
char bufblock[1024]; /* size should be multiple of 64 for md5_process_block
*/
FILE *fil = NULL;
int nbtup = 0;
+ int cnt = 0;
struct md5_ctx ctx = {};
MELT_ENTERFRAME(3, NULL);
#define resv meltfram__.mcfr_varptr[0]
@@ -5456,16 +5457,14 @@ meltgc_string_hex_md5sum_file_sequence (melt_ptr_t
while (!feof (fil))
{
memset (bufblock, 0, sizeof (bufblock));
- if (fread (bufblock, sizeof(bufblock), 1, fil)==1)
+ cnt = fread (bufblock, 1, sizeof(bufblock), fil);
+ if (cnt ==sizeof(bufblock))
{
/* an entire block has been read. */
- md5_process_block (bufblock, sizeof(bufblock), &ctx);
+ md5_process_bytes (bufblock, sizeof(bufblock), &ctx);
}
else
{
- int cnt = fread (bufblock, 1, sizeof(bufblock), fil);
- if (cnt <= 0)
- break;
md5_process_bytes (bufblock, (size_t) cnt, &ctx);
}
}
2011-07-27 Pierre Vittet
* melt-runtime.c (meltgc_string_hex_md5sum_file_sequence):
Correct fread use + only use md5_process_bytes
[PATCH, MELT] fix useless forcing of GCC garbage collector
This patch is for the MELT branch.
My GCC contributor number is 634276.
After speaking with Basile Starynkevitch, we saw that there might be a
useless forcing of the garbage collector in melt-runtime.c . I tested
with the patch, and I haven't seen any problem (I could compile GCC,
using a MELT plugin with the patched version).
I have also measured a small time improvement while compiling the file
gcc.c (which is more that 8000 lines):
Whithout the modification:
usersys
1.563 0.145s
With the modification:
usersys
1.144 0.106s
Changelog:
2011-05-09 Pierre Vittet
* melt-runtime.c: Remove variable forcing the garbage collector while
it was not needed.
Thanks
Pierre Vittet
Index: melt-runtime.c
===
--- melt-runtime.c (revision 173571)
+++ melt-runtime.c (working copy)
@@ -1159,16 +1159,13 @@
melt_nb_garbcoll, melt_startalz, melt_endalz);
if (needfull)
{
- bool wasforced = ggc_force_collect;
melt_nb_full_garbcoll++;
debugeprintf ("melt_garbcoll #%ld fullgarbcoll #%ld",
melt_nb_garbcoll, melt_nb_full_garbcoll);
/* force major collection, with our callback */
- ggc_force_collect = true;
- debugeprintf ("melt_garbcoll forcing fullgarbcoll #%ld",
melt_nb_full_garbcoll);
+ debugeprintf ("melt_garbcoll calling gcc_collect #%ld",
melt_nb_full_garbcoll);
ggc_collect ();
- ggc_force_collect = wasforced;
- debugeprintf ("melt_garbcoll forced fullgarbcoll #%ld",
melt_nb_full_garbcoll);
+ debugeprintf ("melt_garbcoll after fullgarbcoll #%ld",
melt_nb_full_garbcoll);
/* Delete the unmarked specials. */
prevspecptr = &melt_oldspeclist;
for (specp = melt_oldspeclist; specp; specp = nextspecp)
Re: [PATCH, MELT] fix useless forcing of GCC garbage collector
Thanks you for the correction, I will take care next time. Pierre On 09/05/2011 19:03, Basile Starynkevitch wrote: On Mon, 09 May 2011 14:15:30 +0200 Pierre Vittet wrote: This patch is for the MELT branch. The diff file was slightly wrong (diff run under gcc/). Pierre, you should run svn diff -x -p at the top source directory to get a patch file. I applied the patch. The gcc/ChangeLog.MELT proposed by Pierre was wrong, I wrote: 2011-05-09 Pierre Vittet * melt-runtime.c (melt_garbcoll): Don't force collection by gcc_collect. Committed revision 173576. Folks, what is the procedure to get Pierre an svn+ssh write access to GCC svn server (mostly for the MELT branch, and write after approval for the rest). As far as I understood, all legal stuff has been completed. My GCC contributor number is 634276. This is the copyright assignment legal document reference for Pierre Vittet. What does he (or me) have to do to get svn+ssh://gcc.melt.org/ write access? Cheers.
Re: [PATCH] comment precising need to use free_dominance_info
So maybe this patch adding a comment on calculate_dominance_info is more
adapted.
ChangeLog:
2011-05-17 Pierre Vittet
* dominance.c (calculate_dominance_info): Add comment
precising when to free with free_dominance_info
contributor number: 634276
Index: gcc/dominance.c
===
--- gcc/dominance.c (revision 173830)
+++ gcc/dominance.c (working copy)
@@ -628,8 +628,15 @@ compute_dom_fast_query (enum cdi_direction dir)
}
/* The main entry point into this module. DIR is set depending on whether
- we want to compute dominators or postdominators. */
+ we want to compute dominators or postdominators.
+ We try to keep dominance info alive as long as possible (to avoid
+ recomputing it often). It has to be freed with free_dominance_info when CFG
+ transformation makes it invalide.
+
+ post_dominance info is less often used, and should be freed after each use.
+*/
+
void
calculate_dominance_info (enum cdi_direction dir)
{
[PATCH, MELT] correcting path error in the Makefile.in
This patch correct a bug in the current revision of MELT, which was preventing MELT to run correctly. This was a path problem in gcc/Makefile.in (melt-modules/ and melt-modules.mk) were not found. My contributor number is 634276. changelog : 2011-05-17 Pierre Vittet * Makefile.in : Correct path errors for melt_module_dir and for install-melt-mk target Index: gcc/Makefile.in === --- gcc/Makefile.in (revision 173832) +++ gcc/Makefile.in (working copy) @@ -5352,7 +5352,7 @@ melt_default_modules_list=melt-default-modules melt_source_dir=$(libexecsubdir)/melt-source/ ## this is the installation directory of melt dynamic modules (*.so) -melt_module_dir=$(libexecsubdir)/melt-module/ +melt_module_dir=$(libexecsubdir)/melt-modules/ ## this is the installed path of the MELT module makefile melt_installed_module_makefile=$(libexecsubdir)/melt-module.mk @@ -5416,8 +5416,8 @@ install-melt-modules: melt-modules melt-all-module ## install the makefile for MELT modules install-melt-mk: melt-module.mk - $(mkinstalldirs) $(DESTDIR)$(plugin_includedir) - $(INSTALL_DATA) $< $(DESTDIR)/$(plugin_includedir)/ + $(mkinstalldirs) $(DESTDIR)$(libexecsubdir) + $(INSTALL_DATA) $< $(DESTDIR)/$(libexecsubdir)/ ## install the default modules list install-melt-default-modules-list: $(melt_default_modules_list).modlis
[PATCH, MELT] add dominance functions
Hello,
I have written a patch to allow the use of the GCC dominance functions
into MELT.
This is made in order to abstract the use of calculate_dominance_info
and free_dominance_info:
If the user use one of the MELT dominance related functions, it
will only call calculate_dominance_info and register a call to
free_dominance_info (at the end of the MELT pass) if the dominance info
were not previously calculated.
The idea is :
- dominance info were already calculated (in a previous pass):
-we can use dominance info and at the end of pass, no call is
made to free_dominance_info (as we expect a next pass to use dominance
info and to free only when necessary).
-dominance info were not already calculated:
-We first compute dominance info, use them during the pass and
free them at the end of the plugin pass (as we don't expect a next pass
to use it).
Unsafe functions are only for internal use and so are not exported.
I have compiled GCC MELT with the patch and successfully test the functions.
Changelog:
2011-05-17 Pierre Vittet
* melt/xtramelt-ana-base.melt
(is_dominance_info_available, is_post_dominance_info_available,
calculate_dominance_info_unsafe,
calculate_post_dominance_info_unsafe,
free_dominance_info, free_post_dominance_info,
calculate_dominance_info,
calculate_post_dominance_info, debug_dominance_info,
debug_post_dominance_info, get_immediate_dominator_unsafe,
get_immediate_dominator, get_immediate_post_dominator_unsafe,
get_immediate_post_dominator, dominated_by_other_unsafe,
dominated_by_other, post_dominated_by_other_unsafe,
post_dominated_by_other, foreach_dominated_unsafe,
dominated_by_bb_iterator): Add primitives, functions, iterators for
using dominance info.
Index: gcc/melt/xtramelt-ana-base.melt
===
--- gcc/melt/xtramelt-ana-base.melt (revision 173832)
+++ gcc/melt/xtramelt-ana-base.melt (working copy)
@@ -1910,6 +1910,242 @@
(defprimitive basicblock_nth_succ_edge (:basic_block bb :long ix) :edge
#{(($bb && $ix>=0 && $ixsuccs))?EDGE_SUCC($bb,$ix):NULL)}#)
+;Primitives concerning dominance in basic_blocks
+;those functions mainly come from gcc/dominance.c
+
+(defprimitive is_dominance_info_available () :long
+ :doc #{Check if dominance info are already calculated.
+User normally doesn't have to call this primitive, as MELT functions
+check if there is a need to use this.
+}#
+ #{dom_info_available_p(CDI_DOMINATORS)}#
+)
+
+(defprimitive is_post_dominance_info_available () :long
+ :doc #{Check if post dominance info are already calculated.
+User normally doesn't have to call this primitive, as MELT functions
+check if there is a need to use this.
+ }#
+ #{dom_info_available_p(CDI_POST_DOMINATORS)}#
+)
+
+(defprimitive calculate_dominance_info_unsafe() :void
+ :doc #{This primitive is internaly called, user doesn't need it.
+Build the struct containing dominance info.
+This struct is necessary to use others dominance related function.
+This function is unsafe because it does not register any future call to
+free_dominance_info.
+}#
+ #{calculate_dominance_info(CDI_DOMINATORS)}#
+)
+
+(defprimitive calculate_post_dominance_info_unsafe () :void
+ :doc #{This primitive is internaly called, user doesn't need it.
+Build the struct containing post dominance info.
+This struct is necessary to use other dominance related function.
+This function is unsafe because it does not register any future call to
+free_dominance_info.
+}#
+ #{calculate_dominance_info(CDI_POST_DOMINATORS)}#
+)
+
+(defprimitive free_dominance_info () :void
+ :doc #{This primitive is internaly called, user doesn't need it.
+ Clear dominance info if they have been allocated.
+ }#
+ #{free_dominance_info(CDI_DOMINATORS)}#
+)
+
+(defprimitive free_post_dominance_info () :void
+ :doc #{This primitive is internaly called, user doesn't need it.
+ Clear post dominance info if they have been allocated.
+ }#
+ #{free_dominance_info(CDI_POST_DOMINATORS)}#
+)
+
+(defun calculate_dominance_info()
+ :doc #{This primitive is internaly called, user doesn't need it.
+ Build the struct containing dominance info.
+ This struct is necessary to use other dominance related info.
+ It place a call to free dominance info when pass is finished if it is
+ necessary.
+ }#
+ (if (is_dominance_info_available)
+() ;; do nothing
+(progn ;; else calculate dom and ask to free them at end of pass
+ (calculate_dominance_info_unsafe)
+ (at_end_melt_pass_first free_dominance_info)
+))
+)
+
+(defun calculate_post_dominance_info ()
+ :doc #{This primitive is internaly called, user doesn't need it
+ Build the struct containing post dominance info.
+ This struct is necessary to use other p
Re: [PATCH, MELT] add dominance functions
I have corrected my patch with your remarks.
Especially about the debug functions, it takes the debug melt flag into
account. Moreover, I have allowed the user to give a message when
calling this function, as usual in MELT debug functions. Giving this
message was a bit difficult (This is the only argument of the function,
so this must be a MELT value, and that uneasy to convert the value into
:cstring).
I have used debugeprintf macro into a code_chunk to give the MELT file +
line numbers, followed by a outstr_err, which displays the user message.
I think the only disavantage is that it puts an end of lines between the
two informations. If you think there is a best way to do this, I am ok
to try it.
The new changelog:
2011-05-20 Pierre Vittet
* melt/xtramelt-ana-base.melt
(is_dominance_info_available, is_post_dominance_info_available,
calculate_dominance_info_unsafe, calculate_post_dominance_info_unsafe,
free_dominance_info, free_post_dominance_info,
calculate_dominance_info,
calculate_post_dominance_info, debug_dominance_info,
debug_post_dominance_info, get_immediate_dominator_unsafe,
get_immediate_dominator, get_immediate_post_dominator_unsafe,
get_immediate_post_dominator, dominated_by_other_unsafe,
dominated_by_other, post_dominated_by_other_unsafe,
post_dominated_by_other, foreach_dominated_unsafe,
dominated_by_bb_iterator): Add primitives, functions, iterators for
using
dominance info.
On 19/05/2011 07:32, Basile Starynkevitch wrote:
On Wed, 18 May 2011 21:04:39 +0200
Pierre Vittet wrote:
Hello,
I have written a patch to allow the use of the GCC dominance functions
into MELT.
[...]
Changelog:
2011-05-17 Pierre Vittet
* melt/xtramelt-ana-base.melt
(is_dominance_info_available, is_post_dominance_info_available,
calculate_dominance_info_unsafe,
calculate_post_dominance_info_unsafe,
free_dominance_info, free_post_dominance_info,
calculate_dominance_info,
calculate_post_dominance_info, debug_dominance_info,
debug_post_dominance_info, get_immediate_dominator_unsafe,
get_immediate_dominator, get_immediate_post_dominator_unsafe,
get_immediate_post_dominator, dominated_by_other_unsafe,
dominated_by_other, post_dominated_by_other_unsafe,
post_dominated_by_other, foreach_dominated_unsafe,
dominated_by_bb_iterator): Add primitives, functions, iterators for
using dominance info.
Thanks for the patch. Some minor tweaks:
First, put a space between formal arguments list& function name.
So
+(defprimitive calculate_dominance_info_unsafe() :void
should be
+(defprimitive calculate_dominance_info_unsafe () :void
Then, please put the defined name on the same line that defprimitive or
defun or def... When consecutive MELT formals have the same ctype, you
don't need to repeat it
So
+(defprimitive
+ dominated_by_other_unsafe(:basic_block bbA :basic_block bbB) :long
should be
+(defprimitive dominated_by_other_unsafe (:basic_block bbA bbB) :long
In :doc strings, document when something is a boxed value
(distinction between values& stuffs is crucial), so write instead
[I added the boxed word, it is important]
+(defun get_immediate_dominator (bb)
+ :doc#{Return the next immediate dominator of the boxed basic_block
$BB as a MELT +value.}#
At last, all debug* operations should only output debug to stderr only
when flag_melt_debug is set and give the MELT source position (because
we don't want any debug printing in the usual case when -fmelt-debug is
not given to our cc1) Look at debugloop in xtramelt-ana-base.melt for
an example (notice that debugeprintfnonl is a C macro printing the MELT
source position.
So please resubmit a slightly improved patch.
Regards.
Index: gcc/melt/xtramelt-ana-base.melt
===
--- gcc/melt/xtramelt-ana-base.melt (revision 173936)
+++ gcc/melt/xtramelt-ana-base.melt (working copy)
@@ -1871,7 +1871,6 @@
(defprimitive make_basicblock (discr :basic_block bb) :value
#{/*make_basicblock*/(meltgc_new_basicblock((meltobject_ptr_t)($discr),($bb)))}#
)
-
(defprimitive basicblock_content (v) :basic_block
#{(melt_basicblock_content((melt_ptr_t)($v)))}# )
@@ -1910,6 +1909,243 @@
(defprimitive basicblock_nth_succ_edge (:basic_block bb :long ix) :edge
#{(($bb && $ix>=0 && $ixsuccs))?EDGE_SUCC($bb,$ix):NULL)}#)
+;; Primitives concerning dominance in basic_blocks
+;; those functions mainly come from gcc/dominance.c
+
+(defprimitive is_dominance_info_available () :long
+ :doc #{Check if dominance info are already calculated.
+User normally doesn't have to call this primitive, as MELT functions
+check if there is a need to use this.}#
+ #{dom_info_available_p(CDI_DOMINATORS)}#
+)
+
+(defprimitive is_post_dominance_info_available () :long
+ :doc #{Check if
[Patch] get an order number on -fdump-tree-all
Hello,
When we use fdump-tree-all, we get the dump file, however there is no
way to know in which order the pass was executed.
We can use gdb with a breakpoint at the good position (something like
execute_one_pass), however this solution is not satisfiying for plugin
devellopers for exemple.
There is a number in the name of the dumpped file but from what I know
it is a static number related to the pass but it has nothing to do with
the order in which it is executed.
I would enjoy to have a number, giving the pass position, something like :
1.cfile.c.XXXt.pass
I have make a small change in tree-dump.c in order to have this working
with -fdump-tree-all (patch file in attachment)
The drawback is that, as the pass is called for each function, we get a
different file for each function, while it was written in the same file
previously.
I am also surprized to see that the function print_current_pass is only
called on a fail and that debug_pass doesn't appear to be called at all.
Maybe in DEBUG, or at least with an f*_dump_all, we could print the
order of the pass.
thanks
Pierre Vittet
Index: gcc/tree-dump.c
===
--- gcc/tree-dump.c (revision 171340)
+++ gcc/tree-dump.c (working copy)
@@ -925,21 +925,35 @@
struct dump_file_info *dfi;
FILE *stream;
+ /*allow to know how many pass have already been explored*/
+ static int nb_explored_pass = 0;
+ /*add to the name a position at which the pass is explored*/
+ char * name_with_pass_pos;
+ int name_with_pass_pos_size;
+
if (phase == TDI_none || !dump_enabled_p (phase))
return NULL;
name = get_dump_file_name (phase);
+ name_with_pass_pos_size=sizeof(char)*strlen(name)+
sizeof(nb_explored_pass)+1;
+ name_with_pass_pos= (char*) xmalloc(name_with_pass_pos_size);
+
+ snprintf (name_with_pass_pos, name_with_pass_pos_size, "%d.%s",
nb_explored_pass, name);
dfi = get_dump_file_info (phase);
- stream = fopen (name, dfi->state < 0 ? "w" : "a");
+ stream = fopen (name_with_pass_pos, dfi->state < 0 ? "w" : "a");
+
if (!stream)
error ("could not open dump file %qs: %m", name);
else
dfi->state = 1;
free (name);
+ free (name_with_pass_pos);
if (flag_ptr)
*flag_ptr = dfi->flags;
+ nb_explored_pass++;
+
return stream;
}
[PATCH] build: Check for cargo when building rust language
From: Pierre-Emmanuel Patry
Hello,
The rust frontend requires cargo to build some of it's components,
it's presence was not checked during configuration.
Best regards,
Pierre-Emmanuel
--
Prevent rust language from building when cargo is
missing.
config/ChangeLog:
* acx.m4: Add a macro to check for rust
components.
ChangeLog:
* configure: Regenerate.
* configure.ac: Emit an error message when cargo
is missing.
Signed-off-by: Pierre-Emmanuel Patry
---
config/acx.m4 | 11 +
configure | 117 ++
configure.ac | 18
3 files changed, 146 insertions(+)
diff --git a/config/acx.m4 b/config/acx.m4
index 7efe98aaf96..3c5fe67342e 100644
--- a/config/acx.m4
+++ b/config/acx.m4
@@ -424,6 +424,17 @@ else
fi
])
+# Test for Rust
+# We require cargo and rustc for some parts of the rust compiler.
+AC_DEFUN([ACX_PROG_CARGO],
+[AC_REQUIRE([AC_CHECK_TOOL_PREFIX])
+AC_CHECK_TOOL(CARGO, cargo, no)
+if test "x$CARGO" != xno; then
+ have_cargo=yes
+else
+ have_cargo=no
+fi])
+
# Test for D.
AC_DEFUN([ACX_PROG_GDC],
[AC_REQUIRE([AC_CHECK_TOOL_PREFIX])
diff --git a/configure b/configure
index 874966fb9f0..46e66e20197 100755
--- a/configure
+++ b/configure
@@ -714,6 +714,7 @@ PGO_BUILD_GEN_CFLAGS
HAVE_CXX11_FOR_BUILD
HAVE_CXX11
do_compare
+CARGO
GDC
GNATMAKE
GNATBIND
@@ -5786,6 +5787,104 @@ else
have_gdc=no
fi
+
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}cargo", so it can be a program
name with args.
+set dummy ${ac_tool_prefix}cargo; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CARGO+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$CARGO"; then
+ ac_cv_prog_CARGO="$CARGO" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ac_cv_prog_CARGO="${ac_tool_prefix}cargo"
+$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext"
>&5
+break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+CARGO=$ac_cv_prog_CARGO
+if test -n "$CARGO"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CARGO" >&5
+$as_echo "$CARGO" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_CARGO"; then
+ ac_ct_CARGO=$CARGO
+ # Extract the first word of "cargo", so it can be a program name with args.
+set dummy cargo; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CARGO+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_CARGO"; then
+ ac_cv_prog_ac_ct_CARGO="$ac_ct_CARGO" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ac_cv_prog_ac_ct_CARGO="cargo"
+$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext"
>&5
+break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_CARGO=$ac_cv_prog_ac_ct_CARGO
+if test -n "$ac_ct_CARGO"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CARGO" >&5
+$as_echo "$ac_ct_CARGO" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_CARGO" = x; then
+CARGO="no"
+ else
+case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not
prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet"
>&2;}
+ac_tool_warned=yes ;;
+esac
+CARGO=$ac_ct_CARGO
+ fi
+else
+ CARGO="$ac_cv_prog_CARGO"
+fi
+
+if test "x$CARGO" != xno; then
+ have_cargo=yes
+else
+ have_cargo=no
+fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to compare bootstrapped
objects" >&5
$as_echo_n "checking how to compare bootstrapped objects... " >&
Re: libgrust: 'AM_ENABLE_MULTILIB' only for target builds [PR113056]
Hello Thomas, On 12/18/23 17:58, Thomas Schwinge wrote: --- a/libgrust/configure.ac +++ b/libgrust/configure.ac -# AM_ENABLE_MULTILIB(, ..) +AM_ENABLE_MULTILIB(, ..) Such a change was applied eventually, and is necessary for target builds -- but potentially harmful for host builds. OK to push the attached "libgrust: 'AM_ENABLE_MULTILIB' only for target builds [PR113056]"? These changes make sense, I'm fine with those being pushed. Regards, -- Patry Pierre-Emmanuel Compiler Engineer - Embecosm OpenPGP_0xD006124B2A7AEA23.asc Description: OpenPGP public key OpenPGP_signature.asc Description: OpenPGP digital signature
Re: build: Don't check for host-prefixed 'cargo' program
Hi, On 4/15/24 1:50 PM, Thomas Schwinge wrote: I now wonder: instead of 'AC_CHECK_TOOL', shouldn't this use 'AC_CHECK_PROG'? (We always want plain 'cargo', not host-prefixed 'aarch64-linux-gnu-cargo' etc., right?) I'll look into changing this. This is a mistake, we should use 'AC_CHECK_PROG'. OK to push "build: Don't check for host-prefixed 'cargo' program", see attached? Yes, attached patch looks good, thank you! Regards, -- Patry Pierre-Emmanuel Compiler Engineer - Embecosm
Re: build: Use of cargo not yet supported here in Canadian cross configurations
Hello, On 4/15/24 2:44 PM, Thomas Schwinge wrote: On top of that, OK to push the attached "build: Use of cargo not yet supported here in Canadian cross configurations"? This additional patch looks good. I wonder whether we should enable canadian cross in the future with cargo or simply wait for gcc to be able to compile those components entirely. Regards, -- Patry Pierre-Emmanuel Compiler Engineer - Embecosm OpenPGP_0xD006124B2A7AEA23.asc Description: OpenPGP public key OpenPGP_signature.asc Description: OpenPGP digital signature
Re: [PATCH, Ada] RISC-V: Initial riscv linux Ada port.
On 07/08/2018 12:35 AM, Eric Botcazou wrote:
I haven't tried looking at the failures yet, and might not spend much
more time on this. Two of them are debug related, and debug support
is a work in progress. I need to finish the native riscv64-linux
support before we can do anything useful there, and I'd like to get
back to working on that as soon as possible.
No clue about debug11.adb, maybe Pierre-Marie could shed some light on it.
I don’t have much more to say than debug11.adb’s comment ;-)
This testcase checks that in the DWARF description of the variant type
below, the C discriminant is properly described as unsigned, hence the 0x5a
('Z') and 0x80 (128) values in the DW_AT_discr_list attribute. If it was
described as signed, we would have instead 90 and -128.
I don’t have an Ada RISC-V compiler (nor binutils) to check right now:
would it be possible to send the corresponding debug11.s and debug11.o?
Hopefully we just have to enhance the regexps.
--
Pierre-Marie de Rodat
Re: [PATCH, Ada] RISC-V: Initial riscv linux Ada port.
On 07/13/2018 01:57 AM, Jim Wilson wrote: I poked at this a little and noticed a difference between the x86_64 support and the RISC-V support. The RISC-V C language port has char as unsigned by default. The x86_64 port has char signed by default. If I add a -fsigned-char option, then the testcase works as expected for RISC-V. Curiously, the Ada compiler accepts -fsigned-char but not -funsigned-char. I tried hacking in a -funsigned-char flag, but when I use it with the x86_64 port the result is still correct. Maybe my quick hack wasn't quite right. Anyways, the default signedness of char has something to do with the problem. Ah, interesting! Last year, we installed specific code in the Ada front end and the DWARF back end to handle discrepancies between the INTEGER_TYPE signedness and the signedness to appear in debug info (https://gcc.gnu.org/git/?p=gcc.git;a=blob;f=gcc/dwarf2out.c;h=c2422e29658b6a101034318deed224271e6f1ca7;hb=HEAD#l24561), but ironically here, it seems that we don’t handle properly when everything is unsigned. I think the current testcase should work on RISC-V even without -fsigned-char: Character’s debug type should be unsigned in all cases. Maybe for some reason we don’t create the correct debug type in the Ada front end… Do you think I can reproduce this with a x86_64-linux compiler targetting something like riscv-elf? I don’t have access to a RISC-V board on which to build GCC. -- Pierre-Marie de Rodat
[Ada] Adjust growth factor from 1/32 to 1/2 for Unbounded_String
This will reduce significantly the number of allocations done when doing consecutive append operations. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Nicolas Roche gcc/ada/ * libgnat/a-strunb.adb, libgnat/a-strunb__shared.adb: Adjust growth factor from 1/32 to 1/2 for Unbounded_String.--- gcc/ada/libgnat/a-strunb.adb +++ gcc/ada/libgnat/a-strunb.adb @@ -763,13 +763,13 @@ package body Ada.Strings.Unbounded is (Source : in out Unbounded_String; Chunk_Size : Natural) is - Growth_Factor : constant := 32; + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every -- append, particularly important when a string is built up by repeated -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. + -- 2 means add 1/2 of the length of the string as growth space. Min_Mul_Alloc : constant := Standard'Maximum_Alignment; -- Allocation will be done by a multiple of Min_Mul_Alloc This causes --- gcc/ada/libgnat/a-strunb__shared.adb +++ gcc/ada/libgnat/a-strunb__shared.adb @@ -36,13 +36,13 @@ package body Ada.Strings.Unbounded is use Ada.Strings.Maps; - Growth_Factor : constant := 32; + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every -- append, particularly important when a string is built up by repeated -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. + -- 2 means add 1/2 of the length of the string as growth space. Min_Mul_Alloc : constant := Standard'Maximum_Alignment; -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
[Ada] Illegal deferred constant causes stack overflow
This patch prevents the compiler from entering infinite recursion when processing an illegal deferred constant. -- Source -- -- types.ads package Types is type Enum is (One, Two); end Types; -- types2.ads with Types; package Types2 is type Enum is private; One : constant Enum; Two : constant Enum; private type Enum is new Types.Enum; One : constant Enum := One; Two : constant Enum := Two; end Types2; -- Compilation and output -- $ gcc -c types2.ads types2.ads:10:04: full constant declaration appears too late types2.ads:11:04: full constant declaration appears too late Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Hristian Kirtchev gcc/ada/ * sem_eval.adb (Compile_Time_Known_Value): Add a guard which prevents the compiler from entering infinite recursion when trying to determine whether a deferred constant has a compile time known value, and the initialization expression of the constant is a reference to the constant itself.--- gcc/ada/sem_eval.adb +++ gcc/ada/sem_eval.adb @@ -1705,29 +1705,46 @@ package body Sem_Eval is end if; -- If we have an entity name, then see if it is the name of a constant - -- and if so, test the corresponding constant value, or the name of - -- an enumeration literal, which is always a constant. + -- and if so, test the corresponding constant value, or the name of an + -- enumeration literal, which is always a constant. if Present (Etype (Op)) and then Is_Entity_Name (Op) then declare -E : constant Entity_Id := Entity (Op); -V : Node_Id; +Ent : constant Entity_Id := Entity (Op); +Val : Node_Id; begin --- Never known at compile time if it is a packed array value. --- We might want to try to evaluate these at compile time one --- day, but we do not make that attempt now. +-- Never known at compile time if it is a packed array value. We +-- might want to try to evaluate these at compile time one day, +-- but we do not make that attempt now. if Is_Packed_Array_Impl_Type (Etype (Op)) then return False; -end if; -if Ekind (E) = E_Enumeration_Literal then +elsif Ekind (Ent) = E_Enumeration_Literal then return True; -elsif Ekind (E) = E_Constant then - V := Constant_Value (E); - return Present (V) and then Compile_Time_Known_Value (V); +elsif Ekind (Ent) = E_Constant then + Val := Constant_Value (Ent); + + if Present (Val) then + + -- Guard against an illegal deferred constant whose full + -- view is initialized with a reference to itself. Treat + -- this case as value not known at compile time. + + if Is_Entity_Name (Val) and then Entity (Val) = Ent then + return False; + else + return Compile_Time_Known_Value (Val); + end if; + + -- Otherwise the constant does not have a compile time known + -- value. + + else + return False; + end if; end if; end;
[Ada] Violation of No_Standard_Allocators_After_Elaboration not detected
The compiler fails to generate a call to detect allocators executed after elaboration in cases where the allocator is associated with Global_Pool_Object. The fix is to test for this associated storage pool as part of the condition for generating a call to System.Elaboration_Allocators.Check_Standard_Alloctor. Also, the exception Storage_Error is now generated instead of Program_Error for such a run-time violation, as required by the Ada RM in D.7. The following test must compile and execute quietly: -- Put the pragma in gnat.adc: pragma Restrictions (No_Standard_Allocators_After_Elaboration); package Pkg_With_Allocators is type Priv is private; procedure Allocate (Use_Global_Allocator : Boolean; During_Elaboration : Boolean); private type Rec is record Int : Integer; end record; type Priv is access Rec; end Pkg_With_Allocators; package body Pkg_With_Allocators is Ptr : Priv; procedure Allocate (Use_Global_Allocator : Boolean; During_Elaboration : Boolean) is type Local_Acc is access Rec; Local_Ptr : Local_Acc; begin if Use_Global_Allocator then Ptr := new Rec; -- Raise Storage_Error if after elaboration Ptr.Int := 1; else Local_Ptr := new Rec; -- Raise Storage_Error if after elaboration Local_Ptr.Int := 1; end if; if not During_Elaboration then raise Program_Error; -- No earlier exception: FAIL end if; exception when Storage_Error => if During_Elaboration then raise Program_Error; -- No exception expected: FAIL else null; -- Expected Storage_Error: PASS end if; when others => raise Program_Error; -- Unexpected exception: FAIL end Allocate; begin Allocate (Use_Global_Allocator => True, During_Elaboration => True); Allocate (Use_Global_Allocator => False, During_Elaboration => True); end Pkg_With_Allocators; with Pkg_With_Allocators; procedure Alloc_Restriction_Main is begin Pkg_With_Allocators.Allocate (Use_Global_Allocator => True, During_Elaboration => False); Pkg_With_Allocators.Allocate (Use_Global_Allocator => False, During_Elaboration => False); end Alloc_Restriction_Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Gary Dismukes gcc/ada/ * exp_ch4.adb (Expand_N_Allocator): Test for Storage_Pool being RTE in addition to the existing test for no Storage_Pool as a condition enabling generation of the call to Check_Standard_Allocator when the restriction No_Standard_Allocators_After_Elaboration is active. * libgnat/s-elaall.ads (Check_Standard_Allocator): Correct comment to say that Storage_Error will be raised (rather than Program_Error). * libgnat/s-elaall.adb (Check_Standard_Allocator): Raise Storage_Error rather than Program_Error when Elaboration_In_Progress is False.--- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -4561,12 +4561,14 @@ package body Exp_Ch4 is end if; end if; - -- If no storage pool has been specified and we have the restriction + -- If no storage pool has been specified, or the storage pool + -- is System.Pool_Global.Global_Pool_Object, and the restriction -- No_Standard_Allocators_After_Elaboration is present, then generate -- a call to Elaboration_Allocators.Check_Standard_Allocator. if Nkind (N) = N_Allocator -and then No (Storage_Pool (N)) +and then (No (Storage_Pool (N)) + or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object)) and then Restriction_Active (No_Standard_Allocators_After_Elaboration) then Insert_Action (N, --- gcc/ada/libgnat/s-elaall.adb +++ gcc/ada/libgnat/s-elaall.adb @@ -45,7 +45,7 @@ package body System.Elaboration_Allocators is procedure Check_Standard_Allocator is begin if not Elaboration_In_Progress then - raise Program_Error with + raise Storage_Error with "standard allocator after elaboration is complete is not allowed " & "(No_Standard_Allocators_After_Elaboration restriction active)"; end if; --- gcc/ada/libgnat/s-elaall.ads +++ gcc/ada/libgnat/s-elaall.ads @@ -51,7 +51,7 @@ package System.Elaboration_Allocators is procedure Check_Standard_Allocator; -- Called as part of every allocator in a program for which the restriction -- No_Standard_Allocators_After_Elaboration is active. This will raise an - -- exception (Program_Error with an appropriate message) if it is called + -- exception (Storage_Error with an appropriate message) if it is called -- after the call to Mark_End_Of_Elaboration. end System.Elaboration_Allocators;
[Ada] Adjust inlining in GNATprove mode for predicate/invariant/DIC
The frontend generates special functions for checking subtype predicates,
type invariants and Default_Initial_Condition aspect. These are translated
as predicates in GNATprove, and as such should no call inside these
functions should be inlined. This is similar to the existing handling of
calls inside expression functions.
There is no impact on compilation.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Yannick Moy
gcc/ada/
* sem_res.adb (Resolve_Call): Do not inline calls inside
compiler-generated functions translated as predicates in GNATprove.--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -5374,7 +5374,7 @@ package body Sem_Res is
-- A universal real conditional expression can appear in a fixed-type
-- context and must be resolved with that context to facilitate the
- -- code generation to the backend.
+ -- code generation in the back end.
elsif Nkind_In (N, N_Case_Expression, N_If_Expression)
and then Etype (N) = Universal_Real
@@ -6685,22 +6685,43 @@ package body Sem_Res is
elsif Full_Analysis then
- -- Do not inline calls inside expression functions, as this
+ -- Do not inline calls inside expression functions or functions
+ -- generated by the front end for subtype predicates, as this
-- would prevent interpreting them as logical formulas in
-- GNATprove. Only issue a message when the body has been seen,
-- otherwise this leads to spurious messages on callees that
-- are themselves expression functions.
if Present (Current_Subprogram)
- and then Is_Expression_Function_Or_Completion
-(Current_Subprogram)
+ and then
+ (Is_Expression_Function_Or_Completion (Current_Subprogram)
+ or else Is_Predicate_Function (Current_Subprogram)
+ or else Is_Invariant_Procedure (Current_Subprogram)
+ or else Is_DIC_Procedure (Current_Subprogram))
then
if Present (Body_Id)
and then Present (Body_To_Inline (Nam_Decl))
then
- Cannot_Inline
- ("cannot inline & (inside expression function)?",
-N, Nam_UA);
+ if Is_Predicate_Function (Current_Subprogram) then
+Cannot_Inline
+ ("cannot inline & (inside predicate)?",
+ N, Nam_UA);
+
+ elsif Is_Invariant_Procedure (Current_Subprogram) then
+Cannot_Inline
+ ("cannot inline & (inside invariant)?",
+ N, Nam_UA);
+
+ elsif Is_DIC_Procedure (Current_Subprogram) then
+Cannot_Inline
+("cannot inline & (inside Default_Initial_Condition)?",
+ N, Nam_UA);
+
+ else
+Cannot_Inline
+ ("cannot inline & (inside expression function)?",
+ N, Nam_UA);
+ end if;
end if;
-- With the one-pass inlining technique, a call cannot be
@@ -11854,7 +11875,7 @@ package body Sem_Res is
Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id));
-- Build bona fide subtype for the string, and wrap it in an
--- unchecked conversion, because the backend expects the
+-- unchecked conversion, because the back end expects the
-- String_Literal_Subtype to have a static lower bound.
Index_Subtype :=
@@ -11864,7 +11885,7 @@ package body Sem_Res is
Set_Parent (Drange, N);
Analyze_And_Resolve (Drange, Index_Type);
--- In the context, the Index_Type may already have a constraint,
+-- In this context, the Index_Type may already have a constraint,
-- so use common base type on string subtype. The base type may
-- be used when generating attributes of the string, for example
-- in the context of a slice assignment.
[Ada] Bit_Order cannot be defined for record extensions
This patch allows the compiler to report an error on Bit_Order when
defined for a record extension.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Javier Miranda
gcc/ada/
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): Report an error
on Bit_Order when defined for a record extension.
gcc/testsuite/
* gnat.dg/bit_order1.adb: New testcase.--- gcc/ada/sem_ch13.adb
+++ gcc/ada/sem_ch13.adb
@@ -5331,6 +5331,12 @@ package body Sem_Ch13 is
Error_Msg_N
("Bit_Order can only be defined for record type", Nam);
+elsif Is_Tagged_Type (U_Ent)
+ and then Is_Derived_Type (U_Ent)
+then
+ Error_Msg_N
+ ("Bit_Order cannot be defined for record extensions", Nam);
+
elsif Duplicate_Clause then
null;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bit_order1.adb
@@ -0,0 +1,18 @@
+-- { dg-do compile }
+
+with System;
+
+procedure Bit_Order1 is
+
+ type Sample_Ttype is tagged record
+ Data : Natural;
+ end record;
+
+ type Other_Type is new Sample_Ttype with record
+ Other_Data : String (1 .. 100);
+ end record;
+
+ for Other_Type'Bit_Order use System.High_Order_First; -- { dg-error "Bit_Order cannot be defined for record extensions" }
+begin
+ null;
+end;
[Ada] Crash processing sources under GNATprove debug mode
Processing sources under -gnatd.F the frontend may crash on
an iterator of the form 'for X of ...' over an array if the
iterator is located in an inlined subprogram.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Javier Miranda
gcc/ada/
* exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Code cleanup. Required
to avoid generating an ill-formed tree that confuses gnatprove causing
it to blowup.
gcc/testsuite/
* gnat.dg/iter2.adb, gnat.dg/iter2.ads: New testcase.--- gcc/ada/exp_ch5.adb
+++ gcc/ada/exp_ch5.adb
@@ -3711,9 +3711,14 @@ package body Exp_Ch5 is
Ind_Comp :=
Make_Indexed_Component (Loc,
- Prefix => Relocate_Node (Array_Node),
+ Prefix => New_Copy_Tree (Array_Node),
Expressions => New_List (New_Occurrence_Of (Iterator, Loc)));
+ -- Propagate the original node to the copy since the analysis of the
+ -- following object renaming declaration relies on the original node.
+
+ Set_Original_Node (Prefix (Ind_Comp), Original_Node (Array_Node));
+
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
@@ -3755,7 +3760,7 @@ package body Exp_Ch5 is
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Array_Node),
+ Prefix => New_Copy_Tree (Array_Node),
Attribute_Name => Name_Range,
Expressions=> New_List (
Make_Integer_Literal (Loc, Dim1))),
@@ -3792,7 +3797,7 @@ package body Exp_Ch5 is
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
-Prefix => Relocate_Node (Array_Node),
+Prefix => New_Copy_Tree (Array_Node),
Attribute_Name => Name_Range,
Expressions=> New_List (
Make_Integer_Literal (Loc, Dim1))),
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter2.adb
@@ -0,0 +1,28 @@
+-- { dg-do compile }
+-- { dg-options "-gnatd.F -gnatws" }
+
+package body Iter2
+ with SPARK_Mode
+is
+ function To_String (Name : String) return String
+ is
+ procedure Append (Result : in out String;
+Data :String)
+with Inline_Always;
+ procedure Append (Result : in out String;
+Data :String)
+ is
+ begin
+ for C of Data
+ loop
+Result (1) := C;
+ end loop;
+ end Append;
+
+ Result : String (1 .. 3);
+ begin
+ Append (Result, "");
+ return Result;
+ end To_String;
+
+end Iter2;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter2.ads
@@ -0,0 +1,5 @@
+package Iter2
+ with SPARK_Mode
+is
+ function To_String (Name : String) return String;
+end Iter2;
[Ada] Segmentation_Fault with Integer'Wide_Wide_Value
This patch updates the routines which produce Wide_String and Wide_Wide_String
from a String to construct a result of the proper maximum size which is later
sliced.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Hristian Kirtchev
gcc/ada/
* libgnat/s-wchwts.adb (Wide_String_To_String): Use the appropriate
longest sequence factor. Code clean up.
(Wide_Wide_String_To_String): Use the appropriate longest sequence
factor. Code clean up.
gcc/testsuite/
* gnat.dg/wide_wide_value1.adb: New testcase.--- gcc/ada/libgnat/s-wchwts.adb
+++ gcc/ada/libgnat/s-wchwts.adb
@@ -86,16 +86,23 @@ package body System.WCh_WtS is
(S : Wide_String;
EM : WC_Encoding_Method) return String
is
- R : String (S'First .. S'First + 5 * S'Length); -- worst case length
- RP : Natural;
+ Max_Chars : constant Natural := WC_Longest_Sequences (EM);
+
+ Result : String (S'First .. S'First + Max_Chars * S'Length);
+ Result_Idx : Natural;
begin
- RP := R'First - 1;
- for SP in S'Range loop
- Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM);
+ Result_Idx := Result'First - 1;
+
+ for S_Idx in S'Range loop
+ Store_UTF_32_Character
+ (U => Wide_Character'Pos (S (S_Idx)),
+S => Result,
+P => Result_Idx,
+EM => EM);
end loop;
- return R (R'First .. RP);
+ return Result (Result'First .. Result_Idx);
end Wide_String_To_String;
@@ -106,17 +113,23 @@ package body System.WCh_WtS is
(S : Wide_Wide_String;
EM : WC_Encoding_Method) return String
is
- R : String (S'First .. S'First + 7 * S'Length); -- worst case length
- RP : Natural;
+ Max_Chars : constant Natural := WC_Longest_Sequences (EM);
- begin
- RP := R'First - 1;
+ Result : String (S'First .. S'First + Max_Chars * S'Length);
+ Result_Idx : Natural;
- for SP in S'Range loop
- Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM);
+ begin
+ Result_Idx := Result'First - 1;
+
+ for S_Idx in S'Range loop
+ Store_UTF_32_Character
+ (U => Wide_Wide_Character'Pos (S (S_Idx)),
+S => Result,
+P => Result_Idx,
+EM => EM);
end loop;
- return R (R'First .. RP);
+ return Result (Result'First .. Result_Idx);
end Wide_Wide_String_To_String;
end System.WCh_WtS;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/wide_wide_value1.adb
@@ -0,0 +1,60 @@
+-- { dg-do run }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Wide_Wide_Value1 is
+begin
+ begin
+ declare
+ Str : constant Wide_Wide_String :=
+ Wide_Wide_Character'Val (16#0411#) &
+ Wide_Wide_Character'Val (16#043e#) &
+ Wide_Wide_Character'Val (16#0434#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0443#) &
+ Wide_Wide_Character'Val (16#0431#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0435#) &
+ Wide_Wide_Character'Val (16#0432#) &
+ Wide_Wide_Character'Val (16#0416#) &
+ Wide_Wide_Character'Val (16#0443#) &
+ Wide_Wide_Character'Val (16#043c#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0442#) &
+ Wide_Wide_Character'Val (16#041c#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0440#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0442#) &
+ Wide_Wide_Character'Val (16#043e#) &
+ Wide_Wide_Character'Val (16#0432#) &
+ Wide_Wide_Character'Val (16#0438#) &
+ Wide_Wide_Character'Val (16#0447#);
+
+ Val : constant Integer := Integer'Wide_Wide_Value (Str);
+ begin
+ Put_Line ("ERROR: 1: Constraint_Error not raised");
+ end;
+ exception
+ when Constraint_Error =>
+ null;
+ when others =>
+ Put_Line ("ERROR: 1: unexpected exception");
+ end;
+
+ begin
+ declare
+ Str : Wide_Wide_String (1 .. 128) :=
+ (others => Wide_Wide_Character'Val (16#0FFF#));
+
+ Val : constant Integer := Integer'Wide_Wide_Value (Str);
+ begin
+ Put_Line ("ERROR: 1: Constraint_Error not raised");
+ end;
+ exception
+ when Constraint_Error =>
+ null;
+ when others =>
+ Put_Line ("ERROR: 1: unexpected exception");
+ end;
+end Wide_Wide_Value1;
[Ada] Code cleanup on functions inlining
This patch is preventive: it improves checks on inline functions that
return unconstrained type. It does not change the functionality of
the compiler.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Javier Miranda
gcc/ada/
* inline.adb (Build_Body_To_Inline): Minor code reorganization that
ensures that calls to function Has_Single_Return() pass a decorated
tree.
(Has_Single_Return.Check_Return): Peform checks on entities (instead on
relying on their characters).--- gcc/ada/inline.adb
+++ gcc/ada/inline.adb
@@ -1085,33 +1085,9 @@ package body Inline is
Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
return;
- -- Functions that return unconstrained composite types require
- -- secondary stack handling, and cannot currently be inlined, unless
- -- all return statements return a local variable that is the first
- -- local declaration in the body.
-
- elsif Ekind (Spec_Id) = E_Function
-and then not Is_Scalar_Type (Etype (Spec_Id))
-and then not Is_Access_Type (Etype (Spec_Id))
-and then not Is_Constrained (Etype (Spec_Id))
- then
- if not Has_Single_Return (N)
-
- -- Skip inlining if the function returns an unconstrained type
- -- using an extended return statement, since this part of the
- -- new inlining model is not yet supported by the current
- -- implementation. ???
-
- or else (Returns_Unconstrained_Type (Spec_Id)
- and then Has_Extended_Return)
- then
-Cannot_Inline
- ("cannot inline & (unconstrained return type)?", N, Spec_Id);
-return;
- end if;
-
- -- Ditto for functions that return controlled types, where controlled
- -- actions interfere in complex ways with inlining.
+ -- Functions that return controlled types cannot currently be inlined
+ -- because they require secondary stack handling; controlled actions
+ -- may also interfere in complex ways with inlining.
elsif Ekind (Spec_Id) = E_Function
and then Needs_Finalization (Etype (Spec_Id))
@@ -1234,10 +1210,37 @@ package body Inline is
Restore_Env;
end if;
+ -- Functions that return unconstrained composite types require
+ -- secondary stack handling, and cannot currently be inlined, unless
+ -- all return statements return a local variable that is the first
+ -- local declaration in the body. We had to delay this check until
+ -- the body of the function is analyzed since Has_Single_Return()
+ -- requires a minimum decoration.
+
+ if Ekind (Spec_Id) = E_Function
+and then not Is_Scalar_Type (Etype (Spec_Id))
+and then not Is_Access_Type (Etype (Spec_Id))
+and then not Is_Constrained (Etype (Spec_Id))
+ then
+ if not Has_Single_Return (Body_To_Analyze)
+
+ -- Skip inlining if the function returns an unconstrained type
+ -- using an extended return statement, since this part of the
+ -- new inlining model is not yet supported by the current
+ -- implementation. ???
+
+ or else (Returns_Unconstrained_Type (Spec_Id)
+ and then Has_Extended_Return)
+ then
+Cannot_Inline
+ ("cannot inline & (unconstrained return type)?", N, Spec_Id);
+return;
+ end if;
+
-- If secondary stack is used, there is no point in inlining. We have
-- already issued the warning in this case, so nothing to do.
- if Uses_Secondary_Stack (Body_To_Analyze) then
+ elsif Uses_Secondary_Stack (Body_To_Analyze) then
return;
end if;
@@ -3904,17 +3907,23 @@ package body Inline is
if Present (Expression (N))
and then Is_Entity_Name (Expression (N))
then
+ pragma Assert (Present (Entity (Expression (N;
+
if No (Return_Statement) then
Return_Statement := N;
return OK;
- elsif Chars (Expression (N)) =
- Chars (Expression (Return_Statement))
- then
- return OK;
-
else
- return Abandon;
+ pragma Assert
+(Present (Entity (Expression (Return_Statement;
+
+ if Entity (Expression (N)) =
+ Entity (Expression (Return_Statement))
+ then
+ return OK;
+ else
+ return Abandon;
+ end if;
end if;
-- A return statement within an extended return is a noop
@@ -3963,8 +3972,8 @@ package body Inline is
else
return Present (Declarations (N))
and then Present (First (Declar
[Ada] Spurious possible contraint error warning with No_Exception_Propagation
This patch corrects an issue whereby spurious unhandled exception warnings on integer literals within static if and case expressions would be emitted when the restriction No_Exception_Propagation is enabled. -- Source -- -- gnat.adc pragma Restrictions (No_Exception_Propagation); pragma SPARK_Mode (On); -- pack.ads package Pack is procedure Filter (Ret : out Integer); end Pack; -- pack.adb package body Pack is subtype Nat is Integer range 0 .. 10; Default : constant Nat := 1; User_Override : constant Integer := -1; procedure Filter (Ret : out Integer) is Val : constant Nat := (if User_Override in Nat then User_Override else Default); begin Ret := Val; end Filter; end Pack; -- Compilation and output -- & gcc -c -gnatp -gnatwa pack.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Justin Squirek gcc/ada/ * sem_eval.adb (Eval_Integer_Literal): Add exception for avoiding checks on expanded literals within if and case expressions.--- gcc/ada/sem_eval.adb +++ gcc/ada/sem_eval.adb @@ -2720,16 +2720,23 @@ package body Sem_Eval is -- Start of processing for Eval_Integer_Literal begin - -- If the literal appears in a non-expression context, then it is -- certainly appearing in a non-static context, so check it. This is -- actually a redundant check, since Check_Non_Static_Context would -- check it, but it seems worthwhile to optimize out the call. - -- An exception is made for a literal in an if or case expression + -- Additionally, when the literal appears within an if or case + -- expression it must be checked as well. However, due to the literal + -- appearing within a conditional statement, expansion greatly changes + -- the nature of its context and performing some of the checks within + -- Check_Non_Static_Context on an expanded literal may lead to spurious + -- and misleading warnings. if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative) or else Nkind (Parent (N)) not in N_Subexpr) +and then (not Nkind_In (Parent (N), N_If_Expression, + N_Case_Expression_Alternative) + or else Comes_From_Source (N)) and then not In_Any_Integer_Context then Check_Non_Static_Context (N);
[Ada] Crash on Indefinite_Hashed_Maps with -gnata -gnateV
This patch corrects the generation of helper functions which verify the
validity of record type scalar discriminants and scalar components when
switches -gnata (assertions enabled) and -gnateV (validity checks on
subprogram parameters) are in effect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Hristian Kirtchev
gcc/ada/
* exp_attr.adb (Build_Record_VS_Func): Handle corner cases dealing with
class-wide types and record extensions.
gcc/testsuite/
* gnat.dg/validity_check3.adb, gnat.dg/validity_check3.ads: New
testcase.--- gcc/ada/exp_attr.adb
+++ gcc/ada/exp_attr.adb
@@ -724,13 +724,44 @@ package body Exp_Attr is
Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
- Rec_Decl : constant Node_Id := Declaration_Node (Rec_Typ);
- Rec_Def : constant Node_Id := Type_Definition (Rec_Decl);
+ Comps: Node_Id;
Stmts: List_Id;
+ Typ : Entity_Id;
+ Typ_Decl : Node_Id;
+ Typ_Def : Node_Id;
+ Typ_Ext : Node_Id;
-- Start of processing for Build_Record_VS_Func
begin
+ Typ := Rec_Typ;
+
+ -- Use the root type when dealing with a class-wide type
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ_Decl := Declaration_Node (Typ);
+ Typ_Def := Type_Definition (Typ_Decl);
+
+ -- The components of a derived type are located in the extension part
+
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Typ_Ext := Record_Extension_Part (Typ_Def);
+
+ if Present (Typ_Ext) then
+Comps := Component_List (Typ_Ext);
+ else
+Comps := Empty;
+ end if;
+
+ -- Otherwise the components are available in the definition
+
+ else
+ Comps := Component_List (Typ_Def);
+ end if;
+
-- The code generated by this routine is as follows:
--
--function Func_Id (Obj_Id : Formal_Typ) return Boolean is
@@ -774,7 +805,7 @@ package body Exp_Attr is
if not Is_Unchecked_Union (Rec_Typ) then
Validate_Fields
(Obj_Id => Obj_Id,
-Fields => Discriminant_Specifications (Rec_Decl),
+Fields => Discriminant_Specifications (Typ_Decl),
Stmts => Stmts);
end if;
@@ -782,7 +813,7 @@ package body Exp_Attr is
Validate_Component_List
(Obj_Id=> Obj_Id,
- Comp_List => Component_List (Rec_Def),
+ Comp_List => Comps,
Stmts => Stmts);
-- Generate:
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/validity_check3.adb
@@ -0,0 +1,96 @@
+-- { dg-do compile }
+-- { dg-options "-gnata -gnateV" }
+
+package body Validity_Check3 is
+ procedure Proc_Priv_CW_1 (Param : Tag_1'Class) is begin null; end;
+ procedure Proc_Priv_CW_2 (Param : Tag_2'Class) is begin null; end;
+ procedure Proc_Priv_CW_3 (Param : Tag_3'Class) is begin null; end;
+ procedure Proc_Priv_CW_4 (Param : Tag_4'Class) is begin null; end;
+ procedure Proc_Priv_CW_5 (Param : Tag_5'Class) is begin null; end;
+ procedure Proc_Priv_CW_6 (Param : Tag_6'Class) is begin null; end;
+
+ procedure Proc_Priv_Rec_1 (Param : Rec_1) is begin null; end;
+ procedure Proc_Priv_Rec_2 (Param : Rec_2) is begin null; end;
+ procedure Proc_Priv_Rec_3 (Param : Rec_3) is begin null; end;
+ procedure Proc_Priv_Rec_4 (Param : Rec_4) is begin null; end;
+
+ procedure Proc_Priv_Tag_1 (Param : Tag_1) is begin null; end;
+ procedure Proc_Priv_Tag_2 (Param : Tag_2) is begin null; end;
+ procedure Proc_Priv_Tag_3 (Param : Tag_3) is begin null; end;
+ procedure Proc_Priv_Tag_4 (Param : Tag_4) is begin null; end;
+ procedure Proc_Priv_Tag_5 (Param : Tag_5) is begin null; end;
+ procedure Proc_Priv_Tag_6 (Param : Tag_6) is begin null; end;
+
+ procedure Proc_Vis_CW_1 (Param : Tag_1'Class) is begin null; end;
+ procedure Proc_Vis_CW_2 (Param : Tag_2'Class) is begin null; end;
+ procedure Proc_Vis_CW_3 (Param : Tag_3'Class) is begin null; end;
+ procedure Proc_Vis_CW_4 (Param : Tag_4'Class) is begin null; end;
+ procedure Proc_Vis_CW_5 (Param : Tag_5'Class) is begin null; end;
+ procedure Proc_Vis_CW_6 (Param : Tag_6'Class) is begin null; end;
+
+ procedure Proc_Vis_Rec_1 (Param : Rec_1) is begin null; end;
+ procedure Proc_Vis_Rec_2 (Param : Rec_2) is begin null; end;
+ procedure Proc_Vis_Rec_3 (Param : Rec_3) is begin null; end;
+ procedure Proc_Vis_Rec_4 (Param : Rec_4) is begin null; end;
+
+ procedure Proc_Vis_Tag_1 (Param : Tag_1) is begin null; end;
+ procedure Proc_Vis_Tag_2 (Param : Tag_2) is begin null; end;
+ procedure Proc_Vis_Tag_3 (Param : Tag_3) is begin null; end;
+ procedure Proc_Vis_Tag_4 (Param : Tag_4) is begin null; end;
+ procedure Proc_Vis_Tag_5 (Param : Tag_5) is begin null; end;
+ procedure Proc_Vis_Tag_6 (Param : Tag_6) is begin n
[Ada] Deconstruct always-false calls to Withed_Body in Walk_Library_Items
We previously removed the calls to Set_Withed_Body; this commit deconstructs calls to Withed_Body, which always returned False. The Set_Withed_Body/Withed_Body were helping the Walk_Library_Items routine traverse the AST of several compilation units such that declarations are visited before references. However, this never worked as it should and there is no point to keep the code more complicated than necessary. No test provided, because thie removed code was ineffective (and only used in the non-compiler backends, i.e. CodePeer and GNATprove). Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Piotr Trojanek gcc/ada/ * sem.adb (Walk_Library_Items): Deconstruct dead code.--- gcc/ada/sem.adb +++ gcc/ada/sem.adb @@ -36,7 +36,6 @@ with Nlists;use Nlists; with Output;use Output; with Restrict; use Restrict; with Sem_Attr; use Sem_Attr; -with Sem_Aux; use Sem_Aux; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; @@ -1705,7 +1704,7 @@ package body Sem is -- The main unit and its spec may depend on bodies that contain generics -- that are instantiated in them. Iterate through the corresponding -- contexts before processing main (spec/body) itself, to process bodies - -- that may be present, together with their context. The spec of main + -- that may be present, together with their context. The spec of main -- is processed wherever it appears in the list of units, while the body -- is processed as the last unit in the list. @@ -2020,8 +2019,7 @@ package body Sem is if Present (Body_CU) and then Body_CU /= Cunit (Main_Unit) and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body - and then (Nkind (Unit (Comp)) /= N_Package_Declaration - or else Present (Withed_Body (Clause))) + and then Nkind (Unit (Comp)) /= N_Package_Declaration then Body_U := Get_Cunit_Unit_Number (Body_CU); @@ -2335,7 +2333,6 @@ package body Sem is Context_Item : Node_Id; Lib_Unit : Node_Id; - Body_CU : Node_Id; begin Context_Item := First (Context_Items (CU)); @@ -2346,30 +2343,6 @@ package body Sem is then Lib_Unit := Library_Unit (Context_Item); Action (Lib_Unit); - --- If the context item indicates that a package body is needed --- because of an instantiation in CU, traverse the body now, even --- if CU is not related to the main unit. If the generic itself --- appears in a package body, the context item is this body, and --- it already appears in the traversal order, so we only need to --- examine the case of a context item being a package declaration. - -if Present (Withed_Body (Context_Item)) - and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration - and then Present (Corresponding_Body (Unit (Lib_Unit))) -then - Body_CU := - Parent - (Unit_Declaration_Node - (Corresponding_Body (Unit (Lib_Unit; - - -- A body may have an implicit with on its own spec, in which - -- case we must ignore this context item to prevent looping. - - if Unit (CU) /= Unit (Body_CU) then - Action (Body_CU); - end if; -end if; end if; Context_Item := Next (Context_Item);
[Ada] Spurious error with null Abstract_State
This patch corrects the mechanism which ensures that a package with a null
Abstract_State does not introduce hidden state, by ignoring internal states
and variables because they do not represent the "source" hidden state.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Hristian Kirtchev
gcc/ada/
* sem_util.adb (Check_No_Hidden_State): Ignore internally-generated
states and variables.
gcc/testsuite/
* gnat.dg/abstract_state1.adb, gnat.dg/abstract_state1.ads: New
testcase.--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -3228,6 +3228,13 @@ package body Sem_Util is
begin
pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
+ -- Nothing to do for internally-generated abstract states and variables
+ -- because they do not represent the hidden state of the source unit.
+
+ if not Comes_From_Source (Id) then
+ return;
+ end if;
+
-- Find the proper context where the object or state appears
Scop := Scope (Id);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/abstract_state1.adb
@@ -0,0 +1,5 @@
+-- { dg-do compile }
+
+package body Abstract_State1 is
+ procedure Foo is null;
+end Abstract_State1;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/abstract_state1.ads
@@ -0,0 +1,24 @@
+package Abstract_State1
+ with Abstract_State => null,
+ Initializes=> null
+is
+ type Complex (B : Boolean) is tagged private;
+ type No_F is tagged private;
+ X : constant No_F;
+
+ procedure Foo;
+
+private
+ type Complex (B : Boolean) is tagged record
+ G : Integer;
+ case B is
+ when True =>
+F : Integer;
+ when False =>
+null;
+ end case;
+ end record;
+
+ type No_F is new Complex (False) with null record;
+ X : constant No_F := (B => False, G => 7);
+end Abstract_State1;
[Ada] Avoid crash when traversing units with -gnatd.WW debug switch
The debug switch -gnatd.WW enables extra info when traversing library units with Walk_Library_Items, which is used in the CodePeer and GNATprove. This routine was crashing when trying to print info about a unit with configuration pragmas (typically an .adc file). Now fixed. No test, as the crash only happens when a GNATprove backend is manually called with -gnatd.WW switch. Frontend is not affected. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Piotr Trojanek gcc/ada/ * sem.adb (Walk_Library_Items): Skip units with configuration pragmas when printing debug info.--- gcc/ada/sem.adb +++ gcc/ada/sem.adb @@ -2242,8 +2242,14 @@ package body Sem is for Unit_Num in Done'Range loop if not Done (Unit_Num) then - Write_Unit_Info -(Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + + -- Units with configuration pragmas (.ads files) have empty + -- compilation-unit nodes; skip printing info about them. + + if Present (Cunit (Unit_Num)) then + Write_Unit_Info + (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + end if; end if; end loop;
[Ada] Deconstruct unused Withed_Body filed of N_With_Clause node
The Withed_Body field was added to N_With_Clause node to help the Walk_Library_Items routine, which was created for the CodePeer backend and later adopted by the GNATprove. This routine is meant to traverse all library units, such that declarations are visited before references. However, for complex units (in particular, with generics and child packages) it never worked reliably and backends developed their own workarounds. This patch deconstructs the field, as it hasn't been used for years. Semantics unaffected; no test provided. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Piotr Trojanek gcc/ada/ * sinfo.ads, sinfo.adb (Withed_Body): Remove. (Set_Withed_Body): Remove.--- gcc/ada/sinfo.adb +++ gcc/ada/sinfo.adb @@ -3522,14 +3522,6 @@ package body Sinfo is return Flag13 (N); end Was_Originally_Stub; - function Withed_Body - (N : Node_Id) return Node_Id is - begin - pragma Assert (False -or else NT (N).Nkind = N_With_Clause); - return Node1 (N); - end Withed_Body; - -- -- Field Set Procedures -- -- @@ -6990,14 +6982,6 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Was_Originally_Stub; - procedure Set_Withed_Body - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False -or else NT (N).Nkind = N_With_Clause); - Set_Node1 (N, Val); - end Set_Withed_Body; - - -- Iterator Procedures -- - --- gcc/ada/sinfo.ads +++ gcc/ada/sinfo.ads @@ -2504,12 +2504,6 @@ package Sinfo is --Original_Node here because of the case of nested instantiations where --the substituted node can be copied. - -- Withed_Body (Node1-Sem) - --Present in N_With_Clause nodes. Set if the unit in whose context - --the with_clause appears instantiates a generic contained in the - --library unit of the with_clause and as a result loads its body. - --Used for a more precise unit traversal for CodePeer. - -- -- Note on Use of End_Label and End_Span Fields -- -- @@ -6743,7 +6737,6 @@ package Sinfo is -- N_With_Clause -- Sloc points to first token of library unit name - -- Withed_Body (Node1-Sem) -- Name (Node2) -- Private_Present (Flag15) set if with_clause has private keyword -- Limited_Present (Flag17) set if LIMITED is present @@ -10307,9 +10300,6 @@ package Sinfo is function Was_Originally_Stub (N : Node_Id) return Boolean;-- Flag13 - function Withed_Body - (N : Node_Id) return Node_Id;-- Node1 - -- End functions (note used by xsinfo utility program to end processing) @@ -11408,9 +11398,6 @@ package Sinfo is procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True);-- Flag13 - procedure Set_Withed_Body - (N : Node_Id; Val : Node_Id);-- Node1 - - -- Iterator Procedures -- - @@ -13613,7 +13600,6 @@ package Sinfo is pragma Inline (Was_Attribute_Reference); pragma Inline (Was_Expression_Function); pragma Inline (Was_Originally_Stub); - pragma Inline (Withed_Body); pragma Inline (Set_Abort_Present); pragma Inline (Set_Abortable_Part); @@ -13975,6 +13961,5 @@ package Sinfo is pragma Inline (Set_Was_Attribute_Reference); pragma Inline (Set_Was_Expression_Function); pragma Inline (Set_Was_Originally_Stub); - pragma Inline (Set_Withed_Body); end Sinfo;
[Ada] Missing error on hidden state in instantiation
This patch modifies the analysis of package contracts to split processing which is specific to package instantiations on its own. As a result, the lack of indicator Part_Of can now be properly assessed. -- Source -- -- gen_pack.ads generic package Gen_Pack is Pack_Var : Integer := 1; end Gen_Pack; -- gen_wrap.ads with Gen_Pack; generic package Gen_Wrap is Wrap_Var : Integer := 1; package Inst is new Gen_Pack; end Gen_Wrap; -- pack.ads with Gen_Pack; with Gen_Wrap; package Pack with SPARK_Mode => On, Abstract_State => State is procedure Force_Body; private package OK_Inst_1 is new Gen_Pack -- OK with Part_Of => State; -- OK package OK_Inst_2 is new Gen_Pack;-- OK pragma Part_Of (State); -- OK package OK_Inst_3 is new Gen_Wrap -- OK with Part_Of => State; -- OK package OK_Inst_4 is new Gen_Wrap;-- OK pragma Part_Of (State); package Error_Inst_1 is new Gen_Pack; -- Error package Error_Inst_2 is new Gen_Wrap; -- Error end Pack; -- pack.adb package body Pack with SPARK_Mode=> On, Refined_State => (State => (OK_Inst_1.Pack_Var, OK_Inst_2.Pack_Var, OK_Inst_3.Wrap_Var, OK_Inst_3.Inst.Pack_Var, OK_Inst_4.Wrap_Var, OK_Inst_4.Inst.Pack_Var)) is procedure Force_Body is null; end Pack; -- Compilation and output -- $ gcc -c pack.adb pack.ads:23:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:23:12: "Error_Inst_1" is declared in the private part of package "Pack" pack.ads:24:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:24:12: "Error_Inst_2" is declared in the private part of package "Pack" Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Hristian Kirtchev gcc/ada/ * contracts.adb (Analyze_Contracts): Add specialized processing for package instantiation contracts. (Analyze_Package_Contract): Remove the verification of a missing Part_Of indicator. (Analyze_Package_Instantiation_Contract): New routine. * contracts.ads (Analyze_Package_Contract): Update the comment on usage. * sem_prag.adb (Check_Missing_Part_Of): Ensure that the entity of the instance is being examined when trying to determine whether a package instantiation needs a Part_Of indicator.--- gcc/ada/contracts.adb +++ gcc/ada/contracts.adb @@ -53,6 +53,13 @@ with Tbuild; use Tbuild; package body Contracts is + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of package + -- instantiation Inst_Id as if they appear at the end of a declarative + -- region. The pragmas in question are: + -- + --Part_Of + procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id); -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the -- contract-only subprogram body of eligible subprograms found in L, adds @@ -386,6 +393,11 @@ package body Contracts is elsif Nkind (Decl) = N_Object_Declaration then Analyze_Object_Contract (Defining_Entity (Decl)); + -- Package instantiation + + elsif Nkind (Decl) = N_Package_Instantiation then +Analyze_Package_Instantiation_Contract (Defining_Entity (Decl)); + -- Protected units elsif Nkind_In (Decl, N_Protected_Type_Declaration, @@ -1074,17 +1086,6 @@ package body Contracts is end if; end if; - -- Check whether the lack of indicator Part_Of agrees with the placement - -- of the package instantiation with respect to the state space. - - if Is_Generic_Instance (Pack_Id) then - Prag := Get_Pragma (Pack_Id, Pragma_Part_Of); - - if No (Prag) then -Check_Missing_Part_Of (Pack_Id); - end if; - end if; - -- Restore the SPARK_Mode of the enclosing context after all delayed -- pragmas have been analyzed. @@ -1100,6 +1101,62 @@ package body Contracts is end if; end Analyze_Package_Contract; + + -- Analyze_Package_Instantiation_Contract -- + + + -- WARNING: This routine manages SPARK regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- SPARK mode. + + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id) is + Inst_Spec : constant Node_Id :
[Ada] Fix Next_Actual when used on calls "inlined for proof"
The GNATprove backend needs to apply antialiasing checks to subprogram calls that have been rewritten into null statements while "inlining for proof". This requires the First_Actual/Next_Actual to use the Original_Node and not the N_Null_Statement that rewriting leaves as a parent. Only effective in GNATprove mode, so no frontend test provided. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Piotr Trojanek gcc/ada/ * sem_util.adb (Next_Actual): If the parent is a N_Null_Statement, which happens for inlined calls, then fetch the next actual from the original AST.--- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -21033,7 +21033,8 @@ package body Sem_Util is - function Next_Actual (Actual_Id : Node_Id) return Node_Id is - N : Node_Id; + N : Node_Id; + Par : constant Node_Id := Parent (Actual_Id); begin -- If we are pointing at a positional parameter, it is a member of a @@ -21053,11 +21054,22 @@ package body Sem_Util is -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. -if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) +if Nkind_In (Par, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) then - return First_Named_Actual (Parent (Actual_Id)); + return First_Named_Actual (Par); + +-- In case of a call rewritten in GNATprove mode while "inlining +-- for proof" go to the original call. + +elsif Nkind (Par) = N_Null_Statement then + pragma Assert + (GNATprove_Mode +and then + Nkind (Original_Node (Par)) in N_Subprogram_Call); + + return First_Named_Actual (Original_Node (Par)); else return Empty; end if;
[Ada] Add elaboration-related switches to GNAT UGN
This patch adds compiler switches -gnatH and -gnatJ to section "Alphabetical
list of all switches" of the GNAT User Guide for Native.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Hristian Kirtchev
gcc/ada/
* doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add missing
sections on -gnatH and -gnatJ compiler switches.
* gnat_ugn.texi: Regenerate.--- gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -720,9 +720,9 @@ is passed to ``gcc`` (e.g., :switch:`-O`, :switch:`-gnato,` etc.)
.. index:: --RTS (gnatmake)
:switch:`--RTS={rts-path}`
- Specifies the default location of the runtime library. GNAT looks for the
- runtime
- in the following directories, and stops as soon as a valid runtime is found
+ Specifies the default location of the run-time library. GNAT looks for the
+ run-time
+ in the following directories, and stops as soon as a valid run-time is found
(:file:`adainclude` or :file:`ada_source_path`, and :file:`adalib` or
:file:`ada_object_path` present):
@@ -1505,7 +1505,7 @@ Alphabetical List of All Switches
In the example above, the first call to ``Detect_Aliasing`` fails with a
- ``Program_Error`` at runtime because the actuals for ``Val_1`` and
+ ``Program_Error`` at run time because the actuals for ``Val_1`` and
``Val_2`` denote the same object. The second call executes without raising
an exception because ``Self(Obj)`` produces an anonymous object which does
not share the memory location of ``Obj``.
@@ -1817,14 +1817,12 @@ Alphabetical List of All Switches
.. index:: -gnatg (gcc)
:switch:`-gnatg`
- Internal GNAT implementation mode. This should not be used for
- applications programs, it is intended only for use by the compiler
- and its run-time library. For documentation, see the GNAT sources.
- Note that :switch:`-gnatg` implies
- :switch:`-gnatw.ge` and
- :switch:`-gnatyg`
- so that all standard warnings and all standard style options are turned on.
- All warnings and style messages are treated as errors.
+ Internal GNAT implementation mode. This should not be used for applications
+ programs, it is intended only for use by the compiler and its run-time
+ library. For documentation, see the GNAT sources. Note that :switch:`-gnatg`
+ implies :switch:`-gnatw.ge` and :switch:`-gnatyg` so that all standard
+ warnings and all standard style options are turned on. All warnings and style
+ messages are treated as errors.
.. index:: -gnatG[nn] (gcc)
@@ -1839,6 +1837,13 @@ Alphabetical List of All Switches
Output usage information. The output is written to :file:`stdout`.
+.. index:: -gnatH (gcc)
+
+:switch:`-gnatH`
+ Legacy elaboration-checking mode enabled. When this switch is in effect, the
+ pre-18.x access-before-elaboration model becomes the de facto model.
+
+
.. index:: -gnati (gcc)
:switch:`-gnati{c}`
@@ -1874,6 +1879,27 @@ Alphabetical List of All Switches
Reformat error messages to fit on ``nn`` character lines
+.. index:: -gnatJ (gcc)
+
+:switch:`-gnatJ`
+ Permissive elaboration-checking mode enabled. When this switch is in effect,
+ the post-18.x access-before-elaboration model ignores potential issues with:
+
+ - Accept statements
+ - Activations of tasks defined in instances
+ - Assertion pragmas
+ - Calls from within an instance to its enclosing context
+ - Calls through generic formal parameters
+ - Calls to subprograms defined in instances
+ - Entry calls
+ - Indirect calls using 'Access
+ - Requeue statements
+ - Select statements
+ - Synchronous task suspension
+
+ and does not emit compile-time diagnostics or run-time checks.
+
+
.. index:: -gnatk (gcc)
:switch:`-gnatk={n}`
@@ -2195,7 +2221,7 @@ Alphabetical List of All Switches
.. index:: --RTS (gcc)
:switch:`--RTS={rts-path}`
- Specifies the default location of the runtime library. Same meaning as the
+ Specifies the default location of the run-time library. Same meaning as the
equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`).
@@ -5062,7 +5088,7 @@ switches refine this default behavior.
that a certain check will necessarily fail, it will generate code to
do an unconditional 'raise', even if checks are suppressed. The
compiler warns in this case. Another case in which checks may not be
- eliminated is when they are embedded in certain run time routines such
+ eliminated is when they are embedded in certain run-time routines such
as math library routines.
Of course, run-time checks are omitted whenever the compiler can prove
@@ -5858,7 +5884,7 @@ Debugging Control
Exception Handling Control
--
-GNAT uses two methods for handling exceptions at run-time. The
+GNAT uses two methods for handling exceptions at run time. The
``setjmp/longjmp`` method saves the context when entering
a frame with an exception handler. Then whe
[Ada] Secondary stack leak in loop iterator
When the evaluation of the loop iterator invokes a function whose result relies on the secondary stack the compiler does not generate code to release the consumed memory as soon as the loop terminates. After this patch the following test works fine. with Text_IO; use Text_IO; pragma Warnings (Off); with System.Secondary_Stack; pragma Warnings (On); procedure Sec_Stack_Leak is function F (X : String) return Integer is begin return 10; end F; function G (X : Integer) return String is begin return (1 .. X => 'x'); end G; procedure Info is new System.Secondary_Stack.Ss_Info (Put_Line); procedure Nest is begin for I in Integer range 1 .. 100 loop for J in Integer range 1 .. F (G (10_000)) loop null; end loop; Info; end loop; Info; end Nest; begin Info; Nest; Info; end Sec_Stack_Leak; Commands: gnatmake -q sec_stack_leak.adb sec_stack_leak | grep "Current allocated space :" | uniq Output: Current allocated space : 0 bytes Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Javier Miranda gcc/ada/ * sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level to reuse it. (Analyze_Loop_Statement): Wrap the loop in a block when the evaluation of the loop iterator relies on the secondary stack.--- gcc/ada/sem_ch5.adb +++ gcc/ada/sem_ch5.adb @@ -83,6 +83,12 @@ package body Sem_Ch5 is -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; + -- N is the node for an arbitrary construct. This function searches the + -- construct N to see if any expressions within it contain function + -- calls that use the secondary stack, returning True if any such call + -- is found, and False otherwise. + procedure Preanalyze_Range (R_Copy : Node_Id); -- Determine expected type of range or domain of iteration of Ada 2012 -- loop by analyzing separate copy. Do the analysis and resolution of the @@ -2692,12 +2698,6 @@ package body Sem_Ch5 is -- forms. In this case it is not sufficent to check the static predicate -- function only, look for a dynamic predicate aspect as well. - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; - -- N is the node for an arbitrary construct. This function searches the - -- construct N to see if any expressions within it contain function - -- calls that use the secondary stack, returning True if any such call - -- is found, and False otherwise. - procedure Process_Bounds (R : Node_Id); -- If the iteration is given by a range, create temporaries and -- assignment statements block to capture the bounds and perform @@ -2782,65 +2782,6 @@ package body Sem_Ch5 is end if; end Check_Predicate_Use; - - -- Has_Call_Using_Secondary_Stack -- - - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is - function Check_Call (N : Node_Id) return Traverse_Result; - -- Check if N is a function call which uses the secondary stack - - - -- Check_Call -- - - - function Check_Call (N : Node_Id) return Traverse_Result is -Nam : Node_Id; -Subp : Entity_Id; -Typ : Entity_Id; - - begin -if Nkind (N) = N_Function_Call then - Nam := Name (N); - - -- Obtain the subprogram being invoked - - loop - if Nkind (Nam) = N_Explicit_Dereference then - Nam := Prefix (Nam); - - elsif Nkind (Nam) = N_Selected_Component then - Nam := Selector_Name (Nam); - - else - exit; - end if; - end loop; - - Subp := Entity (Nam); - Typ := Etype (Subp); - - if Requires_Transient_Scope (Typ) then - return Abandon; - - elsif Sec_Stack_Needed_For_Return (Subp) then - return Abandon; - end if; -end if; - --- Continue traversing the tree - -return OK; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - -- Start of processing for Has_Call_Using_Secondary_Stack - - begin - return Check_Calls (N) = Abandon; - end Has_Call_Using_Secondary_Stack; - -- Process_Bounds -- @@ -3644,6 +3585,56 @@ package body Sem_Ch5 is end; end if; + -- Wrap the loop in a block when the evaluation of the loop iterator
[Ada] Attach the special GNATprove HEAP entity to the Standard package
In GNATprove mode we use frontend cross-references to synthesize the Global contract of subprograms with SPARK_Mode => Off and represent a read/write via a pointer as a read/write of a special entity called HEAP. This entity is now attached to the Standard package, so that we can safely check the Ekind of its Scope, which now happens in Scope_Within. This only affects GNATprove, so no frontend test provided. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Piotr Trojanek gcc/ada/ * lib-xref-spark_specific.adb (Create_Heap): Attach the HEAP entity to the Standard package.--- gcc/ada/lib-xref-spark_specific.adb +++ gcc/ada/lib-xref-spark_specific.adb @@ -287,6 +287,7 @@ package body SPARK_Specific is Set_Ekind (Heap, E_Variable); Set_Is_Internal (Heap, True); + Set_Scope (Heap, Standard_Standard); Set_Has_Fully_Qualified_Name (Heap); end Create_Heap;
[Ada] Crash on case expression in build-in-place function
This patch modifies the recursive tree replication routine New_Copy_Tree to create new entities and remap old entities to the new ones for constructs in N_Expression_With_Actions nodes when requested by a caller. This in turn allows the build-in-place mechanism to avoid sharing entities between the 4 variants of returns it generates. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * exp_ch6.adb (Build_Heap_Or_Pool_Allocator): Ensure that scoping constructs and entities within receive new entities when replicating a tree. (Expand_N_Extended_Return_Statement): Ensure that scoping constructs and entities within receive new entities when replicating a tree. * sem_util.adb (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. (Visit_Entity): Visit entities within scoping constructs inside expression with actions nodes when requested by the caller. Add blocks, labels, and procedures to the list of entities which need replication. * sem_util.ads (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. Update the comment on usage. gcc/testsuite/ * gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase.--- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -4562,7 +4562,10 @@ package body Exp_Ch6 is Fin_Mas_Id : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); - Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr); + Orig_Expr : constant Node_Id := + New_Copy_Tree +(Source => Alloc_Expr, + Scopes_In_EWA_OK => True); Stmts : constant List_Id := New_List; Desig_Typ : Entity_Id; Local_Id : Entity_Id; @@ -5022,7 +5025,10 @@ package body Exp_Ch6 is Init_Assignment := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Ret_Obj_Id, Loc), - Expression => New_Copy_Tree (Ret_Obj_Expr)); + Expression => +New_Copy_Tree + (Source => Ret_Obj_Expr, + Scopes_In_EWA_OK => True)); Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); @@ -5153,7 +5159,10 @@ package body Exp_Ch6 is Subtype_Mark => New_Occurrence_Of (Etype (Ret_Obj_Expr), Loc), -Expression => New_Copy_Tree (Ret_Obj_Expr))); +Expression => + New_Copy_Tree +(Source => Ret_Obj_Expr, + Scopes_In_EWA_OK => True))); else -- If the function returns a class-wide type we cannot @@ -5193,7 +5202,11 @@ package body Exp_Ch6 is -- except we set Storage_Pool and Procedure_To_Call so -- it will use the user-defined storage pool. - Pool_Allocator := New_Copy_Tree (Heap_Allocator); + Pool_Allocator := + New_Copy_Tree + (Source => Heap_Allocator, + Scopes_In_EWA_OK => True); + pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); -- Do not generate the renaming of the build-in-place @@ -5235,7 +5248,11 @@ package body Exp_Ch6 is -- allocation. else -SS_Allocator := New_Copy_Tree (Heap_Allocator); +SS_Allocator := + New_Copy_Tree +(Source => Heap_Allocator, + Scopes_In_EWA_OK => True); + pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); -- The heap and pool allocators are marked as --- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -19505,10 +19505,11 @@ package body Sem_Util is --- function New_Copy_Tree - (Source: Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope: Entity_Id := Empty; + Scopes_In_EWA_OK : Boolean:= False) return Node_Id is -- This routine per
[Ada] New ignored Ghost code removal mechanism
This patch reimplements the mechanism which removes ignored Ghost code from the
tree.
The previous mechanism proved to be unreliable because it assumed that no new
scoping constructs would be created after some ignored Ghost code had already
notified its enclosing scoping constructs that they contain such code. The
assumption can be broken by having a call to an ignored Ghost procedure within
the extended return statement of a function. The procedure call would signal
the enclosing function that it contains ignored Ghost code, however the return
statement would introduce an extra block, effectively hiding the procedure call
from the ignored Ghost code elimination pass.
The new mechanism implemented in this patch forgoes directed tree pruning in
favor of storing the actual ignored Ghost code, and later directly eliminating
it from the tree.
For this approach to operate efficiently, only "top level" ignored Ghost
constructs are stored. The top level constructs are essentially nodes which can
appear within a declarative or statement list and be safely rewritten into null
statements. This ensures that only "root" ignored Ghost construct need to be
processed, as opposed to all ignored Ghost nodes within a subtree.
The approach has one drawback however. Due to the generation and analysis of
ignored Ghost code, a construct may be recorded multiple times (usually twice).
The mechanism simply deals with this artefact instead of employing expensive
solutions such as hash tables or a common flag shared by all nodes to eliminate
the duplicates.
-- Source --
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
procedure Ghost_Proc with Ghost;
procedure Ghost_Proc is
begin
Put_Line ("ERROR: Ghost_Proc called");
end Ghost_Proc;
function Func return Integer is
begin
return Res : Integer := 123 do
Ghost_Proc;
end return;
end Func;
Val : Integer with Ghost;
begin
Val := Func;
end Main;
-- Compilation and output --
$ gcc -c -gnatDG main.adb
$ grep -c "ghost" main.adb.dg
0
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Hristian Kirtchev
gcc/ada/
* alloc.ads: Update the allocation metrics of the ignored Ghost nodes
table.
* atree.adb: Add a soft link for a procedure which is invoked whenever
an ignored Ghost node or entity is created.
(Change_Node): Preserve relevant attributes which come from the Flags
table.
(Mark_New_Ghost_Node): Record a newly created ignored Ghost node or
entity.
(Rewrite): Preserve relevant attributes which come from the Flags
table.
(Set_Ignored_Ghost_Recording_Proc): New routine.
* atree.ads: Define an access-to-suprogram type for a soft link which
records a newly created ignored Ghost node or entity.
(Set_Ignored_Ghost_Recording_Proc): New routine.
* ghost.adb: Remove with and use clause for Lib. Remove table
Ignored_Ghost_Units. Add new table Ignored_Ghost_Nodes.
(Add_Ignored_Ghost_Unit): Removed.
(Initialize): Initialize the table which stores ignored Ghost nodes.
Set the soft link which allows Atree.Mark_New_Ghost_Node to record an
ignored Ghost node.
(Is_Ignored_Ghost_Unit): Use the ultimate original node when checking
an eliminated ignored Ghost unit.
(Lock): Release and lock the table which stores ignored Ghost nodes.
(Mark_And_Set_Ghost_Assignment): Record rather than propagate ignored
Ghost nodes.
(Mark_And_Set_Ghost_Procedure_Call): Record rather than propagate
ignored Ghost nodes.
(Mark_Ghost_Clause): Record rather than propagate ignored Ghost nodes.
(Mark_Ghost_Declaration_Or_Body): Record rather than propagate ignored
Ghost nodes.
(Mark_Ghost_Pragma): Record rather than propagate ignored Ghost nodes.
(Propagate_Ignored_Ghost_Code): Removed.
(Record_Ignored_Ghost_Node): New routine.
(Remove_Ignored_Ghost_Code): Reimplemented.
(Remove_Ignored_Ghost_Node): New routine.
(Ultimate_Original_Node): New routine.
* ghost.ads (Check_Ghost_Completion): Removed.
* sem_ch8.adb (Analyze_Use_Package): Remove obsolete code. Mark a use
package clause as ignored Ghost if applicable.
* sem_util.adb (Is_Body_Or_Package_Declaration): Reimplemented.--- gcc/ada/alloc.ads
+++ gcc/ada/alloc.ads
@@ -67,8 +67,8 @@ package Alloc is
In_Out_Warnings_Initial : constant := 100;-- Sem_Warn
In_Out_Warnings_Increment: constant := 100;
- Ignored_Ghost_Units_Initial : constant := 20; -- Sem_Util
- Ignored_Ghost_Units_Increment: constant := 50;
+ Ignored_Ghost_Nodes_Initial : constant := 100;-- Ghost
+ Ignored_Ghost_Nodes_Increment: constant := 100;
[Ada] Spurious error on unused Part_Of constituent
This patch updates the analysis of indicator Part_Of (or the lack thereof), to ignore generic formal parameters for purposes of determining the visible state space because they are not visible outside the generic and related instances. -- Source -- -- gen_pack.ads generic In_Formal : in Integer := 0; In_Out_Formal : in out Integer; package Gen_Pack is Exported_In_Formal : Integer renames In_Formal; Exported_In_Out_Formal : Integer renames In_Out_Formal; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack with Abstract_State => State is procedure Force_Body; Val : Integer; private package OK_1 is new Gen_Pack (In_Out_Formal => Val) with Part_Of => State;-- OK package OK_2 is new Gen_Pack (In_Formal => 1, In_Out_Formal => Val) with Part_Of => State;-- OK package Error_1 is-- Error new Gen_Pack (In_Out_Formal => Val); package Error_2 is-- Error new Gen_Pack (In_Formal => 2, In_Out_Formal => Val); end Pack; -- pack.adb package body Pack with Refined_State => -- Error (State => (OK_1.Exported_In_Formal, OK_1.Exported_In_Out_Formal)) is procedure Force_Body is null; end Pack; -- gen_pack.ads generic In_Formal : in Integer := 0; In_Out_Formal : in out Integer; package Gen_Pack is Exported_In_Formal : Integer renames In_Formal; Exported_In_Out_Formal : Integer renames In_Out_Formal; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack with Abstract_State => State is procedure Force_Body; Val : Integer; private package OK_1 is new Gen_Pack (In_Out_Formal => Val) with Part_Of => State;-- OK package OK_2 is new Gen_Pack (In_Formal => 1, In_Out_Formal => Val) with Part_Of => State;-- OK package Error_1 is-- Error new Gen_Pack (In_Out_Formal => Val); package Error_2 is-- Error new Gen_Pack (In_Formal => 2, In_Out_Formal => Val); end Pack; -- pack.adb package body Pack with Refined_State => -- Error (State => (OK_1.Exported_In_Formal, OK_1.Exported_In_Out_Formal)) is procedure Force_Body is null; end Pack; -- Compilation and output -- $ gcc -c pack.adb pack.adb:3:11: state "State" has unused Part_Of constituents pack.adb:3:11: constant "Exported_In_Formal" defined at gen_pack.ads:6, instance at pack.ads:15 pack.adb:3:11: variable "Exported_In_Out_Formal" defined at gen_pack.ads:7, instance at pack.ads:15 pack.ads:19:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:19:12: "Error_1" is declared in the private part of package "Pack" pack.ads:21:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:21:12: "Error_2" is declared in the private part of package "Pack" Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * sem_prag.adb (Has_Visible_State): Do not consider generic formals because they are not part of the visible state space. Add constants to the list of acceptable visible states. (Propagate_Part_Of): Do not consider generic formals when propagating the Part_Of indicator. * sem_util.adb (Entity_Of): Do not follow renaming chains which go through a generic formal because they are not visible for SPARK purposes. * sem_util.ads (Entity_Of): Update the comment on usage.--- gcc/ada/sem_prag.adb +++ gcc/ada/sem_prag.adb @@ -19982,6 +19982,13 @@ package body Sem_Prag is if not Comes_From_Source (Item_Id) then null; + -- Do not consider generic formals or their corresponding + -- actuals because they are not part of a visible state. + -- Note that both entities are marked as hidden. + + elsif Is_Hidden (Item_Id) then +null; + -- The Part_Of indicator turns an abstract state or an -- object into a constituent of the encapsulating state. @@ -28775,9 +28782,19 @@ package body Sem_Prag is if not Comes_From_Source (Item_Id) then null; +-- Do not consider generic formals or their corresponding actuals +-- because they are not part of a visible state. Note that both +-- entities are marked as hidden. + +
[Ada] Secondary stack leak in statements block located in a loop
When a loop iterator has a block declaration containing statements that invoke functions whose result is returned on the secondary stack (such as a string-returning function), the compiler fails to generate code to release the allocated memory when the loop terminates. After this patch the following test works fine. with Ada.Text_IO; use Ada.Text_IO; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; pragma Warnings (Off); with System.Secondary_Stack; pragma Warnings (On); procedure Small is procedure Info is new System.Secondary_Stack.Ss_Info (Put_Line); US : Unbounded_String; begin Info; for J in 1 .. 100_000 loop Leaky_Block : declare begin if (J mod 2) = 0 then Info; end if; Ada.Text_IO.Put_Line (To_String (US)); -- Test if (J mod 2) = 0 then Info; end if; end Leaky_Block; end loop; Info; end; Command: gnatmake small.adb; small | grep "Current allocated space :" | uniq Output: Current allocated space : 0 bytes Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Javier Miranda gcc/ada/ * exp_ch7.adb (Make_Transient_Block): When determining whether an enclosing scope already handles the secondary stack, take into account transient blocks nested in a block that do not manage the secondary stack and are located within a loop.--- gcc/ada/exp_ch7.adb +++ gcc/ada/exp_ch7.adb @@ -8695,9 +8695,33 @@ package body Exp_Ch7 is Action : Node_Id; Par: Node_Id) return Node_Id is + function Within_Loop_Statement (N : Node_Id) return Boolean; + -- Return True when N appears within a loop and no block is containing N + function Manages_Sec_Stack (Id : Entity_Id) return Boolean; -- Determine whether scoping entity Id manages the secondary stack + --- + -- Within_Loop_Statement -- + --- + + function Within_Loop_Statement (N : Node_Id) return Boolean is + Par : Node_Id := Parent (N); + + begin + while not (Nkind_In (Par, + N_Loop_Statement, + N_Handled_Sequence_Of_Statements, + N_Package_Specification) + or else Nkind (Par) in N_Proper_Body) + loop +pragma Assert (Present (Par)); +Par := Parent (Par); + end loop; + + return Nkind (Par) = N_Loop_Statement; + end Within_Loop_Statement; + --- -- Manages_Sec_Stack -- --- @@ -8780,6 +8804,16 @@ package body Exp_Ch7 is elsif Ekind (Scop) = E_Loop then exit; +-- Ditto when the block appears without a block that does not +-- manage the secondary stack and is located within a loop. + +elsif Ekind (Scop) = E_Block + and then not Manages_Sec_Stack (Scop) + and then Present (Block_Node (Scop)) + and then Within_Loop_Statement (Block_Node (Scop)) +then + exit; + -- The transient block does not need to manage the secondary stack -- when there is an enclosing construct which already does that. -- This optimization saves on SS_Mark and SS_Release calls but may
[Ada] Spurious error on Part_Of indicator
This patch modifies the verification of a missing Part_Of indicator to avoid considering constants as visible state of a package instantiation because the compiler cannot determine whether their values depend on variable input. This diagnostic is left to GNATprove. -- Source -- -- gnat.adc pragma SPARK_Mode; -- gen_pack.ads generic package Gen_Pack is Val : constant Integer := 123; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack with Abstract_State => Pack_State is procedure Force_Body; private package Inst_1 is new Gen_Pack; -- OK package Inst_2 is new Gen_Pack with Part_Of => Pack_State;-- OK end Pack; -- pack.adb package body Pack with Refined_State => (Pack_State => Inst_2.Val) is procedure Force_Body is null; end Pack; - -- Compilation -- - $ gcc -c pack.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * sem_prag.adb (Has_Visible_State): Do not consider constants as visible state because it is not possible to determine whether a constant depends on variable input. (Propagate_Part_Of): Add comment clarifying the behavior with respect to constant.--- gcc/ada/sem_prag.adb +++ gcc/ada/sem_prag.adb @@ -19991,6 +19991,9 @@ package body Sem_Prag is -- The Part_Of indicator turns an abstract state or an -- object into a constituent of the encapsulating state. + -- Note that constants are considered here even though + -- they may not depend on variable input. This check is + -- left to the SPARK prover. elsif Ekind_In (Item_Id, E_Abstract_State, E_Constant, @@ -28789,12 +28792,12 @@ package body Sem_Prag is elsif Is_Hidden (Item_Id) then null; --- A visible state has been found +-- A visible state has been found. Note that constants are not +-- considered here because it is not possible to determine whether +-- they depend on variable input. This check is left to the SPARK +-- prover. -elsif Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) -then +elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then return True; -- Recursively peek into nested packages and instantiations
[Ada] Avoid confusing warning on exception propagation in GNATprove mode
When compiling with the restriction No_Exception_Propagation, GNAT compiler may issue a warning about exceptions not being propagated. This warning is useless and confusing to users for GNATprove analysis, as GNATprove precisely detects possible exceptions, so disable the warning in that mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Yannick Moy gcc/ada/ * gnat1drv.adb (Gnat1drv): Do not issue warning about exception not being propagated in GNATprove mode.--- gcc/ada/gnat1drv.adb +++ gcc/ada/gnat1drv.adb @@ -467,6 +467,12 @@ procedure Gnat1drv is Ineffective_Inline_Warnings := True; + -- Do not issue warnings for possible propagation of exception. + -- GNATprove already issues messages about possible exceptions. + + No_Warn_On_Non_Local_Exception := True; + Warn_On_Non_Local_Exception := False; + -- Disable front-end optimizations, to keep the tree as close to the -- source code as possible, and also to avoid inconsistencies between -- trees when using different optimization switches.
[Ada] Crash processing abstract state aspect of a package
The compiler may crash processing an aspect Part_Of used in a package spec which has also an Initial_Condition aspect. After this patch the following test compiles fine. package P with SPARK_Mode => On, Abstract_State => (Count_State), Initial_Condition => (Get_Count = 0) -- Test is type Count_Type is range 0 .. 16; function Get_Count return Count_Type; procedure Dummy; private C: Count_Type := 0 with Part_Of => Count_State; -- Test function Get_Count return Count_Type is (C); end P; package body P with SPARK_Mode => On, Refined_State => (Count_State => C) is procedure Dummy is null; end P; Command: gcc -c p.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Javier Miranda gcc/ada/ * exp_ch13.adb (Expand_N_Freeze_Entity): Handle subtype declared for an iterator. * freeze.adb (Freeze_Expression): Handle freeze of an entity defined outside of a subprogram body. This case was previously handled during preanalysis; the frozen entities were remembered and left pending until we continued freezeing entities outside of the subprogram. Now, when climbing the parents chain to locate the correct placement for the freezeing node, we check if the entity can be frozen and only when no enclosing node is marked as Must_Not_Freeze the entity is frozen. * sem_ch3.ads (Preanalyze_Default_Expression): Declaration moved to the package body. * sem_ch3.adb (Preanalyze_Default_Expression): Code adjusted to invoke the new subprogram Preanalyze_With_Freezing_And_Resolve. * sem_ch6.adb (Preanalyze_Formal_Expression): New subprogram. (Analyze_Expression_Function, Process_Formals): Invoke Preanalyze_Formal_Expression instead of Preanalyze_Spec_Expression since the analysis of the formals may freeze entities. (Analyze_Subprogram_Body_Helper): Skip building the body of the class-wide clone for eliminated subprograms. * sem_res.ads, sem_res.adb (Preanalyze_And_Resolve): New subprogram. Its code is basically the previous version of this routine but extended with an additional parameter which is used to specify if during preanalysis we are allowed to freeze entities. If the new parameter is True then the subtree root node is marked as Must_Not_Freeze and no entities are frozen during preanalysis. (Preanalyze_And_Resolve): Invokes the internal version of Preanalyze_And_Resolve without entity freezing. (Preanalyze_With_Freezing_And_Resolve): Invokes the internal version of Prenalyze_And_Resolve with freezing enabled.--- gcc/ada/exp_ch13.adb +++ gcc/ada/exp_ch13.adb @@ -470,6 +470,11 @@ package body Exp_Ch13 is and then Ekind (E_Scope) not in Concurrent_Kind then E_Scope := Scope (E_Scope); + + -- The entity may be a subtype declared for an iterator. + + elsif Ekind (E_Scope) = E_Loop then + E_Scope := Scope (E_Scope); end if; -- Remember that we are processing a freezing entity and its freezing --- gcc/ada/freeze.adb +++ gcc/ada/freeze.adb @@ -6936,20 +6936,6 @@ package body Freeze is --- procedure Freeze_Expression (N : Node_Id) is - In_Spec_Exp : constant Boolean := In_Spec_Expression; - Typ : Entity_Id; - Nam : Entity_Id; - Desig_Typ : Entity_Id; - P : Node_Id; - Parent_P: Node_Id; - - Freeze_Outside : Boolean := False; - -- This flag is set true if the entity must be frozen outside the - -- current subprogram. This happens in the case of expander generated - -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do - -- not freeze all entities like other bodies, but which nevertheless - -- may reference entities that have to be frozen before the body and - -- obviously cannot be frozen inside the body. function Find_Aggregate_Component_Desig_Type return Entity_Id; -- If the expression is an array aggregate, the type of the component @@ -7038,6 +7024,29 @@ package body Freeze is end if; end In_Expanded_Body; + -- Local variables + + In_Spec_Exp : constant Boolean := In_Spec_Expression; + Typ : Entity_Id; + Nam : Entity_Id; + Desig_Typ : Entity_Id; + P : Node_Id; + Parent_P: Node_Id; + + Freeze_Outside : Boolean := False; + -- This flag is set true if the entity must be frozen outside the + -- current subprogram. This happens in the case of expander generated + -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do + -- not freeze all entities like other bodies, but which nevertheless + -- may reference entities that have to be frozen before the body and + -- obviously cannot be
[Ada] Missing check on illegal equality operation in subprogram
In Ada2012 it is illegal to declare an equality operation on an untagged
type when the operation is primitive and the type is already frozem (see
RM 4.5.2 (9.8)). previously the test to detect this illegality only examined
declarations within a package. This patch covers the case where type and
operation are both declared within a subprogram body.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Ed Schonberg
gcc/ada/
* sem_ch6.adb (Check_Untagged_Equality): Extend check to operations
declared in the same scope as the operand type, when that scope is a
procedure.
gcc/testsuite/
* gnat.dg/equal3.adb: New testcase.--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -8581,14 +8581,10 @@ package body Sem_Ch6 is
if Is_Frozen (Typ) then
- -- If the type is not declared in a package, or if we are in the body
- -- of the package or in some other scope, the new operation is not
- -- primitive, and therefore legal, though suspicious. Should we
- -- generate a warning in this case ???
+ -- The check applies to a primitive operation, so check that type
+ -- and equality operation are in the same scope.
- if Ekind (Scope (Typ)) /= E_Package
- or else Scope (Typ) /= Current_Scope
- then
+ if Scope (Typ) /= Current_Scope then
return;
-- If the type is a generic actual (sub)type, the operation is not
@@ -8631,7 +8627,7 @@ package body Sem_Ch6 is
("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
end if;
--- Otherwise try to find the freezing point
+-- Otherwise try to find the freezing point for better message.
else
Obj_Decl := Next (Parent (Typ));
@@ -8659,6 +8655,13 @@ package body Sem_Ch6 is
end if;
exit;
+
+ -- If we reach generated code for subprogram declaration
+ -- or body, it is the body that froze the type and the
+ -- declaration is legal.
+
+ elsif Sloc (Obj_Decl) = Sloc (Decl) then
+ return;
end if;
Next (Obj_Decl);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/equal3.adb
@@ -0,0 +1,22 @@
+-- { dg-do compile }
+
+procedure Equal3 is
+type R is record
+ A, B : Integer;
+end record;
+
+package Pack is
+ type RR is record
+ C : R;
+ end record;
+
+ X : RR := (C => (A => 1, B => 1));
+ Y : RR := (C => (A => 1, B => 2));
+ pragma Assert (X /= Y); --@ASSERT:PASS
+
+end Pack;
+use Pack;
+function "=" (X, Y : R) return Boolean is (X.A = Y.A); -- { dg-error "equality operator must be declared before type \"R\" is frozen \\(RM 4.5.2 \\(9.8\\)\\) \\(Ada 2012\\)" }
+begin
+pragma Assert (X /= Y); --@ASSERT:FAIL
+end Equal3;
[Ada] Argument_String_To_List creates empty items from whitespace
This patch corrects an issue whereby leading whitespace in a non-quoted argument list passed to Argument_String_To_List caused extraneous empty arguments to be returned. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Justin Squirek gcc/ada/ * libgnat/s-os_lib.adb (Argument_String_To_List): Fix trimming of whitespace. gcc/testsuite/ * gnat.dg/split_args.adb: New testcase.--- gcc/ada/libgnat/s-os_lib.adb +++ gcc/ada/libgnat/s-os_lib.adb @@ -178,7 +178,6 @@ package body System.OS_Lib is return Len; end Args_Length; - - -- Argument_String_To_List -- - @@ -191,6 +190,9 @@ package body System.OS_Lib is Idx : Integer; New_Argc : Natural := 0; + Backqd : Boolean := False; + Quoted : Boolean := False; + Cleaned : String (1 .. Arg_String'Length); Cleaned_Idx : Natural; -- A cleaned up version of the argument. This function is taking @@ -205,75 +207,71 @@ package body System.OS_Lib is Idx := Arg_String'First; loop - exit when Idx > Arg_String'Last; + -- Skip extraneous spaces - declare -Backqd : Boolean := False; -Quoted : Boolean := False; - - begin -Cleaned_Idx := Cleaned'First; + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop +Idx := Idx + 1; + end loop; -loop - -- An unquoted space is the end of an argument + exit when Idx > Arg_String'Last; - if not (Backqd or Quoted) - and then Arg_String (Idx) = ' ' - then - exit; + Cleaned_Idx := Cleaned'First; + Backqd := False; + Quoted := False; - -- Start of a quoted string + loop +-- An unquoted space is the end of an argument - elsif not (Backqd or Quoted) - and then Arg_String (Idx) = '"' - then - Quoted := True; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; +if not (Backqd or Quoted) + and then Arg_String (Idx) = ' ' +then + exit; - -- End of a quoted string and end of an argument +-- Start of a quoted string - elsif (Quoted and not Backqd) - and then Arg_String (Idx) = '"' - then - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - Idx := Idx + 1; - exit; +elsif not (Backqd or Quoted) + and then Arg_String (Idx) = '"' +then + Quoted := True; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; - -- Turn off backquoting after advancing one character +-- End of a quoted string and end of an argument - elsif Backqd then - Backqd := False; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; +elsif (Quoted and not Backqd) + and then Arg_String (Idx) = '"' +then + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + Idx := Idx + 1; + exit; - -- Following character is backquoted +-- Turn off backquoting after advancing one character - elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then - Backqd := True; +elsif Backqd then + Backqd := False; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; - else - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - end if; +-- Following character is backquoted - Idx := Idx + 1; - exit when Idx > Arg_String'Last; -end loop; +elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then + Backqd := True; --- Found an argument +else + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; +end if; -New_Argc := New_Argc + 1; -New_Argv (New_Argc) := - new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); +Idx := Idx + 1; +exit when Idx > Arg_String'Last; + end loop; --- Skip extraneous spaces + -- Found an argument -while Idx <= Arg_String'Last and th
[Ada] Minor fix for imported C++ constructors
C++ constructors are imported as functions and then internally rewritten into procedures taking the "this" pointer as first parameter. Now this parameter is not of an access type but of the type directly, so it must be In/Out and not just In. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Eric Botcazou gcc/ada/ * exp_disp.adb (Gen_Parameters_Profile): Make the _Init parameter an In/Out parameter. (Set_CPP_Constructors): Adjust comment accordingly.--- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -8181,7 +8181,8 @@ package body Exp_Disp is function Gen_Parameters_Profile (E : Entity_Id) return List_Id; -- Duplicate the parameters profile of the imported C++ constructor - -- adding an access to the object as an additional parameter. + -- adding the "this" pointer to the object as the additional first + -- parameter under the usual form _Init : in out Typ. -- Gen_Parameters_Profile -- @@ -8198,6 +8199,8 @@ package body Exp_Disp is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, Parameter_Type => New_Occurrence_Of (Typ, Loc))); if Present (Parameter_Specifications (Parent (E))) then @@ -8244,9 +8247,7 @@ package body Exp_Disp is Found := True; Loc := Sloc (E); Parms := Gen_Parameters_Profile (E); -IP:= - Make_Defining_Identifier (Loc, -Chars => Make_Init_Proc_Name (Typ)); +IP:= Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); -- Case 1: Constructor of untagged type @@ -8273,14 +8274,14 @@ package body Exp_Disp is -- Case 2: Constructor of a tagged type --- In this case we generate the IP as a wrapper of the the --- C++ constructor because IP must also save copy of the _tag +-- In this case we generate the IP routine as a wrapper of the +-- C++ constructor because IP must also save a copy of the _tag -- generated in the C++ side. The copy of the _tag is used by -- Build_CPP_Init_Procedure to elaborate derivations of C++ types. -- Generate: --- procedure IP (_init : Typ; ...) is ---procedure ConstructorP (_init : Typ; ...); +-- procedure IP (_init : in out Typ; ...) is +--procedure ConstructorP (_init : in out Typ; ...); --pragma Import (ConstructorP); -- begin --ConstructorP (_init, ...); @@ -8352,7 +8353,7 @@ package body Exp_Disp is loop -- Skip the following assertion with primary tags -- because Related_Type is not set on primary tag --- components +-- components. pragma Assert (Tag_Comp = First_Tag_Component (Typ)
[Ada] Assertion_Policy for class-wide precondition
This patch fixes the compiler to that class-wide preconditions on primitive operations of interfaces are not checked at run time when the Assertion_Policy indicates that they should be ignored. This is required by the RM. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Bob Duff gcc/ada/ * exp_disp.adb (Build_Class_Wide_Check): Return early if the precondition is supposed to be ignored.--- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -809,7 +809,7 @@ package body Exp_Disp is Prec := Next_Pragma (Prec); end loop; -if No (Prec) then +if No (Prec) or else Is_Ignored (Prec) then return; end if;
[Ada] Configuration state not observed for instance bodies
This patch ensures that the processing of instantiated and inlined bodies uses the proper configuration context available at the point of the instantiation or inlining. Previously configuration pragmas which appear prior to the context items of a unit would lose their effect when a body is instantiated or inlined. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * frontend.adb (Frontend): Update the call to Register_Config_Switches. * inline.ads: Add new component Config_Switches to record Pending_Body_Info which captures the configuration state of the pending body. Remove components Version, Version_Pragma, SPARK_Mode, and SPARK_Mode_Pragma from record Pending_Body_Info because they are already captured in component Config_Switches. * opt.adb (Register_Opt_Config_Switches): Rename to Register_Config_Switches. (Restore_Opt_Config_Switches): Rename to Restore_Config_Switches. (Save_Opt_Config_Switches): Rename to Save_Config_Switches. This routine is now a function, and returns the saved configuration state as an aggregate to avoid missing an attribute. (Set_Opt_Config_Switches): Rename to Set_Config_Switches. * opt.ads (Register_Opt_Config_Switches): Rename to Register_Config_Switches. (Restore_Opt_Config_Switches): Rename to Restore_Config_Switches. (Save_Opt_Config_Switches): Rename to Save_Config_Switches. This routine is now a function. (Set_Opt_Config_Switches): Rename to Set_Config_Switches. * par.adb (Par): Update the calls to configuration switch-related subprograms. * sem.adb (Semantics): Update the calls to configuration switch-related subprograms. * sem_ch10.adb (Analyze_Package_Body_Stub): Update the calls to configuration switch-related subprograms. (Analyze_Protected_Body_Stub): Update the calls to configuration switch-related subprograms. (Analyze_Subprogram_Body_Stub): Update calls to configuration switch-related subprograms. * sem_ch12.adb (Add_Pending_Instantiation): Update the capture of pending instantiation attributes. (Inline_Instance_Body): Update the capture of pending instantiation attributes. It is no longer needed to explicitly manipulate the SPARK mode. (Instantiate_Package_Body): Update the restoration of the context attributes. (Instantiate_Subprogram_Body): Update the restoration of context attributes. (Load_Parent_Of_Generic): Update the capture of pending instantiation attributes. (Set_Instance_Env): Update the way relevant configuration attributes are saved and restored. gcc/testsuite/ * gnat.dg/config_pragma1.adb, gnat.dg/config_pragma1_pkg.ads: New testcase.--- gcc/ada/frontend.adb +++ gcc/ada/frontend.adb @@ -303,7 +303,7 @@ begin -- capture the values of the configuration switches (see Opt for further -- details). - Opt.Register_Opt_Config_Switches; + Register_Config_Switches; -- Check for file which contains No_Body pragma --- gcc/ada/inline.ads +++ gcc/ada/inline.ads @@ -63,21 +63,24 @@ package Inline is -- See full description in body of Sem_Ch12 for more details type Pending_Body_Info is record - Inst_Node : Node_Id; - -- Node for instantiation that requires the body - Act_Decl : Node_Id; -- Declaration for package or subprogram spec for instantiation - Expander_Status : Boolean; - -- If the body is instantiated only for semantic checking, expansion - -- must be inhibited. + Config_Switches : Config_Switches_Type; + -- Capture the values of configuration switches Current_Sem_Unit : Unit_Number_Type; -- The semantic unit within which the instantiation is found. Must be -- restored when compiling the body, to insure that internal entities -- use the same counter and are unique over spec and body. + Expander_Status : Boolean; + -- If the body is instantiated only for semantic checking, expansion + -- must be inhibited. + + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + Scope_Suppress : Suppress_Record; Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save suppress information at the point of instantiation. Used to @@ -93,21 +96,8 @@ package Inline is -- This means we have to capture this information from the current scope -- at the point of instantiation. - Version : Ada_Version_Type; - -- The body must be compiled with the same language version as the - -- spec. The version may be set by a configuration pragma in a separate - -- file or in the current file, and may differ from body to body. - - Versio
[Ada] Use standard version of s-memory.adb for mingw32
This patch switches mingw32 targets to use the standard version of s-memory.adb as Windows now has the capability of limiting the amount of memory used by process. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Patrick Bernardi gcc/ada/ * libgnat/s-memory__mingw.adb: Remove. * Makefile.rtl: Remove s-memory.adb target pair from the Cygwin/Mingw32 section. gcc/testsuite/ * gnat.dg/memorytest.adb: New testcase.--- gcc/ada/Makefile.rtl +++ gcc/ada/Makefile.rtl @@ -1960,19 +1960,17 @@ endif # Cygwin/Mingw32 ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) # Cygwin provides a full Posix environment, and so we use the default - # versions of s-memory and g-socthi rather than the Windows-specific - # MinGW versions. Ideally we would use all the default versions for - # Cygwin and none of the MinGW versions, but for historical reasons - # the Cygwin port has always been a CygMing frankenhybrid and it is - # a long-term project to disentangle them. + # versions g-socthi rather than the Windows-specific MinGW version. + # Ideally we would use all the default versions for Cygwin and none + # of the MinGW versions, but for historical reasons the Cygwin port + # has always been a CygMing frankenhybrid and it is a long-term project + # to disentangle them. ifeq ($(strip $(filter-out cygwin%,$(target_os))),) LIBGNAT_TARGET_PAIRS = \ -s-memory.adbhttp://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- --- - --- This version provides ways to limit the amount of used memory for systems --- that do not have OS support for that. - --- The amount of available memory available for dynamic allocation is limited --- by setting the environment variable GNAT_MEMORY_LIMIT to the number of --- kilobytes that can be used. --- --- Windows is currently using this version. - -with Ada.Exceptions; -with System.Soft_Links; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - function msize (Ptr : System.Address) return size_t; - pragma Import (C, msize, "_msize"); - - function getenv (Str : String) return System.Address; - pragma Import (C, getenv); - - function atoi (Str : System.Address) return Integer; - pragma Import (C, atoi); - - Available_Memory : size_t := 0; - -- Amount of memory that is available for heap allocations. - -- A value of 0 means that the amount is not yet initialized. - - Msize_Accuracy : constant := 4096; - -- Defines the amount of memory to add to requested allocation sizes, - -- because malloc may return a bigger block than requested. As msize - -- is used when by Free, it must be used on allocation as well. To - -- prevent underflow of available_memory we need to use a reserve. - - procedure Check_Available_Memory (Size : size_t); - -- This routine must be called while holding the task lock. When the - -- memory limit is not yet initialized, it will be set to the value of - -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that - -- does not exist. If the size is larger than the amount of available - -- memory, the task lock will be freed and a storage_error exception - -- will be raised. - - --- - -- Alloc -- - --- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - if Actual_Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_malloc (Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory - msize (Result); -
[Ada] Faulty ignored Ghost code removal
This patch ensures that removal of ignored Ghost code is the absolute last operation performed on the tree. Previously the removal was performed prior to issuing delayed warnings, however the warning mechanism may see a heavily modified tree and fail. No small reproducer available. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * frontend.adb (Frontend): The removal of ignored Ghost code must be the last semantic operation performed on the tree.--- gcc/ada/frontend.adb +++ gcc/ada/frontend.adb @@ -451,11 +451,6 @@ begin Check_Elaboration_Scenarios; - -- Remove any ignored Ghost code as it must not appear in the - -- executable. - - Remove_Ignored_Ghost_Code; - -- Examine all top level scenarios collected during analysis and -- resolution in order to diagnose conditional ABEs, even in the -- presence of serious errors. @@ -483,6 +478,14 @@ begin Sem_Warn.Output_Unreferenced_Messages; Sem_Warn.Check_Unused_Withs; Sem_Warn.Output_Unused_Warnings_Off_Warnings; + +-- Remove any ignored Ghost code as it must not appear in the +-- executable. This action must be performed last because it +-- heavily alters the tree. + +if Operating_Mode = Generate_Code or else GNATprove_Mode then + Remove_Ignored_Ghost_Code; +end if; end if; end if; end;
[Ada] Fix incompatibility Default_Scalar_Storage_Order/tagged types
The pragma Default_Scalar_Storage_Order cannot reliably be used to set the
non-default scalar storage order for a program that declares tagged types, if
it also declares user-defined primitives.
This is fixed by making Make_Tags use the same base array type as Make_DT and
Make_Secondary_DT when accessing the array of user-defined primitives.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Eric Botcazou
gcc/ada/
* exp_disp.adb (Make_Tags): When the type has user-defined primitives,
build the access type that is later used by Build_Get_Prim_Op_Address
as pointing to a subtype of Ada.Tags.Address_Array.
gcc/testsuite/
* gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase.--- gcc/ada/exp_disp.adb
+++ gcc/ada/exp_disp.adb
@@ -7179,7 +7179,7 @@ package body Exp_Disp is
Analyze_List (Result);
-- Generate:
- -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
+ -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
-- type Typ_DT_Acc is access Typ_DT;
else
@@ -7196,20 +7196,19 @@ package body Exp_Disp is
Name_DT_Prims_Acc);
begin
Append_To (Result,
- Make_Full_Type_Declaration (Loc,
+ Make_Subtype_Declaration (Loc,
Defining_Identifier => DT_Prims,
-Type_Definition =>
- Make_Constrained_Array_Definition (Loc,
-Discrete_Subtype_Definitions => New_List (
- Make_Range (Loc,
-Low_Bound => Make_Integer_Literal (Loc, 1),
-High_Bound => Make_Integer_Literal (Loc,
- DT_Entry_Count
- (First_Tag_Component (Typ),
-Component_Definition =>
- Make_Component_Definition (Loc,
-Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc);
+Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Address_Array), Loc),
+Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, New_List (
+Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc,
+ DT_Entry_Count
+ (First_Tag_Component (Typ);
Append_To (Result,
Make_Full_Type_Declaration (Loc,
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/sso10.adb
@@ -0,0 +1,16 @@
+-- { dg-do run }
+
+with SSO10_Pkg; use SSO10_Pkg;
+
+procedure SSO10 is
+
+ procedure Inner (R : Root'Class) is
+ begin
+Run (R);
+ end;
+
+ R : Root;
+
+begin
+ Inner (R);
+end;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/sso10_pkg.ads
@@ -0,0 +1,9 @@
+pragma Default_Scalar_Storage_Order (High_Order_First);
+
+package SSO10_Pkg is
+
+ type Root is tagged null record;
+
+ procedure Run (R : Root) is null;
+
+end SSO10_Pkg;
[Ada] Spurious error on prefixed call in an instantiation
This patch fixes a spurious error on a prefixed call in an instance, when the generic parameters include an interface type and an abstract operation of that type, and the actuals in the instance include an interface type and a corresponding abstract operation of it, with a different name than the corresponding generic subprogram parameter. The patch also fixes a similar error involving class-wide operations and generic private types. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Ed Schonberg gcc/ada/ * sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call in an instance, when the generic parameters include an interface type and a abstract operation of that type, and the actuals in the instance include an interface type and a corresponding abstract operation of it, with a different name than the corresponding generic subprogram parameter. gcc/testsuite/ * gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New testcase.--- gcc/ada/sem_ch4.adb +++ gcc/ada/sem_ch4.adb @@ -8928,11 +8928,38 @@ package body Sem_Ch4 is (Anc_Type : Entity_Id; Error: out Boolean) is +Candidate : Entity_Id; +-- If homonym is a renaming, examine the renamed program + Cls_Type: Entity_Id; Hom : Entity_Id; Hom_Ref : Node_Id; Success : Boolean; +function First_Formal_Match + (Typ : Entity_Id) return Boolean; +-- Predicate to verify that the first formal of a class-wide +-- candidate matches the type of the prefix. + + +-- First_Formal_Match -- + + +function First_Formal_Match + (Typ : Entity_Id) return Boolean +is + Ctrl : constant Entity_Id := First_Formal (Candidate); +begin + return Present (Ctrl) + and then + (Base_Type (Etype (Ctrl)) = Typ + or else + (Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type + and then + Base_Type +(Designated_Type (Etype (Ctrl))) = Typ)); +end First_Formal_Match; + begin Error := False; @@ -8948,25 +8975,23 @@ package body Sem_Ch4 is while Present (Hom) loop if Ekind_In (Hom, E_Procedure, E_Function) - and then (not Is_Hidden (Hom) or else In_Instance) - and then Scope (Hom) = Scope (Base_Type (Anc_Type)) - and then Present (First_Formal (Hom)) - and then - (Base_Type (Etype (First_Formal (Hom))) = Cls_Type - or else - (Is_Access_Type (Etype (First_Formal (Hom))) - and then - Ekind (Etype (First_Formal (Hom))) = - E_Anonymous_Access_Type - and then - Base_Type - (Designated_Type (Etype (First_Formal (Hom = - Cls_Type)) + and then Present (Renamed_Entity (Hom)) + and then Is_Generic_Actual_Subprogram (Hom) + then + Candidate := Renamed_Entity (Hom); + else + Candidate := Hom; + end if; + + if Ekind_In (Candidate, E_Procedure, E_Function) + and then (not Is_Hidden (Candidate) or else In_Instance) + and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) + and then First_Formal_Match (Cls_Type) then -- If the context is a procedure call, ignore functions -- in the name of the call. - if Ekind (Hom) = E_Function + if Ekind (Candidate) = E_Function and then Nkind (Parent (N)) = N_Procedure_Call_Statement and then N = Name (Parent (N)) then @@ -8975,7 +9000,7 @@ package body Sem_Ch4 is -- If the context is a function call, ignore procedures -- in the name of the call. - elsif Ekind (Hom) = E_Procedure + elsif Ekind (Candidate) = E_Procedure and then Nkind (Parent (N)) /= N_Procedure_Call_Statement then goto Next_Hom; @@ -8986,7 +9011,7 @@ package body Sem_Ch4 is Success := False; if No (Matching_Op) then - Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog)); + Hom_Ref
[Ada] Spurious error -- "allocation from empty storage pool"
This patch fixes a bug in which if "pragma Default_Storage_Pool (null);"
is given, then a build-in-place function will get an incorrect error
message "allocation from empty storage pool" even though there is no
such allocation in the source program.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Bob Duff
gcc/ada/
* sem_res.adb (Resolve_Allocator): Do not complain about the
implicit allocator that occurs in the expansion of a return
statement for a build-in-place function.--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -5035,9 +5035,14 @@ package body Sem_Res is
end;
end if;
- -- Check for allocation from an empty storage pool
+ -- Check for allocation from an empty storage pool. But do not complain
+ -- if it's a return statement for a build-in-place function, because the
+ -- allocator is there just in case the caller uses an allocator. If the
+ -- caller does use an allocator, it will be caught at the call site.
- if No_Pool_Assigned (Typ) then
+ if No_Pool_Assigned (Typ)
+and then not Alloc_For_BIP_Return (N)
+ then
Error_Msg_N ("allocation from empty storage pool!", N);
-- If the context is an unchecked conversion, as may happen within an
[Ada] Deconstruct 'F' as a prefix for an ALI data
In GNATprove we used to store a variant of cross-reference information in
the ALI file in lines that started with an 'F' letter. This is no longer
the case, so the letter can be returned to the pool of unused prefixes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Piotr Trojanek
gcc/ada/
* ali.adb (Known_ALI_Lines): Remove 'F' as a prefix for lines
related to the FORMAL analysis done by GNATprove.--- gcc/ada/ali.adb
+++ gcc/ada/ali.adb
@@ -39,7 +39,7 @@ package body ALI is
-- line type markers in the ALI file. This is used in Scan_ALI to detect
-- (or skip) invalid lines. The following letters are still available:
--
- --B G H J K O Q Z
+ --B F G H J K O Q Z
Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
('V'=> True, -- version
@@ -59,7 +59,6 @@ package body ALI is
'Y'=> True, -- limited_with
'Z'=> True, -- implicit with from instantiation
'C'=> True, -- SCO information
- 'F'=> True, -- SPARK cross-reference information
'T'=> True, -- task stack information
others => False);
[Ada] Spurious warning on iteration over range of 64-bit modular type
This patch suppresses a spurious warning on the use of a 64-bit modular type
in a quantified expression, where the range of iteration will include a bound
that appears larger than the run-time representation of Universal_Integer'last.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Ed Schonberg
gcc/ada/
* sem_eval.adb (Check_Non_Static_Context): Do not warn on an
integer literal greater than the upper bound of
Universal_Integer'Last when expansion is disabled, to avoid a
spurious warning over ranges involving 64-bit modular types.
gcc/testsuite/
* gnat.dg/iter3.adb: New testcase.--- gcc/ada/sem_eval.adb
+++ gcc/ada/sem_eval.adb
@@ -547,9 +547,15 @@ package body Sem_Eval is
-- called in contexts like the expression of a number declaration where
-- we certainly want to allow out of range values.
+ -- We inhibit the warning when expansion is disabled, because the
+ -- preanalysis of a range of a 64-bit modular type may appear to
+ -- violate the constraint on non-static Universal_Integer. If there
+ -- is a true overflow it will be diagnosed during full analysis.
+
if Etype (N) = Universal_Integer
and then Nkind (N) = N_Integer_Literal
and then Nkind (Parent (N)) in N_Subexpr
+and then Expander_Active
and then
(Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
or else
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter3.adb
@@ -0,0 +1,15 @@
+-- { dg-do compile }
+-- { dg-options "-gnata" }
+
+procedure Iter3 is
+ type Mod64 is mod 2 ** 64;
+
+ function F (X : Mod64) return Boolean is (X /= Mod64'Last);
+begin
+ pragma Assert (for all X in Mod64 => F(X));
+ pragma Assert (for all X in Mod64'Range => F(X));
+
+ for X in Mod64'Range loop
+ null;
+ end loop;
+end;
[Ada] Replace low-level calls to Ekind with high-level calls to Is_Formal
High-level wrappers are easier to read. This change came up while reading some code related to GNATprove, but then uniformly applied to the entire frontend. For the few remaining membership tests that could be replaced by Is_Formal it is not obvious whether the high-level routine makes the code better. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Piotr Trojanek gcc/ada/ * exp_aggr.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb, repinfo.adb, sem_ch9.adb: Minor replace Ekind membership tests with a wrapper routine.--- gcc/ada/exp_aggr.adb +++ gcc/ada/exp_aggr.adb @@ -7278,7 +7278,7 @@ package body Exp_Aggr is (Nkind (Expr_Q) = N_Type_Conversion or else (Is_Entity_Name (Expr_Q) - and then Ekind (Entity (Expr_Q)) in Formal_Kind)) + and then Is_Formal (Entity (Expr_Q and then Tagged_Type_Expansion then Static_Components := False; --- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -12547,7 +12547,7 @@ package body Exp_Ch4 is Sel_Comp := Parent (Sel_Comp); end loop; - return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; + return Is_Formal (Entity (Prefix (Sel_Comp))); end Prefix_Is_Formal_Parameter; -- Start of processing for Has_Inferable_Discriminants --- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -6799,7 +6799,7 @@ package body Exp_Ch6 is and then (Nkind_In (Exp, N_Type_Conversion, N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind)) + and then Is_Formal (Entity (Exp then -- When the return type is limited, perform a check that the tag of -- the result is the same as the tag of the return type. @@ -6877,7 +6877,7 @@ package body Exp_Ch6 is or else Nkind_In (Exp, N_Type_Conversion, N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind) + and then Is_Formal (Entity (Exp))) or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) then --- gcc/ada/lib-xref.adb +++ gcc/ada/lib-xref.adb @@ -1034,7 +1034,7 @@ package body Lib.Xref is -- parameters may end up being marked as not coming from source -- although they are. Take these into account specially. - elsif GNATprove_Mode and then Ekind (E) in Formal_Kind then + elsif GNATprove_Mode and then Is_Formal (E) then Ent := E; -- Entity does not come from source, but is a derived subprogram and --- gcc/ada/repinfo.adb +++ gcc/ada/repinfo.adb @@ -428,7 +428,7 @@ package body Repinfo is List_Entities (E, Bytes_Big_Endian, True); - elsif Ekind (E) in Formal_Kind and then In_Subprogram then + elsif Is_Formal (E) and then In_Subprogram then null; elsif Ekind_In (E, E_Entry, --- gcc/ada/sem_ch9.adb +++ gcc/ada/sem_ch9.adb @@ -2358,7 +2358,7 @@ package body Sem_Ch9 is if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) and then (not Is_Entity_Name (Target_Obj) - or else Ekind (Entity (Target_Obj)) not in Formal_Kind + or else not Is_Formal (Entity (Target_Obj)) or else Enclosing /= Scope (Entity (Target_Obj))) then Error_Msg_N
[Ada] Compiler failure on an extended_return_statement in a block
When compiling with an assertion-enabled compiler, Assert_Failure can be
raised when expanded an extended_return_statement whose enclosing scope
is not a function (such as when it's a block_statement). The simple fix
is to change the Assert to test Current_Subprogram rather than Current_Scope.
Three such Assert pragmas are corrected in this way.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Gary Dismukes
gcc/ada/
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Replace
calls to Current_Scope in three assertions with calls to
Current_Subprogram.
gcc/testsuite/
* gnat.dg/block_ext_return_assert_failure.adb: New testcase.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -4763,7 +4763,7 @@ package body Exp_Ch6 is
-- the pointer to the object) they are always handled by means of
-- simple return statements.
- pragma Assert (not Is_Thunk (Current_Scope));
+ pragma Assert (not Is_Thunk (Current_Subprogram));
if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
Exp := Expression (Ret_Obj_Decl);
@@ -4772,9 +4772,9 @@ package body Exp_Ch6 is
-- then F and G are both b-i-p, or neither b-i-p.
if Nkind (Exp) = N_Function_Call then
-pragma Assert (Ekind (Current_Scope) = E_Function);
+pragma Assert (Ekind (Current_Subprogram) = E_Function);
pragma Assert
- (Is_Build_In_Place_Function (Current_Scope) =
+ (Is_Build_In_Place_Function (Current_Subprogram) =
Is_Build_In_Place_Function_Call (Exp));
null;
end if;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/block_ext_return_assert_failure.adb
@@ -0,0 +1,24 @@
+-- { dg-do compile }
+
+-- This test used to crash a compiler with assertions enabled
+
+procedure Block_Ext_Return_Assert_Failure is
+
+ function Return_Int return Integer is
+ begin
+ return 123;
+ end Return_Int;
+
+ function F return Integer is
+ begin
+ declare
+ begin
+ return Result : constant Integer := Return_Int do
+null;
+ end return;
+ end;
+ end F;
+
+begin
+ null;
+end Block_Ext_Return_Assert_Failure;
[Ada] Spurious error on the placement of aspect Global
This patch modifies the expansion of stand-alone subprogram bodies that appear in the body of a protected type to properly associate aspects and pragmas to the newly created spec for the subprogram body. As a result, the annotations are properly associated with the initial declaration of the subprogram. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Hristian Kirtchev gcc/ada/ * exp_ch9.adb (Analyze_Pragmas): New routine. (Build_Private_Protected_Declaration): Code clean up. Relocate relevant aspects and pragmas from the stand-alone body to the newly created spec. Explicitly analyze any pragmas that have been either relocated or produced by the analysis of the aspects. (Move_Pragmas): New routine. * sem_prag.adb (Find_Related_Declaration_Or_Body): Recognize the case where a pragma applies to the internally created spec for a stand-along subprogram body declared in a protected body. gcc/testsuite/ * gnat.dg/global.adb, gnat.dg/global.ads: New testcase.--- gcc/ada/exp_ch9.adb +++ gcc/ada/exp_ch9.adb @@ -23,6 +23,7 @@ -- -- -- +with Aspects; use Aspects; with Atree;use Atree; with Einfo;use Einfo; with Elists; use Elists; @@ -53,6 +54,7 @@ with Sem_Ch9; use Sem_Ch9; with Sem_Ch11; use Sem_Ch11; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo;use Sinfo; @@ -290,7 +292,7 @@ package body Exp_Ch9 is (N : Node_Id; Pid : Node_Id) return Node_Id; -- This routine constructs the unprotected version of a protected - -- subprogram body, which is contains all of the code in the original, + -- subprogram body, which contains all of the code in the original, -- unexpanded body. This is the version of the protected subprogram that is -- called from all protected operations on the same object, including the -- protected version of the same subprogram. @@ -3483,14 +3485,95 @@ package body Exp_Ch9 is function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id is + procedure Analyze_Pragmas (From : Node_Id); + -- Analyze all pragmas which follow arbitrary node From + + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Find all suitable source pragmas at the top of subprogram body From's + -- declarations and insert them after arbitrary node To. + + - + -- Analyze_Pragmas -- + - + + procedure Analyze_Pragmas (From : Node_Id) is + Decl : Node_Id; + + begin + Decl := Next (From); + while Present (Decl) loop +if Nkind (Decl) = N_Pragma then + Analyze_Pragma (Decl); + +-- No candidate pragmas are available for analysis + +else + exit; +end if; + +Next (Decl); + end loop; + end Analyze_Pragmas; + + -- + -- Move_Pragmas -- + -- + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Insert_Nod : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The pragmas are moved in an order-preserving fashion + + Insert_Nod := To; + + -- Inspect the declarations of the subprogram body and relocate all + -- candidate pragmas. + + Decl := First (Declarations (From)); + while Present (Decl) loop + +-- Preserve the following declaration for iteration purposes, due +-- to possible relocation of a pragma. + +Next_Decl := Next (Decl); + +if Nkind (Decl) = N_Pragma then + Remove (Decl); + Insert_After (Insert_Nod, Decl); + Insert_Nod := Decl; + +-- Skip internally generated code + +elsif not Comes_From_Source (Decl) then + null; + +-- No candidate pragmas are available for relocation + +else + exit; +end if; + +Decl := Next_Decl; + end loop; + end Move_Pragmas; + + -- Local variables + + Body_Id : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (N); - Body_Id : constant Entity_Id := Defining_Entity (N); Decl : Node_Id; - Plist: List_Id; Formal : Entity_Id; - New_Spec : Node_Id; + Formals : List_Id; + Spec : Node_Id; Spec_Id : Entity_Id; + -- Start of processing for Build_Private_Protected_Declaration + begin Formal := F
[Ada] Wrong value after assignment of overlain record objects
This patch corrects an issue whereby objects of a record type with a
representation clause which are overlain by address would fail to get
assigned values properly when one or both of said objects were marked
volatile.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Justin Squirek
gcc/ada/
* exp_ch5.adb (Make_Field_Assign): Force temporarily generated
objects for assignment of overlaid user objects to be renamings
instead of constant declarations.
gcc/testsuite/
* gnat.dg/addr11.adb: New testcase.--- gcc/ada/exp_ch5.adb
+++ gcc/ada/exp_ch5.adb
@@ -1531,11 +1531,22 @@ package body Exp_Ch5 is
Selector_Name => New_Occurrence_Of (Disc, Loc));
end if;
+-- Generate the assignment statement. When the left-hand side
+-- is an object with an address clause present, force generated
+-- temporaries to be renamings so as to correctly assign to any
+-- overlaid objects.
+
A :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
-Prefix=> Duplicate_Subexpr (Lhs),
+Prefix=>
+ Duplicate_Subexpr
+(Exp => Lhs,
+ Name_Req => False,
+ Renaming_Req =>
+ Is_Entity_Name (Lhs)
+ and then Present (Address_Clause (Entity (Lhs,
Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
Expression => Expr);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/addr11.adb
@@ -0,0 +1,28 @@
+-- { dg-do run }
+
+procedure Addr11 is
+
+ type Rec is record
+I : Short_Integer;
+C : Character;
+ end record;
+
+ type Derived is new Rec;
+ for Derived use record
+I at 1 range 0 .. 15;
+C at 0 range 0 .. 7;
+ end record;
+
+ Init : constant Rec := ( 1515, 'A' );
+
+ D1 : Derived;
+ D2 : Derived;
+ pragma Volatile (D2);
+ for D2'Address use D1'Address;
+
+begin
+ D2 := Derived (Init);
+ if D1 /= Derived (Init) then
+raise Program_Error;
+ end if;
+end;
[Ada] Fix alignment of mutex_t and cond_t type on 32-bit SPARC/Solaris
The alignment of the couple of types from System.OS_Interface was wrongly set to 4 (32-bit) instead of 8 (64-bit) in 32-bit mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Eric Botcazou gcc/ada/ * 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.--- gcc/ada/libgnarl/s-osinte__solaris.ads +++ gcc/ada/libgnarl/s-osinte__solaris.ads @@ -536,17 +536,18 @@ private end record; pragma Convention (C, record_type_3); + type upad64_t is new Interfaces.Unsigned_64; + type mutex_t is record flags : record_type_3; - lock : String (1 .. 8); - data : String (1 .. 8); + lock : upad64_t; + data : upad64_t; end record; pragma Convention (C, mutex_t); type cond_t is record - flag : array_type_9; - Xtype : unsigned_long; - data : String (1 .. 8); + flags : record_type_3; + data : upad64_t; end record; pragma Convention (C, cond_t);
[Ada] Spurious error on default parameter in protected operation
This patch fixes a spurious compiler error on a call to a protected
operation whose profile includes a defaulted in-parameter that is a call
to another protected function of the same object.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Ed Schonberg
gcc/ada/
* exp_ch6.adb (Expand_Protected_Subprogram_Call): Handle
properly a protected call that includes a default parameter that
is a call to a protected function of the same type.
gcc/testsuite/
* gnat.dg/prot5.adb, gnat.dg/prot5_pkg.adb,
gnat.dg/prot5_pkg.ads: New testcase.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -6387,6 +6387,30 @@ package body Exp_Ch6 is
then
Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
+ -- A default parameter of a protected operation may be a call to
+ -- a protected function of the type. This appears as an internal
+ -- call in the profile of the operation, but if the context is an
+ -- external call we must convert the call into an external one,
+ -- using the protected object that is the target, so that:
+
+ -- Prot.P (F)
+ -- is transformed into
+ -- Prot.P (Prot.F)
+
+ elsif Nkind (Parent (N)) = N_Procedure_Call_Statement
+ and then Nkind (Name (Parent (N))) = N_Selected_Component
+ 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
+ then
+Rewrite (Name (N),
+ Make_Selected_Component (Sloc (N),
+Prefix => New_Copy_Tree (Prefix (Name (Parent (N,
+Selector_Name => Relocate_Node (Name (N;
+Analyze_And_Resolve (N);
+return;
+
else
-- If the context is the initialization procedure for a protected
-- type, the call is legal because the called entity must be a
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/prot5.adb
@@ -0,0 +1,12 @@
+-- { dg-do run }
+-- { dg-options -gnata }
+
+with Prot5_Pkg;
+
+procedure Prot5 is
+begin
+ Prot5_Pkg.P.Proc (10); -- explicit parameter
+ Prot5_Pkg.P.Proc (Prot5_Pkg.P.Get_Data); -- explicit call to protected operation
+ Prot5_Pkg.P.Proc;-- defaulted call.
+ pragma Assert (Prot5_Pkg.P.Get_Data = 80);
+end Prot5;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/prot5_pkg.adb
@@ -0,0 +1,13 @@
+package body Prot5_Pkg is
+ protected body P is
+ function Get_Data return Integer is
+ begin
+ return Data;
+ end Get_Data;
+
+ procedure Proc (A : Integer := Get_Data) is
+ begin
+ Data := A * 2;
+ end Proc;
+ end P;
+end Prot5_Pkg;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/prot5_pkg.ads
@@ -0,0 +1,8 @@
+package Prot5_Pkg is
+ protected P is
+ function Get_Data return Integer;
+ procedure Proc (A : Integer := Get_Data);
+ private
+ Data : Integer;
+ end P;
+end Prot5_Pkg;
[Ada] GNATmake fails to detect missing body
This patch corrects an issue whereby building a multi-unit compilation with missing sources resulted in a cryptic "code generation" error instead of the appropriate file not found error. -- Source -- -- main.adb with Types; procedure Main is begin null; end; -- types.ads package Types is procedure Force; end; -- Compilation and output -- & gnatmake -q main.adb gnatmake: "types.adb" not found Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Justin Squirek gcc/ada/ * lib-writ.adb (Write_With_Lines): Modfiy the generation of dependencies within ali files so that source unit bodies are properly listed even if said bodies are missing. Perform legacy behavior in GNATprove mode. * lib-writ.ads: Modify documentation to reflect current behavior.--- gcc/ada/lib-writ.adb +++ gcc/ada/lib-writ.adb @@ -950,20 +950,35 @@ package body Lib.Writ is Write_Info_Tab (25); if Is_Spec_Name (Uname) then - Body_Fname := -Get_File_Name - (Get_Body_Name (Uname), - Subunit => False, May_Fail => True); - - Body_Index := -Get_Unit_Index - (Get_Body_Name (Uname)); - - if Body_Fname = No_File then - Body_Fname := Get_File_Name (Uname, Subunit => False); - Body_Index := Get_Unit_Index (Uname); - end if; + -- In GNATprove mode we must write the spec of a unit which + -- requires a body if that body is not found. This will + -- allow partial analysis on incomplete sources. + + if GNATprove_Mode then + + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), + Subunit => False, May_Fail => True); + + Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); + + if Body_Fname = No_File then +Body_Fname := Get_File_Name (Uname, Subunit => False); +Body_Index := Get_Unit_Index (Uname); + end if; + + -- In the normal path we don't allow failure in fetching the + -- name of the desired body unit so that it may be properly + -- referenced in the output ali - even if it is missing. + + else + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), + Subunit => False, May_Fail => False); + + Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); + end if; else Body_Fname := Get_File_Name (Uname, Subunit => False); Body_Index := Get_Unit_Index (Uname); --- gcc/ada/lib-writ.ads +++ gcc/ada/lib-writ.ads @@ -629,13 +629,13 @@ package Lib.Writ is -- by the current unit. One Z line is present for each unit that is -- only implicitly withed by the current unit. The first parameter is -- the unit name in internal format. The second parameter is the file - -- name of the file that must be compiled to compile this unit. It is - -- usually the file for the body, except for packages which have no - -- body. For units that need a body, if the source file for the body - -- cannot be found, the file name of the spec is used instead. The - -- third parameter is the file name of the library information file - -- that contains the results of compiling this unit. The optional - -- modifiers are used as follows: + -- name of the body unit on which the current compliation depends - + -- except when in GNATprove mode. In GNATprove mode, when packages + -- which require a body have no associated source file, the file name + -- of the spec is used instead to allow partial analysis of incomplete + -- sources. The third parameter is the file name of the library + -- information file that contains the results of compiling this unit. + -- The optional modifiers are used as follows: --E pragma Elaborate applies to this unit
[Ada] Secondary stack leak with access-to-subprogram
This patch modifies call resolution to recognize when the designated type of an access-to-subprogram requires secondary stack management, and establish the proper transient block. -- Source -- -- leak7.adb procedure Leak7 is Max_Iterations : constant := 10_000; function Func return String is begin return "Will this leak? Or will it dry?"; end Func; type Func_Ptr is access function return String; procedure Anonymous_Leak (Func : access function return String) is begin for Iteration in 1 .. Max_Iterations loop declare Val : constant String := Func.all; begin null; end; end loop; end Anonymous_Leak; procedure Named_Leak (Func : Func_Ptr) is begin for Iteration in 1 .. Max_Iterations loop declare Val : constant String := Func.all; begin null; end; end loop; end Named_Leak; begin Anonymous_Leak (Func'Access); Named_Leak (Func'Access); end Leak7; -- Compilation and output -- $ gnatmake -q leak7.adb $ valgrind ./leak7 >& leak7.txt $ grep -c "still reachable" leak7.txt 0 Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Hristian Kirtchev gcc/ada/ * sem_res.adb (Resolve_Call): Establish a transient scope to manage the secondary stack when the designated type of an access-to-subprogram requires it.--- gcc/ada/sem_res.adb +++ gcc/ada/sem_res.adb @@ -6433,7 +6433,7 @@ package body Sem_Res is null; elsif Expander_Active -and then Ekind (Nam) = E_Function +and then Ekind_In (Nam, E_Function, E_Subprogram_Type) and then Requires_Transient_Scope (Etype (Nam)) then Establish_Transient_Scope (N, Manage_Sec_Stack => True);
[Ada] Remove inappropriate test from Is_By_Reference_Type
The result returned by the predicate may change depending on whether an error was posted on the type, which complicates further error reporting. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_aux.adb (Is_By_Reference_Type): Do not test Error_Posted.diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -846,10 +846,7 @@ package body Sem_Aux is Btype : constant Entity_Id := Base_Type (Ent); begin - if Error_Posted (Ent) or else Error_Posted (Btype) then - return False; - - elsif Is_Private_Type (Btype) then + if Is_Private_Type (Btype) then declare Utyp : constant Entity_Id := Underlying_Type (Btype); begin
[Ada] usage.adb: make -gnatw.c description clearer
The term "unrepped" can be hard to understand for users.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* usage.adb (Usage): Update -gnatw.c messages.diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -483,8 +483,10 @@ begin
Write_Line (".B turn off warnings for biased representation");
Write_Line ("c+ turn on warnings for constant conditional");
Write_Line ("C* turn off warnings for constant conditional");
- Write_Line (".c+ turn on warnings for unrepped components");
- Write_Line (".C* turn off warnings for unrepped components");
+ Write_Line (".c+ turn on warnings for components without " &
+ "representation clauses");
+ Write_Line (".C* turn off warnings for components without " &
+ "representation clauses");
Write_Line ("_c* turn on warnings for unknown " &
"Compile_Time_Warning");
Write_Line ("_C turn off warnings for unknown " &
[Ada] Move Build_And_Insert_Cuda_Initialization to Expand_CUDA_Package
This commit makes Build_And_Insert_Cuda_Initialization an internal procedure and creates a new Expand_CUDA_Package procedure which calls Build_And_Insert_Cuda_Initialization. This is a small, self-contained refactoring that does not impact any feature or fix any bug - it just makes future commits that do add new features smaller and easier to review. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch7.adb (Expand_N_Package_Body): Replace Build_And_Insert_Cuda_Initialization with Expand_CUDA_Package. * gnat_cuda.adb (Expand_CUDA_Package): New procedure. (Build_And_Insert_Cuda_Initialization): Make internal. * gnat_cuda.ads (Expand_CUDA_Package): New procedure. (Build_And_Insert_Cuda_Initialization): Remove from spec.diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -5918,12 +5918,7 @@ package body Exp_Ch7 is Build_Static_Dispatch_Tables (N); end if; - -- If procedures marked with CUDA_Global have been defined within N, - -- we need to register them with the CUDA runtime at program startup. - -- This requires multiple declarations and function calls which need - -- to be appended to N's declarations. - - Build_And_Insert_CUDA_Initialization (N); + Expand_CUDA_Package (N); Build_Task_Activation_Call (N); diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb --- a/gcc/ada/gnat_cuda.adb +++ b/gcc/ada/gnat_cuda.adb @@ -66,6 +66,25 @@ package body GNAT_CUDA is -- least one procedure marked with aspect CUDA_Global. The values are -- Elists of the marked procedures. + procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); + -- Builds declarations necessary for CUDA initialization and inserts them + -- in N, the package body that contains CUDA_Global nodes. These + -- declarations are: + -- + --* A symbol to hold the pointer P to the CUDA fat binary. + -- + --* A type definition T for a wrapper that contains the pointer to the + -- CUDA fat binary. + -- + --* An object of the aforementioned type to hold the aforementioned + -- pointer. + -- + --* For each CUDA_Global procedure in the package, a declaration of a C + -- string containing the function's name. + -- + --* A procedure that takes care of calling CUDA functions that register + -- CUDA_Global procedures with the runtime. + function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id; -- Returns an Elist of all procedures marked with pragma CUDA_Global that -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id @@ -94,6 +113,23 @@ package body GNAT_CUDA is Append_Elmt (Kernel, Kernels); end Add_CUDA_Kernel; + procedure Expand_CUDA_Package (N : Node_Id) is + begin + + -- If not compiling for the host, do not do anything. + + if not Debug_Flag_Underscore_C then + return; + end if; + + -- If procedures marked with CUDA_Global have been defined within N, + -- we need to register them with the CUDA runtime at program startup. + -- This requires multiple declarations and function calls which need + -- to be appended to N's declarations. + + Build_And_Insert_CUDA_Initialization (N); + end Expand_CUDA_Package; + -- -- Hash -- -- @@ -524,7 +560,7 @@ package body GNAT_CUDA is -- Start of processing for Build_And_Insert_CUDA_Initialization begin - if CUDA_Node_List = No_Elist or not Debug_Flag_Underscore_C then + if CUDA_Node_List = No_Elist then return; end if; diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads --- a/gcc/ada/gnat_cuda.ads +++ b/gcc/ada/gnat_cuda.ads @@ -82,26 +82,8 @@ package GNAT_CUDA is -- Kernel is a procedure entity marked with CUDA_Global, Pack_Id is the -- entity of its parent package body. - procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); - -- Builds declarations necessary for CUDA initialization and inserts them - -- in N, the package body that contains CUDA_Global nodes. These - -- declarations are: - -- - --* A symbol to hold the pointer to the CUDA fat binary - -- - --* A type definition for a wrapper that contains the pointer to the - -- CUDA fat binary - -- - --* An object of the aforementioned type to hold the aforementioned - -- pointer. - -- - --* For each CUDA_Global procedure in the package, a declaration of a C - -- string containing the function's name. - -- - --* A function that takes care of calling CUDA functions that register - -- CUDA_Global procedures with the runtime. - -- - --* A boolean that holds the result of the call to the aforementioned - -- function. + procedure Expand_CUDA_Package (N : Node_Id);
[Ada] Only assign type to op if compatible
Before this commit, the following program would make the compiler crash: procedure Main is ConstantString1 : aliased String := "Class1"; My_Access : access String := ConstantString1'Access; begin if "Class1" = My_Access then null; end if; end Main; This was because when an access type was given on the right side of an operator, GNAT assumed that an interpretation for the operator existed. This assumption resulted in no error being thrown and Gigi crashing when encountering the malformed tree. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch4.adb (Find_Non_Universal_Interpretations): Check if types are compatible before adding interpretation.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6626,7 +6626,7 @@ package body Sem_Ch4 is Get_Next_Interp (Index, It); end loop; end if; - else + elsif Has_Compatible_Type (R, T1) then Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1)); end if; end Find_Non_Universal_Interpretations;
[Ada] Refactor scan_backend_switch to share logic across backends
This commit refactors scan_backend_switch to share logic across adabkend.adb and back_end.adb. A side effect of this refactor is that `-fdump-diagnostics-format` is now available with other backends. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * adabkend.adb (Scan_Back_End_Switches): Replace switch-scanning logic with call to Backend_Utils.Scan_Common_Back_End_Switches. * back_end.adb (Scan_Back_End_Switches): Replace switch-scanning logic with call to Backend_Utils.Scan_Common_Back_End_Switches. * backend_utils.adb: New file. * backend_utils.ads: New file. * gcc-interface/Make-lang.in: Add ada/backend_utils.o.diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.adb @@ -22,15 +22,16 @@ -- This is the version of the Back_End package for back ends written in Ada -with Atree;use Atree; +with Atree; use Atree; +with Backend_Utils; use Backend_Utils; with Debug; with Lib; -with Opt; use Opt; -with Output; use Output; -with Osint;use Osint; -with Osint.C; use Osint.C; -with Switch.C; use Switch.C; -with Types;use Types; +with Opt; use Opt; +with Output;use Output; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Switch.C; use Switch.C; +with Types; use Types; with System.OS_Lib; use System.OS_Lib; @@ -182,48 +183,11 @@ package body Adabkend is return; - -- Special check, the back-end switch -fno-inline also sets the - -- front end flags to entirely inhibit all inlining. So we store it - -- and set the appropriate flags. - - elsif Switch_Chars (First .. Last) = "fno-inline" then -Lib.Store_Compilation_Switch (Switch_Chars); -Opt.Disable_FE_Inline := True; -return; - - -- Similar processing for -fpreserve-control-flow - - elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then -Lib.Store_Compilation_Switch (Switch_Chars); -Opt.Suppress_Control_Flow_Optimizations := True; -return; - - -- Recognize -gxxx switches - - elsif Switch_Chars (First) = 'g' then -Debugger_Level := 2; - -if First < Last then - case Switch_Chars (First + 1) is - when '0' => - Debugger_Level := 0; - when '1' => - Debugger_Level := 1; - when '2' => - Debugger_Level := 2; - when '3' => - Debugger_Level := 3; - when others => - null; - end case; -end if; - - elsif Switch_Chars (First .. Last) = "S" then -Generate_Asm := True; - -- Ignore all other back-end switches - elsif Is_Back_End_Switch (Switch_Chars) then + elsif Scan_Common_Back_End_Switch (Switch_Chars) +or else Is_Back_End_Switch (Switch_Chars) + then null; -- Give error for junk switch diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -25,23 +25,24 @@ -- This is the version of the Back_End package for GCC back ends -with Atree;use Atree; -with Debug;use Debug; -with Elists; use Elists; -with Errout; use Errout; -with Lib; use Lib; -with Osint;use Osint; -with Opt; use Opt; -with Osint.C; use Osint.C; -with Namet;use Namet; -with Nlists; use Nlists; -with Stand;use Stand; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Switch; use Switch; -with Switch.C; use Switch.C; -with System; use System; -with Types;use Types; +with Atree; use Atree; +with Backend_Utils; use Backend_Utils; +with Debug; use Debug; +with Elists;use Elists; +with Errout;use Errout; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Osint.C; use Osint.C; +with Namet; use Namet; +with Nlists;use Nlists; +with Stand; use Stand; +with Sinput;use Sinput; +with Stringt; use Stringt; +with Switch;use Switch; +with Switch.C; use Switch.C; +with System;use System; +with Types; use Types; with System.OS_Lib; use System.OS_Lib; @@ -266,52 +267,20 @@ package body Back_End is -- specific switches that the Ada front-end knows about. else -Store_Compilation_Switch (Switch_Chars); - --- For gcc back ends, -fno-inline disables Inline pragmas only, --- not Inline_Always to remain consistent with the always_inline --- attribute behavior. - -if Switch_Chars (First .. Last) = "fno-inline" then - Opt.Disable_FE_Inline := True; - -
[Ada] Spurious accessibility error on allocator in generic instance
This patch fixes an error in the compiler whereby an allocator for a limited type within a generic instance may cause spurious compile-time warnings and run-time errors. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch4.adb (Expand_N_Type_Conversion): Add guard to protect against calculating accessibility levels against internal compiler-generated types.diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12361,10 +12361,16 @@ package body Exp_Ch4 is -- an instantiation, otherwise the conversion will already have been -- rejected as illegal. - -- Note: warnings are issued by the analyzer for the instance cases + -- Note: warnings are issued by the analyzer for the instance cases, + -- and, since we are late in expansion, a check is performed to + -- verify that neither the target type nor the operand type are + -- internally generated - as this can lead to spurious errors when, + -- for example, the operand type is a result of BIP expansion. elsif In_Instance_Body and then Statically_Deeper_Relation_Applies (Target_Type) + and then not Is_Internal (Target_Type) + and then not Is_Internal (Operand_Type) and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then
[Ada] Fix assertion in GNATprove_Mode
Avoid calling List_Rep_Info in Generate_SCIL and GNATprove_Mode, because
the representation info is not there. Otherwise, we fail an assertion.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* gnat1drv.adb (Gnat1drv): Avoid calling List_Rep_Info in
Generate_SCIL and GNATprove_Mode.
* repinfo.adb (List_Common_Type_Info): Fix comment.diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -1616,7 +1616,14 @@ begin
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
- Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian);
+
+ -- Back annotation of representation info is not done in CodePeer and
+ -- SPARK modes.
+
+ if not (Generate_SCIL or GNATprove_Mode) then
+ Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian);
+ end if;
+
Inline.List_Inlining_Info;
-- Only write the library if the backend did not generate any error
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -422,7 +422,8 @@ package body Repinfo is
Write_Line (";");
end if;
- -- Alignment is not always set for task and protected types
+ -- Alignment is not always set for task, protected, and class-wide
+ -- types.
else
pragma Assert
[Ada] Don't examine all discriminants when looking for the first one
A minor performance improvement; semantics is unaffected. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch3.adb (Build_Discriminant_Constraints): Exit once a first discriminant is found and the Discrim_Present flag is set.diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10392,6 +10392,7 @@ package body Sem_Ch3 is (Discr_Expr (J), Check_Concurrent => True) then Discrim_Present := True; +exit; end if; end loop;
[Ada] Work around CodePeer bug by declaring variable
This commit works around a CodePeer bug where CodePeer thinks Get_32_Bit_Val returns something uninitialized. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * atree.adb (Get_32_Bit_Field): Declare result before returning.diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -513,8 +513,13 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_32_Bit, Field_Type); + + Result : constant Field_Type := Cast (Get_32_Bit_Val (N, Offset)); + -- Note: declaring Result here instead of directly returning + -- Cast (...) helps CodePeer understand that there are no issues + -- around uninitialized variables. begin - return Cast (Get_32_Bit_Val (N, Offset)); + return Result; end Get_32_Bit_Field; function Get_32_Bit_Field_With_Default
[Ada] Small cleanup in System.Dwarf_Line
The unit has got "with" and "use" clauses both for Ada.Exceptions.Traceback and System.Traceback_Entries, but the former is essentially a forwarder for the latter so can be eliminated. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/s-dwalin.ads: Remove clause for Ada.Exceptions.Traceback, add clause for System.Traceback_Entries and alphabetize. (AET): Delete. (STE): New package renaming. (Symbolic_Traceback): Adjust. * libgnat/s-dwalin.adb: Remove clauses for Ada.Exceptions.Traceback and System.Traceback_Entries. (Symbolic_Traceback): Adjust.diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -31,7 +31,6 @@ with Ada.Characters.Handling; with Ada.Containers.Generic_Array_Sort; -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with Ada.Unchecked_Deallocation; with Interfaces; use Interfaces; @@ -42,7 +41,6 @@ with System.Bounded_Strings; use System.Bounded_Strings; with System.IO;use System.IO; with System.Mmap; use System.Mmap; with System.Object_Reader; use System.Object_Reader; -with System.Traceback_Entries; use System.Traceback_Entries; with System.Storage_Elements; use System.Storage_Elements; package body System.Dwarf_Lines is @@ -1864,7 +1862,7 @@ package body System.Dwarf_Lines is procedure Symbolic_Traceback (Cin :Dwarf_Context; - Traceback:AET.Tracebacks_Array; + Traceback:STE.Tracebacks_Array; Suppress_Hex :Boolean; Symbol_Found :out Boolean; Res : in out System.Bounded_Strings.Bounded_String) @@ -1893,7 +1891,7 @@ package body System.Dwarf_Lines is -- If the buffer is full, no need to do any useless work exit when Is_Full (Res); - Addr_In_Traceback := PC_For (Traceback (J)); + Addr_In_Traceback := STE.PC_For (Traceback (J)); Offset_To_Lookup := Addr_In_Traceback - C.Load_Address; diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -35,15 +35,14 @@ -- -- Files must be compiled with at least minimal debugging information (-g1). -with Ada.Exceptions.Traceback; - +with System.Bounded_Strings; with System.Object_Reader; with System.Storage_Elements; -with System.Bounded_Strings; +with System.Traceback_Entries; package System.Dwarf_Lines is - package AET renames Ada.Exceptions.Traceback; + package STE renames System.Traceback_Entries; package SOR renames System.Object_Reader; type Dwarf_Context (In_Exception : Boolean := False) is private; @@ -83,7 +82,7 @@ package System.Dwarf_Lines is procedure Symbolic_Traceback (Cin :Dwarf_Context; - Traceback:AET.Tracebacks_Array; + Traceback:STE.Tracebacks_Array; Suppress_Hex :Boolean; Symbol_Found :out Boolean; Res : in out System.Bounded_Strings.Bounded_String);
[Ada] Implementation of Preelaborable_Initialization attribute for AI12-0409
This set of changes implements the Preelaborable_Initialization attribute, corresponding to the existing aspect/pragma, as defined by AI12-0409 (RM2022 10.2.1(11.6/5-11.8/5). This includes semantic checking of restrictions on the prefix, and support for the aspect expression being given by an expression with one or more P_I attributes applied to formal private or derived types, when the type with the aspect is specified on types within a generic package declaration (the value of the aspect in instantiations can be different depending on the actual types), as well as applying preelaborable-initialization restrictions on full types when the partial type has such aspects. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_attr.adb (Expand_N_Attribute_Reference): Fold Preelaborable_Initialization attribute in cases where it hasn't been folded by the analyzer. * exp_disp.adb (Original_View_In_Visible_Part): This function is removed and moved to sem_util.adb. * sem_attr.adb (Attribute_22): Add Attribute_Preelaborable_Initialization as an Ada 2022 attribute. (Analyze_Attribute, Attribute_Preelaborable_Initialization): Check that the prefix of the attribute is either a formal private or derived type, or a composite type declared within the visible part of a package or generic package. (Eval_Attribute): Perform folding of Preelaborable_Initialization attribute based on Has_Preelaborable_Initialization applied to the prefix type. * sem_ch3.adb (Resolve_Aspects): Add specialized code for Preelaborable_Initialization used at the end of a package visible part for setting Known_To_Have_Preelab_Init on types that are specified with True or that have a conjunction of one or more P_I attributes applied to formal types. * sem_ch7.adb (Analyze_Package_Specification): On call to Has_Preelaborable_Initialization, pass True for new formal Formal_Types_Have_Preelab_Init, so that error checking treats subcomponents that are declared within types in generics as having preelaborable initialization when the subcomponents are of formal types. * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Add test for P_I to prevent calling Make_Pragma_From_Boolean_Aspect, since this aspect is handled specially and the Known_To_Have_Preelab_Init flag will get set on types that have the aspect by other means. (Analyze_Aspect_Specifications.Analyze_One_Aspect): Add test for Aspect_Preelaborable_Initialization for allowing the aspect to be specified on formal type declarations. (Is_Operational_Item): Treat Attribute_Put_Image as an operational attribute. The need for this was encountered while working on these changes. * sem_util.ads (Has_Preelaborable_Initialization): Add Formal_Types_Have_Preelab_Init as a new formal parameter that defaults to False. (Is_Conjunction_Of_Formal_Preelab_Init_Attributes): New function. (Original_View_In_Visible_Part): Moved here from exp_disp.adb, so it can be called by Analyze_Attribute. * sem_util.adb (Has_Preelaborable_Initialization): Return True for formal private and derived types when new formal Formal_Types_Have_Preelab_Init is True, and pass along the Formal_Types_Have_Preelab_Init flag in the array component case. (Check_Components): Pass along Formal_Types_Have_Preelab_Init flag on call to Has_Preelaborable_Initialization. (Is_Conjunction_Of_Formal_Preelab_Init_Attributes): New function that returns True when passed an expression that includes one or more attributes for Preelaborable_Initialization applied to prefixes that denote formal types. (Is_Formal_Preelab_Init_Attribute): New utility function nested within Is_Conjunction_Of_Formal_Preelab_Init_Attributes that determines whether a node is a P_I attribute applied to a generic formal type. (Original_View_In_Visible_Part): Moved here from exp_util.adb, so it can be called by Analyze_Attribute. * snames.ads-tmpl: Add note near the start of spec giving details about what needs to be done when adding a name that corresponds to both an attribute and a pragma. Delete existing occurrence of Name_Preelaborable_Initialization, and add a note comment in the list of Name_* constants at that place, indicating that it's included in type Pragma_Id, etc., echoing other such comments for names that are both an attribute and a pragma. Insert Name_Preelaborable_Initialization in the alphabetized set of Name_* constants corresponding to attributes (between First_Attribute_Name and Last_Attribute_Name).
[Ada] Refine types of local constants that store Etype results
Calls to Etype return entities, even though the signature of the Etype routine says it returns nodes. Fixed automatically with: $ sed -i 's/ Node_Id := Etype/ Entity_Id := Etype/' *.adb Found while reviewing changes in GNATprove related to aliasing checks. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_aggr.adb, exp_ch4.adb, exp_ch5.adb, sprint.adb: Refine types of local constants.diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4003,7 +4003,7 @@ package body Exp_Aggr is and then Present (First_Index (Etype (Expr_Q))) then declare - Expr_Q_Type : constant Node_Id := Etype (Expr_Q); + Expr_Q_Type : constant Entity_Id := Etype (Expr_Q); begin Append_List_To (L, Build_Array_Aggr_Code diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7763,8 +7763,8 @@ package body Exp_Ch4 is if Is_Unchecked_Union (Op_Type) then declare - Lhs_Type : constant Node_Id := Etype (L_Exp); - Rhs_Type : constant Node_Id := Etype (R_Exp); + Lhs_Type : constant Entity_Id := Etype (L_Exp); + Rhs_Type : constant Entity_Id := Etype (R_Exp); Lhs_Discr_Vals : Elist_Id; -- List of inferred discriminant values for left operand. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -742,8 +742,8 @@ package body Exp_Ch5 is -- in the front end. declare - L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); - R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + L_Index_Typ : constant Entity_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Entity_Id := Etype (First_Index (R_Type)); Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); @@ -1382,8 +1382,8 @@ package body Exp_Ch5 is Loc : constant Source_Ptr := Sloc (N); - L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); - R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + L_Index_Typ : constant Entity_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Entity_Id := Etype (First_Index (R_Type)); Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -4222,7 +4222,7 @@ package body Sprint is -- Itype to be printed declare -B : constant Node_Id := Etype (Typ); +B : constant Entity_Id := Etype (Typ); P : constant Node_Id := Parent (Typ); S : constant Saved_Output_Buffer := Save_Output_Buffer; -- Save current output buffer
