Google Git
Sign in
gnu / gcc / 75bbfcfa8623f5b211475a54f52ced32201575e7 / . / gcc / ch / grant.c
blob: 2809003fdab11030be550c41905938ec1f079b85 [file] [log] [blame]
/* Implement grant-file output & seize-file input for CHILL.
Copyright (C) 1992, 93, 94, 95, 1996, 1998 Free Software Foundation, Inc.
This file is part of GNU CC.
GNU CC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU CC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU CC; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
#include "config.h"
#include "system.h"
#include "tree.h"
#include "ch-tree.h"
#include "lex.h"
#include "flags.h"
#include "actions.h"
#include "input.h"
#include "rtl.h"
#include "tasking.h"
#include "toplev.h"
#include "output.h"
#define APPEND(X,Y) X = append (X, Y)
#define PREPEND(X,Y) X = prepend (X, Y);
#define FREE(x) strfree (x)
#define ALLOCAMOUNT 10000
/* may be we can handle this in a more exciting way,
but this also should work for the moment */
#define MAYBE_NEWLINE(X) \
do \
{ \
if (X->len && X->str[X->len - 1] != '\n') \
APPEND (X, ";\n"); \
} while (0)
extern tree process_type;
extern char *asm_file_name;
extern char *dump_base_name;
/* forward declarations */
/* variable indicates compilation at module level */
int chill_at_module_level = 0;
/* mark that a SPEC MODULE was generated */
static int spec_module_generated = 0;
/* define version strings */
extern char *gnuchill_version;
extern char *version_string;
/* define a faster string handling */
typedef struct
{
char *str;
int len;
int allocated;
} MYSTRING;
/* structure used for handling multiple grant files */
char *grant_file_name;
MYSTRING *gstring = NULL;
MYSTRING *selective_gstring = NULL;
static MYSTRING *decode_decl PROTO((tree));
static MYSTRING *decode_constant PROTO((tree));
static void grant_one_decl PROTO((tree));
static MYSTRING *get_type PROTO((tree));
static MYSTRING *decode_mode PROTO((tree));
static MYSTRING *decode_prefix_rename PROTO((tree));
static MYSTRING *decode_constant_selective PROTO((tree, tree));
static MYSTRING *decode_mode_selective PROTO((tree, tree));
static MYSTRING *get_type_selective PROTO((tree, tree));
static MYSTRING *decode_decl_selective PROTO((tree, tree));
/* list of the VAR_DECLs of the module initializer entries */
tree module_init_list = NULL_TREE;
/* handle different USE_SEIZE_FILE's in case of selective granting */
typedef struct SEIZEFILELIST
{
struct SEIZEFILELIST *next;
tree filename;
MYSTRING *seizes;
} seizefile_list;
static seizefile_list *selective_seizes = 0;
static MYSTRING *
newstring (str)
char *str;
{
MYSTRING *tmp = (MYSTRING *) xmalloc (sizeof (MYSTRING));
unsigned len = strlen (str);
tmp->allocated = len + ALLOCAMOUNT;
tmp->str = xmalloc ((unsigned)tmp->allocated);
strcpy (tmp->str, str);
tmp->len = len;
return (tmp);
}
static void
strfree (str)
MYSTRING *str;
{
free (str->str);
free (str);
}
static MYSTRING *
append (inout, in)
MYSTRING *inout;
char *in;
{
int inlen = strlen (in);
int amount = ALLOCAMOUNT;
if (inlen >= amount)
amount += inlen;
if ((inout->len + inlen) >= inout->allocated)
inout->str = xrealloc (inout->str, inout->allocated += amount);
strcpy (inout->str + inout->len, in);
inout->len += inlen;
return (inout);
}
static MYSTRING *
prepend (inout, in)
MYSTRING *inout;
char *in;
{
MYSTRING *res = inout;
if (strlen (in))
{
res = newstring (in);
res = APPEND (res, inout->str);
FREE (inout);
}
return res;
}
void
grant_use_seizefile (seize_filename)
char *seize_filename;
{
APPEND (gstring, "<> USE_SEIZE_FILE \"");
APPEND (gstring, seize_filename);
APPEND (gstring, "\" <>\n");
}
static MYSTRING *
decode_layout (layout)
tree layout;
{
tree temp;
tree stepsize = NULL_TREE;
int was_step = 0;
MYSTRING *result = newstring ("");
MYSTRING *work;
if (layout == integer_zero_node) /* NOPACK */
{
APPEND (result, " NOPACK");
return result;
}
if (layout == integer_one_node) /* PACK */
{
APPEND (result, " PACK");
return result;
}
APPEND (result, " ");
temp = layout;
if (TREE_PURPOSE (temp) == NULL_TREE)
{
APPEND (result, "STEP(");
was_step = 1;
temp = TREE_VALUE (temp);
stepsize = TREE_VALUE (temp);
}
APPEND (result, "POS(");
/* Get the starting word */
temp = TREE_PURPOSE (temp);
work = decode_constant (TREE_PURPOSE (temp));
APPEND (result, work->str);
FREE (work);
temp = TREE_VALUE (temp);
if (temp != NULL_TREE)
{
/* Get the starting bit */
APPEND (result, ", ");
work = decode_constant (TREE_PURPOSE (temp));
APPEND (result, work->str);
FREE (work);
temp = TREE_VALUE (temp);
if (temp != NULL_TREE)
{
/* Get the length or the ending bit */
tree what = TREE_PURPOSE (temp);
if (what == integer_zero_node) /* length */
{
APPEND (result, ", ");
}
else
{
APPEND (result, ":");
}
work = decode_constant (TREE_VALUE (temp));
APPEND (result, work->str);
FREE (work);
}
}
APPEND (result, ")");
if (was_step)
{
if (stepsize != NULL_TREE)
{
APPEND (result, ", ");
work = decode_constant (stepsize);
APPEND (result, work->str);
FREE (work);
}
APPEND (result, ")");
}
return result;
}
static MYSTRING *
grant_array_type (type)
tree type;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
tree layout;
int varying = 0;
if (chill_varying_type_p (type))
{
varying = 1;
type = CH_VARYING_ARRAY_TYPE (type);
}
if (CH_STRING_TYPE_P (type))
{
tree fields = TYPE_DOMAIN (type);
tree maxval = TYPE_MAX_VALUE (fields);
if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
APPEND (result, "CHARS (");
else
APPEND (result, "BOOLS (");
if (TREE_CODE (maxval) == INTEGER_CST)
{
char wrk[20];
sprintf (wrk, HOST_WIDE_INT_PRINT_DEC,
TREE_INT_CST_LOW (maxval) + 1);
APPEND (result, wrk);
}
else if (TREE_CODE (maxval) == MINUS_EXPR
&& TREE_OPERAND (maxval, 1) == integer_one_node)
{
mode_string = decode_constant (TREE_OPERAND (maxval, 0));
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
mode_string = decode_constant (maxval);
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, "+1");
}
APPEND (result, ")");
if (varying)
APPEND (result, " VARYING");
return result;
}
APPEND (result, "ARRAY (");
if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
&& TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
{
mode_string = decode_constant (TYPE_MIN_VALUE (TYPE_DOMAIN (type)));
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, ":");
mode_string = decode_constant (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
mode_string = decode_mode (TYPE_DOMAIN (type));
APPEND (result, mode_string->str);
FREE (mode_string);
}
APPEND (result, ") ");
if (varying)
APPEND (result, "VARYING ");
mode_string = get_type (TREE_TYPE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
layout = TYPE_ATTRIBUTES (type);
if (layout != NULL_TREE)
{
mode_string = decode_layout (layout);
APPEND (result, mode_string->str);
FREE (mode_string);
}
return result;
}
static MYSTRING *
grant_array_type_selective (type, all_decls)
tree type;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
int varying = 0;
if (chill_varying_type_p (type))
{
varying = 1;
type = CH_VARYING_ARRAY_TYPE (type);
}
if (CH_STRING_TYPE_P (type))
{
tree fields = TYPE_DOMAIN (type);
tree maxval = TYPE_MAX_VALUE (fields);
if (TREE_CODE (maxval) != INTEGER_CST)
{
if (TREE_CODE (maxval) == MINUS_EXPR
&& TREE_OPERAND (maxval, 1) == integer_one_node)
{
mode_string = decode_constant_selective (TREE_OPERAND (maxval, 0), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
mode_string = decode_constant_selective (maxval, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
}
return result;
}
if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
&& TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
{
mode_string = decode_constant_selective (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
mode_string = decode_constant_selective (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
else
{
mode_string = decode_mode_selective (TYPE_DOMAIN (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
mode_string = get_type_selective (TREE_TYPE (type), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
return result;
}
static MYSTRING *
get_tag_value (val)
tree val;
{
MYSTRING *result;
if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
{
result = newstring (IDENTIFIER_POINTER (DECL_NAME (val)));
}
else if (TREE_CODE (val) == CONST_DECL)
{
/* it's a synonym -- get the value */
result = decode_constant (DECL_INITIAL (val));
}
else
{
result = decode_constant (val);
}
return (result);
}
static MYSTRING *
get_tag_value_selective (val, all_decls)
tree val;
tree all_decls;
{
MYSTRING *result;
if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
result = newstring ("");
else if (TREE_CODE (val) == CONST_DECL)
{
/* it's a synonym -- get the value */
result = decode_constant_selective (DECL_INITIAL (val), all_decls);
}
else
{
result = decode_constant_selective (val, all_decls);
}
return (result);
}
static MYSTRING *
print_enumeral (type)
tree type;
{
MYSTRING *result = newstring ("");
tree fields;
#if 0
if (TYPE_LANG_SPECIFIC (type) == NULL)
#endif
{
APPEND (result, "SET (");
for (fields = TYPE_VALUES (type);
fields != NULL_TREE;
fields = TREE_CHAIN (fields))
{
if (TREE_PURPOSE (fields) == NULL_TREE)
APPEND (result, "*");
else
{
tree decl = TREE_VALUE (fields);
APPEND (result, IDENTIFIER_POINTER (TREE_PURPOSE (fields)));
if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
{
MYSTRING *val_string = decode_constant (DECL_INITIAL (decl));
APPEND (result, " = ");
APPEND (result, val_string->str);
FREE (val_string);
}
}
if (TREE_CHAIN (fields) != NULL_TREE)
APPEND (result, ",\n ");
}
APPEND (result, ")");
}
return result;
}
static MYSTRING *
print_enumeral_selective (type, all_decls)
tree type;
tree all_decls;
{
MYSTRING *result = newstring ("");
tree fields;
for (fields = TYPE_VALUES (type);
fields != NULL_TREE;
fields = TREE_CHAIN (fields))
{
if (TREE_PURPOSE (fields) != NULL_TREE)
{
tree decl = TREE_VALUE (fields);
if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
{
MYSTRING *val_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
if (val_string->len)
APPEND (result, val_string->str);
FREE (val_string);
}
}
}
return result;
}
static MYSTRING *
print_integer_type (type)
tree type;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
char *name_ptr;
tree base_type;
if (TREE_TYPE (type))
{
mode_string = decode_mode (TREE_TYPE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, "(");
mode_string = decode_constant (TYPE_MIN_VALUE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_TYPE (type) != ridpointers[(int) RID_BIN])
{
APPEND (result, ":");
mode_string = decode_constant (TYPE_MAX_VALUE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
}
APPEND (result, ")");
return result;
}
/* We test TYPE_MAIN_VARIANT because pushdecl often builds
a copy of a built-in type node, which is logically id-
entical but has a different address, and the same
TYPE_MAIN_VARIANT. */
/* FIXME this should not be needed! */
base_type = TREE_TYPE (type) ? TREE_TYPE (type) : type;
if (TREE_UNSIGNED (base_type))
{
if (base_type == chill_unsigned_type_node
|| TYPE_MAIN_VARIANT(base_type) ==
TYPE_MAIN_VARIANT (chill_unsigned_type_node))
name_ptr = "UINT";
else if (base_type == long_integer_type_node
|| TYPE_MAIN_VARIANT(base_type) ==
TYPE_MAIN_VARIANT (long_unsigned_type_node))
name_ptr = "ULONG";
else if (type == unsigned_char_type_node
|| TYPE_MAIN_VARIANT(base_type) ==
TYPE_MAIN_VARIANT (unsigned_char_type_node))
name_ptr = "UBYTE";
else if (type == duration_timing_type_node
|| TYPE_MAIN_VARIANT (base_type) ==
TYPE_MAIN_VARIANT (duration_timing_type_node))
name_ptr = "DURATION";
else if (type == abs_timing_type_node
|| TYPE_MAIN_VARIANT (base_type) ==
TYPE_MAIN_VARIANT (abs_timing_type_node))
name_ptr = "TIME";
else
name_ptr = "UINT";
}
else
{
if (base_type == chill_integer_type_node
|| TYPE_MAIN_VARIANT (base_type) ==
TYPE_MAIN_VARIANT (chill_integer_type_node))
name_ptr = "INT";
else if (base_type == long_integer_type_node
|| TYPE_MAIN_VARIANT (base_type) ==
TYPE_MAIN_VARIANT (long_integer_type_node))
name_ptr = "LONG";
else if (type == signed_char_type_node
|| TYPE_MAIN_VARIANT (base_type) ==
TYPE_MAIN_VARIANT (signed_char_type_node))
name_ptr = "BYTE";
else
name_ptr = "INT";
}
APPEND (result, name_ptr);
/* see if we have a range */
if (TREE_TYPE (type) != NULL)
{
mode_string = decode_constant (TYPE_MIN_VALUE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, ":");
mode_string = decode_constant (TYPE_MAX_VALUE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
}
return result;
}
static tree
find_enum_parent (enumname, all_decls)
tree enumname;
tree all_decls;
{
tree wrk;
for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
{
if (TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (wrk) != CONST_DECL &&
TREE_CODE (TREE_TYPE (wrk)) == ENUMERAL_TYPE)
{
tree list;
for (list = TYPE_VALUES (TREE_TYPE (wrk)); list != NULL_TREE; list = TREE_CHAIN (list))
{
if (DECL_NAME (TREE_VALUE (list)) == enumname)
return wrk;
}
}
}
return NULL_TREE;
}
static MYSTRING *
print_integer_selective (type, all_decls)
tree type;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
if (TREE_TYPE (type))
{
mode_string = decode_mode_selective (TREE_TYPE (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_TYPE (type) == ridpointers[(int)RID_RANGE] &&
TREE_CODE (TYPE_MIN_VALUE (type)) == IDENTIFIER_NODE &&
TREE_CODE (TYPE_MAX_VALUE (type)) == IDENTIFIER_NODE)
{
/* we have a range of a set. Find parant mode and write it
to SPEC MODULE. This will loose if the parent mode was SEIZED from
another file.*/
tree minparent = find_enum_parent (TYPE_MIN_VALUE (type), all_decls);
tree maxparent = find_enum_parent (TYPE_MAX_VALUE (type), all_decls);
if (minparent != NULL_TREE)
{
if (! CH_ALREADY_GRANTED (minparent))
{
mode_string = decode_decl (minparent);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
CH_ALREADY_GRANTED (minparent) = 1;
}
}
if (minparent != maxparent && maxparent != NULL_TREE)
{
if (!CH_ALREADY_GRANTED (maxparent))
{
mode_string = decode_decl (maxparent);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
CH_ALREADY_GRANTED (maxparent) = 1;
}
}
}
else
{
mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
return result;
}
/* see if we have a range */
if (TREE_TYPE (type) != NULL)
{
mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
return result;
}
static MYSTRING *
print_struct (type)
tree type;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
tree fields;
if (chill_varying_type_p (type))
{
mode_string = grant_array_type (type);
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
fields = TYPE_FIELDS (type);
APPEND (result, "STRUCT (");
while (fields != NULL_TREE)
{
if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
{
tree variants;
/* Format a tagged variant record type. */
APPEND (result, " CASE ");
if (TYPE_TAGFIELDS (TREE_TYPE (fields)) != NULL_TREE)
{
tree tag_list = TYPE_TAGFIELDS (TREE_TYPE (fields));
for (;;)
{
tree tag_name = DECL_NAME (TREE_VALUE (tag_list));
APPEND (result, IDENTIFIER_POINTER (tag_name));
tag_list = TREE_CHAIN (tag_list);
if (tag_list == NULL_TREE)
break;
APPEND (result, ", ");
}
}
APPEND (result, " OF\n");
variants = TYPE_FIELDS (TREE_TYPE (fields));
/* Each variant is a FIELD_DECL whose type is an anonymous
struct within the anonymous union. */
while (variants != NULL_TREE)
{
tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
while (tag_list != NULL_TREE)
{
tree tag_values = TREE_VALUE (tag_list);
APPEND (result, " (");
while (tag_values != NULL_TREE)
{
mode_string = get_tag_value (TREE_VALUE (tag_values));
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_CHAIN (tag_values) != NULL_TREE)
{
APPEND (result, ",\n ");
tag_values = TREE_CHAIN (tag_values);
}
else break;
}
APPEND (result, ")");
tag_list = TREE_CHAIN (tag_list);
if (tag_list)
APPEND (result, ",");
else
break;
}
APPEND (result, " : ");
while (struct_elts != NULL_TREE)
{
mode_string = decode_decl (struct_elts);
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_CHAIN (struct_elts) != NULL_TREE)
APPEND (result, ",\n ");
struct_elts = TREE_CHAIN (struct_elts);
}
variants = TREE_CHAIN (variants);
if (variants != NULL_TREE
&& TREE_CHAIN (variants) == NULL_TREE
&& DECL_NAME (variants) == ELSE_VARIANT_NAME)
{
tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
APPEND (result, "\n ELSE ");
while (else_elts != NULL_TREE)
{
mode_string = decode_decl (else_elts);
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_CHAIN (else_elts) != NULL_TREE)
APPEND (result, ",\n ");
else_elts = TREE_CHAIN (else_elts);
}
break;
}
if (variants != NULL_TREE)
APPEND (result, ",\n");
}
APPEND (result, "\n ESAC");
}
else
{
mode_string = decode_decl (fields);
APPEND (result, mode_string->str);
FREE (mode_string);
}
fields = TREE_CHAIN (fields);
if (fields != NULL_TREE)
APPEND (result, ",\n ");
}
APPEND (result, ")");
}
return result;
}
static MYSTRING *
print_struct_selective (type, all_decls)
tree type;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
tree fields;
if (chill_varying_type_p (type))
{
mode_string = grant_array_type_selective (type, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
fields = TYPE_FIELDS (type);
while (fields != NULL_TREE)
{
if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
{
tree variants;
/* Format a tagged variant record type. */
variants = TYPE_FIELDS (TREE_TYPE (fields));
/* Each variant is a FIELD_DECL whose type is an anonymous
struct within the anonymous union. */
while (variants != NULL_TREE)
{
tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
while (tag_list != NULL_TREE)
{
tree tag_values = TREE_VALUE (tag_list);
while (tag_values != NULL_TREE)
{
mode_string = get_tag_value_selective (TREE_VALUE (tag_values),
all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
if (TREE_CHAIN (tag_values) != NULL_TREE)
tag_values = TREE_CHAIN (tag_values);
else break;
}
tag_list = TREE_CHAIN (tag_list);
if (!tag_list)
break;
}
while (struct_elts != NULL_TREE)
{
mode_string = decode_decl_selective (struct_elts, all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
struct_elts = TREE_CHAIN (struct_elts);
}
variants = TREE_CHAIN (variants);
if (variants != NULL_TREE
&& TREE_CHAIN (variants) == NULL_TREE
&& DECL_NAME (variants) == ELSE_VARIANT_NAME)
{
tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
while (else_elts != NULL_TREE)
{
mode_string = decode_decl_selective (else_elts, all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
else_elts = TREE_CHAIN (else_elts);
}
break;
}
}
}
else
{
mode_string = decode_decl_selective (fields, all_decls);
APPEND (result, mode_string->str);
FREE (mode_string);
}
fields = TREE_CHAIN (fields);
}
}
return result;
}
static MYSTRING *
print_proc_exceptions (ex)
tree ex;
{
MYSTRING *result = newstring ("");
if (ex != NULL_TREE)
{
APPEND (result, "\n EXCEPTIONS (");
for ( ; ex != NULL_TREE; ex = TREE_CHAIN (ex))
{
APPEND (result, IDENTIFIER_POINTER (TREE_VALUE (ex)));
if (TREE_CHAIN (ex) != NULL_TREE)
APPEND (result, ",\n ");
}
APPEND (result, ")");
}
return result;
}
static MYSTRING *
print_proc_tail (type, args, print_argnames)
tree type;
tree args;
int print_argnames;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
int count = 0;
int stopat = list_length (args) - 3;
/* do the argument modes */
for ( ; args != NULL_TREE;
args = TREE_CHAIN (args), count++)
{
char buf[20];
tree argmode = TREE_VALUE (args);
tree attribute = TREE_PURPOSE (args);
if (argmode == void_type_node)
continue;
/* if we have exceptions don't print last 2 arguments */
if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
break;
if (count)
APPEND (result, ",\n ");
if (print_argnames)
{
sprintf(buf, "arg%d ", count);
APPEND (result, buf);
}
if (attribute == ridpointers[(int) RID_LOC])
argmode = TREE_TYPE (argmode);
mode_string = get_type (argmode);
APPEND (result, mode_string->str);
FREE (mode_string);
if (attribute != NULL_TREE)
{
sprintf (buf, " %s", IDENTIFIER_POINTER (attribute));
APPEND (result, buf);
}
}
APPEND (result, ")");
/* return type */
{
tree retn_type = TREE_TYPE (type);
if (retn_type != NULL_TREE
&& TREE_CODE (retn_type) != VOID_TYPE)
{
mode_string = get_type (retn_type);
APPEND (result, "\n RETURNS (");
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_CODE (retn_type) == REFERENCE_TYPE)
APPEND (result, " LOC");
APPEND (result, ")");
}
}
mode_string = print_proc_exceptions (TYPE_RAISES_EXCEPTIONS (type));
APPEND (result, mode_string->str);
FREE (mode_string);
return result;
}
static MYSTRING *
print_proc_tail_selective (type, args, all_decls)
tree type;
tree args;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
int count = 0;
int stopat = list_length (args) - 3;
/* do the argument modes */
for ( ; args != NULL_TREE;
args = TREE_CHAIN (args), count++)
{
tree argmode = TREE_VALUE (args);
tree attribute = TREE_PURPOSE (args);
if (argmode == void_type_node)
continue;
/* if we have exceptions don't process last 2 arguments */
if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
break;
if (attribute == ridpointers[(int) RID_LOC])
argmode = TREE_TYPE (argmode);
mode_string = get_type_selective (argmode, all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
/* return type */
{
tree retn_type = TREE_TYPE (type);
if (retn_type != NULL_TREE
&& TREE_CODE (retn_type) != VOID_TYPE)
{
mode_string = get_type_selective (retn_type, all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
}
return result;
}
/* output a mode (or type). */
static MYSTRING *
decode_mode (type)
tree type;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
switch ((enum chill_tree_code)TREE_CODE (type))
{
case TYPE_DECL:
if (DECL_NAME (type))
{
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (type)));
return result;
}
type = TREE_TYPE (type);
break;
case IDENTIFIER_NODE:
APPEND (result, IDENTIFIER_POINTER (type));
return result;
case LANG_TYPE:
/* LANG_TYPE are only used until satisfy is done,
as place-holders for 'READ T', NEWMODE/SYNMODE modes,
parameterised modes, and old-fashioned CHAR(N). */
if (TYPE_READONLY (type))
APPEND (result, "READ ");
mode_string = get_type (TREE_TYPE (type));
APPEND (result, mode_string->str);
if (TYPE_DOMAIN (type) != NULL_TREE)
{
/* Parameterized mode,
or old-fashioned CHAR(N) string declaration.. */
APPEND (result, "(");
mode_string = decode_constant (TYPE_DOMAIN (type));
APPEND (result, mode_string->str);
APPEND (result, ")");
}
FREE (mode_string);
break;
case ARRAY_TYPE:
mode_string = grant_array_type (type);
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case BOOLEAN_TYPE:
APPEND (result, "BOOL");
break;
case CHAR_TYPE:
APPEND (result, "CHAR");
break;
case ENUMERAL_TYPE:
mode_string = print_enumeral (type);
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case FUNCTION_TYPE:
{
tree args = TYPE_ARG_TYPES (type);
APPEND (result, "PROC (");
mode_string = print_proc_tail (type, args, 0);
APPEND (result, mode_string->str);
FREE (mode_string);
}
break;
case INTEGER_TYPE:
mode_string = print_integer_type (type);
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case RECORD_TYPE:
if (CH_IS_INSTANCE_MODE (type))
{
APPEND (result, "INSTANCE");
return result;
}
else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
{ tree bufsize = max_queue_size (type);
APPEND (result, CH_IS_BUFFER_MODE (type) ? "BUFFER " : "EVENT ");
if (bufsize != NULL_TREE)
{
APPEND (result, "(");
mode_string = decode_constant (bufsize);
APPEND (result, mode_string->str);
APPEND (result, ") ");
FREE (mode_string);
}
if (CH_IS_BUFFER_MODE (type))
{
mode_string = decode_mode (buffer_element_mode (type));
APPEND (result, mode_string->str);
FREE (mode_string);
}
break;
}
else if (CH_IS_ACCESS_MODE (type))
{
tree indexmode, recordmode, dynamic;
APPEND (result, "ACCESS");
recordmode = access_recordmode (type);
indexmode = access_indexmode (type);
dynamic = access_dynamic (type);
if (indexmode != void_type_node)
{
mode_string = decode_mode (indexmode);
APPEND (result, " (");
APPEND (result, mode_string->str);
APPEND (result, ")");
FREE (mode_string);
}
if (recordmode != void_type_node)
{
mode_string = decode_mode (recordmode);
APPEND (result, " ");
APPEND (result, mode_string->str);
FREE (mode_string);
}
if (dynamic != integer_zero_node)
APPEND (result, " DYNAMIC");
break;
}
else if (CH_IS_TEXT_MODE (type))
{
tree indexmode, dynamic, length;
APPEND (result, "TEXT (");
length = text_length (type);
indexmode = text_indexmode (type);
dynamic = text_dynamic (type);
mode_string = decode_constant (length);
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, ")");
if (indexmode != void_type_node)
{
APPEND (result, " ");
mode_string = decode_mode (indexmode);
APPEND (result, mode_string->str);
FREE (mode_string);
}
if (dynamic != integer_zero_node)
APPEND (result, " DYNAMIC");
return result;
}
mode_string = print_struct (type);
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case POINTER_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
APPEND (result, "PTR");
else
{
if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
{
mode_string = get_type (TREE_TYPE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
APPEND (result, "REF ");
mode_string = get_type (TREE_TYPE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
}
}
break;
case REAL_TYPE:
if (TREE_INT_CST_LOW (TYPE_SIZE (type)) == 32)
APPEND (result, "REAL");
else
APPEND (result, "LONG_REAL");
break;
case SET_TYPE:
if (CH_BOOLS_TYPE_P (type))
mode_string = grant_array_type (type);
else
{
APPEND (result, "POWERSET ");
mode_string = get_type (TYPE_DOMAIN (type));
}
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case REFERENCE_TYPE:
mode_string = get_type (TREE_TYPE (type));
APPEND (result, mode_string->str);
FREE (mode_string);
break;
default:
APPEND (result, "/* ---- not implemented ---- */");
break;
}
return (result);
}
static tree
find_in_decls (id, all_decls)
tree id;
tree all_decls;
{
tree wrk;
for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
{
if (DECL_NAME (wrk) == id || DECL_POSTFIX (wrk) == id)
return wrk;
}
return NULL_TREE;
}
static int
in_ridpointers (id)
tree id;
{
int i;
for (i = RID_UNUSED; i < RID_MAX; i++)
{
if (id == ridpointers[i])
return 1;
}
return 0;
}
static void
grant_seized_identifier (decl)
tree decl;
{
seizefile_list *wrk = selective_seizes;
MYSTRING *mode_string;
CH_ALREADY_GRANTED (decl) = 1;
/* comes from a SPEC MODULE in the module */
if (DECL_SEIZEFILE (decl) == NULL_TREE)
return;
/* search file already in process */
while (wrk != 0)
{
if (wrk->filename == DECL_SEIZEFILE (decl))
break;
wrk = wrk->next;
}
if (!wrk)
{
wrk = (seizefile_list *)xmalloc (sizeof (seizefile_list));
wrk->next = selective_seizes;
selective_seizes = wrk;
wrk->filename = DECL_SEIZEFILE (decl);
wrk->seizes = newstring ("<> USE_SEIZE_FILE \"");
APPEND (wrk->seizes, IDENTIFIER_POINTER (DECL_SEIZEFILE (decl)));
APPEND (wrk->seizes, "\" <>\n");
}
APPEND (wrk->seizes, "SEIZE ");
mode_string = decode_prefix_rename (decl);
APPEND (wrk->seizes, mode_string->str);
FREE (mode_string);
APPEND (wrk->seizes, ";\n");
}
static MYSTRING *
decode_mode_selective (type, all_decls)
tree type;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
tree decl;
switch ((enum chill_tree_code)TREE_CODE (type))
{
case TYPE_DECL:
/* FIXME: could this ever happen ?? */
if (DECL_NAME (type))
{
FREE (result);
result = decode_mode_selective (DECL_NAME (type), all_decls);
return result;
}
break;
case IDENTIFIER_NODE:
if (in_ridpointers (type))
/* it's a predefined, we must not search the whole list */
return result;
decl = find_in_decls (type, all_decls);
if (decl != NULL_TREE)
{
if (CH_ALREADY_GRANTED (decl))
/* already processed */
return result;
if (TREE_CODE (decl) == ALIAS_DECL && DECL_POSTFIX (decl) != NULL_TREE)
{
/* If CH_DECL_GRANTED, decl was granted into this scope, and
so wasn't in the source code. */
if (!CH_DECL_GRANTED (decl))
{
grant_seized_identifier (decl);
}
}
else
{
result = decode_decl (decl);
mode_string = decode_decl_selective (decl, all_decls);
if (mode_string->len)
{
PREPEND (result, mode_string->str);
}
FREE (mode_string);
}
}
return result;
case LANG_TYPE:
mode_string = get_type_selective (TREE_TYPE (type), all_decls);
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case ARRAY_TYPE:
mode_string = grant_array_type_selective (type, all_decls);
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case BOOLEAN_TYPE:
return result;
break;
case CHAR_TYPE:
return result;
break;
case ENUMERAL_TYPE:
mode_string = print_enumeral_selective (type, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case FUNCTION_TYPE:
{
tree args = TYPE_ARG_TYPES (type);
mode_string = print_proc_tail_selective (type, args, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
break;
case INTEGER_TYPE:
mode_string = print_integer_selective (type, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case RECORD_TYPE:
if (CH_IS_INSTANCE_MODE (type))
{
return result;
}
else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
{
tree bufsize = max_queue_size (type);
if (bufsize != NULL_TREE)
{
mode_string = decode_constant_selective (bufsize, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
if (CH_IS_BUFFER_MODE (type))
{
mode_string = decode_mode_selective (buffer_element_mode (type), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
break;
}
else if (CH_IS_ACCESS_MODE (type))
{
tree indexmode = access_indexmode (type);
tree recordmode = access_recordmode (type);
if (indexmode != void_type_node)
{
mode_string = decode_mode_selective (indexmode, all_decls);
if (mode_string->len)
{
if (result->len && result->str[result->len - 1] != '\n')
APPEND (result, ";\n");
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
if (recordmode != void_type_node)
{
mode_string = decode_mode_selective (recordmode, all_decls);
if (mode_string->len)
{
if (result->len && result->str[result->len - 1] != '\n')
APPEND (result, ";\n");
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
break;
}
else if (CH_IS_TEXT_MODE (type))
{
tree indexmode = text_indexmode (type);
tree length = text_length (type);
mode_string = decode_constant_selective (length, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
if (indexmode != void_type_node)
{
mode_string = decode_mode_selective (indexmode, all_decls);
if (mode_string->len)
{
if (result->len && result->str[result->len - 1] != '\n')
APPEND (result, ";\n");
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
break;
}
mode_string = print_struct_selective (type, all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
break;
case POINTER_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
break;
else
{
if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
{
mode_string = get_type_selective (TREE_TYPE (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
else
{
mode_string = get_type_selective (TREE_TYPE (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
}
break;
case REAL_TYPE:
return result;
break;
case SET_TYPE:
if (CH_BOOLS_TYPE_P (type))
mode_string = grant_array_type_selective (type, all_decls);
else
mode_string = get_type_selective (TYPE_DOMAIN (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case REFERENCE_TYPE:
mode_string = get_type_selective (TREE_TYPE (type), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
break;
default:
APPEND (result, "/* ---- not implemented ---- */");
break;
}
return (result);
}
static MYSTRING *
get_type (type)
tree type;
{
if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
return newstring ("");
return (decode_mode (type));
}
static MYSTRING *
get_type_selective (type, all_decls)
tree type;
tree all_decls;
{
if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
return newstring ("");
return (decode_mode_selective (type, all_decls));
}
#if 0
static int
is_forbidden (str, forbid)
tree str;
tree forbid;
{
if (forbid == NULL_TREE)
return (0);
if (TREE_CODE (forbid) == INTEGER_CST)
return (1);
while (forbid != NULL_TREE)
{
if (TREE_VALUE (forbid) == str)
return (1);
forbid = TREE_CHAIN (forbid);
}
/* nothing found */
return (0);
}
#endif
static MYSTRING *
decode_constant (init)
tree init;
{
MYSTRING *result = newstring ("");
MYSTRING *tmp_string;
tree type = TREE_TYPE (init);
tree val = init;
char *op;
char wrk[256];
MYSTRING *mode_string;
switch ((enum chill_tree_code)TREE_CODE (val))
{
case CALL_EXPR:
tmp_string = decode_constant (TREE_OPERAND (val, 0));
APPEND (result, tmp_string->str);
FREE (tmp_string);
val = TREE_OPERAND (val, 1); /* argument list */
if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
{
APPEND (result, " ");
tmp_string = decode_constant (val);
APPEND (result, tmp_string->str);
FREE (tmp_string);
}
else
{
APPEND (result, " (");
if (val != NULL_TREE)
{
for (;;)
{
tmp_string = decode_constant (TREE_VALUE (val));
APPEND (result, tmp_string->str);
FREE (tmp_string);
val = TREE_CHAIN (val);
if (val == NULL_TREE)
break;
APPEND (result, ", ");
}
}
APPEND (result, ")");
}
return result;
case NOP_EXPR:
/* Generate an "expression conversion" expression (a cast). */
tmp_string = decode_mode (type);
APPEND (result, tmp_string->str);
FREE (tmp_string);
APPEND (result, "(");
val = TREE_OPERAND (val, 0);
type = TREE_TYPE (val);
/* If the coercee is a tuple, make sure it is prefixed by its mode. */
if (TREE_CODE (val) == CONSTRUCTOR
&& !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
{
tmp_string = decode_mode (type);
APPEND (result, tmp_string->str);
FREE (tmp_string);
APPEND (result, " ");
}
tmp_string = decode_constant (val);
APPEND (result, tmp_string->str);
FREE (tmp_string);
APPEND (result, ")");
return result;
case IDENTIFIER_NODE:
APPEND (result, IDENTIFIER_POINTER (val));
return result;
case PAREN_EXPR:
APPEND (result, "(");
tmp_string = decode_constant (TREE_OPERAND (val, 0));
APPEND (result, tmp_string->str);
FREE (tmp_string);
APPEND (result, ")");
return result;
case UNDEFINED_EXPR:
APPEND (result, "*");
return result;
case PLUS_EXPR: op = "+"; goto binary;
case MINUS_EXPR: op = "-"; goto binary;
case MULT_EXPR: op = "*"; goto binary;
case TRUNC_DIV_EXPR: op = "/"; goto binary;
case FLOOR_MOD_EXPR: op = " MOD "; goto binary;
case TRUNC_MOD_EXPR: op = " REM "; goto binary;
case CONCAT_EXPR: op = "//"; goto binary;
case BIT_IOR_EXPR: op = " OR "; goto binary;
case BIT_XOR_EXPR: op = " XOR "; goto binary;
case TRUTH_ORIF_EXPR: op = " ORIF "; goto binary;
case BIT_AND_EXPR: op = " AND "; goto binary;
case TRUTH_ANDIF_EXPR: op = " ANDIF "; goto binary;
case GT_EXPR: op = ">"; goto binary;
case GE_EXPR: op = ">="; goto binary;
case SET_IN_EXPR: op = " IN "; goto binary;
case LT_EXPR: op = "<"; goto binary;
case LE_EXPR: op = "<="; goto binary;
case EQ_EXPR: op = "="; goto binary;
case NE_EXPR: op = "/="; goto binary;
case RANGE_EXPR:
if (TREE_OPERAND (val, 0) == NULL_TREE)
{
APPEND (result, TREE_OPERAND (val, 1) == NULL_TREE ? "*" : "ELSE");
return result;
}
op = ":"; goto binary;
binary:
tmp_string = decode_constant (TREE_OPERAND (val, 0));
APPEND (result, tmp_string->str);
FREE (tmp_string);
APPEND (result, op);
tmp_string = decode_constant (TREE_OPERAND (val, 1));
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case REPLICATE_EXPR:
APPEND (result, "(");
tmp_string = decode_constant (TREE_OPERAND (val, 0));
APPEND (result, tmp_string->str);
FREE (tmp_string);
APPEND (result, ")");
tmp_string = decode_constant (TREE_OPERAND (val, 1));
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case NEGATE_EXPR: op = "-"; goto unary;
case BIT_NOT_EXPR: op = " NOT "; goto unary;
case ADDR_EXPR: op = "->"; goto unary;
unary:
APPEND (result, op);
tmp_string = decode_constant (TREE_OPERAND (val, 0));
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case INTEGER_CST:
APPEND (result, display_int_cst (val));
return result;
case REAL_CST:
#ifndef REAL_IS_NOT_DOUBLE
sprintf (wrk, "%.20g", TREE_REAL_CST (val));
#else
REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk);
#endif
APPEND (result, wrk);
return result;
case STRING_CST:
{
char *ptr = TREE_STRING_POINTER (val);
int i = TREE_STRING_LENGTH (val);
APPEND (result, "\"");
while (--i >= 0)
{
char buf[10];
unsigned char c = *ptr++;
if (c == '^')
APPEND (result, "^^");
else if (c == '"')
APPEND (result, "\"\"");
else if (c == '\n')
APPEND (result, "^J");
else if (c < ' ' || c > '~')
{
sprintf (buf, "^(%u)", c);
APPEND (result, buf);
}
else
{
buf[0] = c;
buf[1] = 0;
APPEND (result, buf);
}
}
APPEND (result, "\"");
return result;
}
case CONSTRUCTOR:
val = TREE_OPERAND (val, 1);
if (type != NULL && TREE_CODE (type) == SET_TYPE
&& CH_BOOLS_TYPE_P (type))
{
/* It's a bitstring. */
tree domain = TYPE_DOMAIN (type);
tree domain_max = TYPE_MAX_VALUE (domain);
char *buf;
register char *ptr;
int len;
if (TREE_CODE (domain_max) != INTEGER_CST
|| (val && TREE_CODE (val) != TREE_LIST))
goto fail;
len = TREE_INT_CST_LOW (domain_max) + 1;
if (TREE_CODE (init) != CONSTRUCTOR)
goto fail;
buf = (char *) alloca (len + 10);
ptr = buf;
*ptr++ = ' ';
*ptr++ = 'B';
*ptr++ = '\'';
if (get_set_constructor_bits (init, ptr, len))
goto fail;
for (; --len >= 0; ptr++)
*ptr += '0';
*ptr++ = '\'';
*ptr = '\0';
APPEND (result, buf);
return result;
}
else
{ /* It's some kind of tuple */
if (type != NULL_TREE)
{
mode_string = get_type (type);
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, " ");
}
if (val == NULL_TREE
|| TREE_CODE (val) == ERROR_MARK)
APPEND (result, "[ ]");
else if (TREE_CODE (val) != TREE_LIST)
goto fail;
else
{
APPEND (result, "[");
for ( ; ; )
{
tree lo_val = TREE_PURPOSE (val);
tree hi_val = TREE_VALUE (val);
MYSTRING *val_string;
if (TUPLE_NAMED_FIELD (val))
APPEND(result, ".");
if (lo_val != NULL_TREE)
{
val_string = decode_constant (lo_val);
APPEND (result, val_string->str);
FREE (val_string);
APPEND (result, ":");
}
val_string = decode_constant (hi_val);
APPEND (result, val_string->str);
FREE (val_string);
val = TREE_CHAIN (val);
if (val == NULL_TREE)
break;
APPEND (result, ", ");
}
APPEND (result, "]");
}
}
return result;
case COMPONENT_REF:
{
tree op1;
mode_string = decode_constant (TREE_OPERAND (init, 0));
APPEND (result, mode_string->str);
FREE (mode_string);
op1 = TREE_OPERAND (init, 1);
if (TREE_CODE (op1) != IDENTIFIER_NODE)
{
error ("decode_constant: invalid component_ref");
break;
}
APPEND (result, ".");
APPEND (result, IDENTIFIER_POINTER (op1));
return result;
}
fail:
error ("decode_constant: mode and value mismatch");
break;
default:
error ("decode_constant: cannot decode this mode");
break;
}
return result;
}
static MYSTRING *
decode_constant_selective (init, all_decls)
tree init;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *tmp_string;
tree type = TREE_TYPE (init);
tree val = init;
MYSTRING *mode_string;
switch ((enum chill_tree_code)TREE_CODE (val))
{
case CALL_EXPR:
tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
val = TREE_OPERAND (val, 1); /* argument list */
if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
{
tmp_string = decode_constant_selective (val, all_decls);
if (tmp_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, tmp_string->str);
}
FREE (tmp_string);
}
else
{
if (val != NULL_TREE)
{
for (;;)
{
tmp_string = decode_constant_selective (TREE_VALUE (val), all_decls);
if (tmp_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, tmp_string->str);
}
FREE (tmp_string);
val = TREE_CHAIN (val);
if (val == NULL_TREE)
break;
}
}
}
return result;
case NOP_EXPR:
/* Generate an "expression conversion" expression (a cast). */
tmp_string = decode_mode_selective (type, all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
val = TREE_OPERAND (val, 0);
type = TREE_TYPE (val);
/* If the coercee is a tuple, make sure it is prefixed by its mode. */
if (TREE_CODE (val) == CONSTRUCTOR
&& !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
{
tmp_string = decode_mode_selective (type, all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
}
tmp_string = decode_constant_selective (val, all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case IDENTIFIER_NODE:
tmp_string = decode_mode_selective (val, all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case PAREN_EXPR:
tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case UNDEFINED_EXPR:
return result;
case PLUS_EXPR:
case MINUS_EXPR:
case MULT_EXPR:
case TRUNC_DIV_EXPR:
case FLOOR_MOD_EXPR:
case TRUNC_MOD_EXPR:
case CONCAT_EXPR:
case BIT_IOR_EXPR:
case BIT_XOR_EXPR:
case TRUTH_ORIF_EXPR:
case BIT_AND_EXPR:
case TRUTH_ANDIF_EXPR:
case GT_EXPR:
case GE_EXPR:
case SET_IN_EXPR:
case LT_EXPR:
case LE_EXPR:
case EQ_EXPR:
case NE_EXPR:
goto binary;
case RANGE_EXPR:
if (TREE_OPERAND (val, 0) == NULL_TREE)
return result;
binary:
tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
if (tmp_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, tmp_string->str);
}
FREE (tmp_string);
return result;
case REPLICATE_EXPR:
tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
if (tmp_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, tmp_string->str);
}
FREE (tmp_string);
return result;
case NEGATE_EXPR:
case BIT_NOT_EXPR:
case ADDR_EXPR:
tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
if (tmp_string->len)
APPEND (result, tmp_string->str);
FREE (tmp_string);
return result;
case INTEGER_CST:
return result;
case REAL_CST:
return result;
case STRING_CST:
return result;
case CONSTRUCTOR:
val = TREE_OPERAND (val, 1);
if (type != NULL && TREE_CODE (type) == SET_TYPE
&& CH_BOOLS_TYPE_P (type))
/* It's a bitstring. */
return result;
else
{ /* It's some kind of tuple */
if (type != NULL_TREE)
{
mode_string = get_type_selective (type, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
if (val == NULL_TREE
|| TREE_CODE (val) == ERROR_MARK)
return result;
else if (TREE_CODE (val) != TREE_LIST)
goto fail;
else
{
for ( ; ; )
{
tree lo_val = TREE_PURPOSE (val);
tree hi_val = TREE_VALUE (val);
MYSTRING *val_string;
if (lo_val != NULL_TREE)
{
val_string = decode_constant_selective (lo_val, all_decls);
if (val_string->len)
APPEND (result, val_string->str);
FREE (val_string);
}
val_string = decode_constant_selective (hi_val, all_decls);
if (val_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, val_string->str);
}
FREE (val_string);
val = TREE_CHAIN (val);
if (val == NULL_TREE)
break;
}
}
}
return result;
case COMPONENT_REF:
{
mode_string = decode_constant_selective (TREE_OPERAND (init, 0), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
return result;
}
fail:
error ("decode_constant_selective: mode and value mismatch");
break;
default:
error ("decode_constant_selective: cannot decode this mode");
break;
}
return result;
}
/* Assuming DECL is an ALIAS_DECL, return its prefix rename clause. */
static MYSTRING *
decode_prefix_rename (decl)
tree decl;
{
MYSTRING *result = newstring ("");
if (DECL_OLD_PREFIX (decl) || DECL_NEW_PREFIX (decl))
{
APPEND (result, "(");
if (DECL_OLD_PREFIX (decl))
APPEND (result, IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)));
APPEND (result, "->");
if (DECL_NEW_PREFIX (decl))
APPEND (result, IDENTIFIER_POINTER (DECL_NEW_PREFIX (decl)));
APPEND (result, ")!");
}
if (DECL_POSTFIX_ALL (decl))
APPEND (result, "ALL");
else
APPEND (result, IDENTIFIER_POINTER (DECL_POSTFIX (decl)));
return result;
}
static MYSTRING *
decode_decl (decl)
tree decl;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
tree type;
switch ((enum chill_tree_code)TREE_CODE (decl))
{
case VAR_DECL:
case BASED_DECL:
APPEND (result, "DCL ");
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
APPEND (result, " ");
mode_string = get_type (TREE_TYPE (decl));
APPEND (result, mode_string->str);
FREE (mode_string);
if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
{
APPEND (result, " BASED (");
APPEND (result, IDENTIFIER_POINTER (DECL_ABSTRACT_ORIGIN (decl)));
APPEND (result, ")");
}
break;
case TYPE_DECL:
if (CH_DECL_SIGNAL (decl))
{
/* this is really a signal */
tree fields = TYPE_FIELDS (TREE_TYPE (decl));
tree signame = DECL_NAME (decl);
tree sigdest;
APPEND (result, "SIGNAL ");
APPEND (result, IDENTIFIER_POINTER (signame));
if (IDENTIFIER_SIGNAL_DATA (signame))
{
APPEND (result, " = (");
for ( ; fields != NULL_TREE;
fields = TREE_CHAIN (fields))
{
MYSTRING *mode_string;
mode_string = get_type (TREE_TYPE (fields));
APPEND (result, mode_string->str);
FREE (mode_string);
if (TREE_CHAIN (fields) != NULL_TREE)
APPEND (result, ", ");
}
APPEND (result, ")");
}
sigdest = IDENTIFIER_SIGNAL_DEST (signame);
if (sigdest != NULL_TREE)
{
APPEND (result, " TO ");
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (sigdest)));
}
}
else
{
/* avoid defining a mode as itself */
if (CH_NOVELTY (TREE_TYPE (decl)) == decl)
APPEND (result, "NEWMODE ");
else
APPEND (result, "SYNMODE ");
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
APPEND (result, " = ");
mode_string = decode_mode (TREE_TYPE (decl));
APPEND (result, mode_string->str);
FREE (mode_string);
}
break;
case FUNCTION_DECL:
{
tree args;
type = TREE_TYPE (decl);
args = TYPE_ARG_TYPES (type);
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
if (CH_DECL_PROCESS (decl))
APPEND (result, ": PROCESS (");
else
APPEND (result, ": PROC (");
args = TYPE_ARG_TYPES (type);
mode_string = print_proc_tail (type, args, 1);
APPEND (result, mode_string->str);
FREE (mode_string);
/* generality */
if (CH_DECL_GENERAL (decl))
APPEND (result, " GENERAL");
if (CH_DECL_SIMPLE (decl))
APPEND (result, " SIMPLE");
if (DECL_INLINE (decl))
APPEND (result, " INLINE");
if (CH_DECL_RECURSIVE (decl))
APPEND (result, " RECURSIVE");
APPEND (result, " END");
}
break;
case FIELD_DECL:
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
APPEND (result, " ");
mode_string = get_type (TREE_TYPE (decl));
APPEND (result, mode_string->str);
FREE (mode_string);
if (DECL_INITIAL (decl) != NULL_TREE)
{
mode_string = decode_layout (DECL_INITIAL (decl));
APPEND (result, mode_string->str);
FREE (mode_string);
}
#if 0
if (is_forbidden (DECL_NAME (decl), forbid))
APPEND (result, " FORBID");
#endif
break;
case CONST_DECL:
if (DECL_INITIAL (decl) == NULL_TREE
|| TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
break;
APPEND (result, "SYN ");
APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
APPEND (result, " ");
mode_string = get_type (TREE_TYPE (decl));
APPEND (result, mode_string->str);
FREE (mode_string);
APPEND (result, " = ");
mode_string = decode_constant (DECL_INITIAL (decl));
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case ALIAS_DECL:
/* If CH_DECL_GRANTED, decl was granted into this scope, and
so wasn't in the source code. */
if (!CH_DECL_GRANTED (decl))
{
static int restricted = 0;
if (DECL_SEIZEFILE (decl) != use_seizefile_name
&& DECL_SEIZEFILE (decl))
{
use_seizefile_name = DECL_SEIZEFILE (decl);
restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
if (! restricted)
grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
mark_use_seizefile_written (use_seizefile_name);
}
if (! restricted)
{
APPEND (result, "SEIZE ");
mode_string = decode_prefix_rename (decl);
APPEND (result, mode_string->str);
FREE (mode_string);
}
}
break;
default:
APPEND (result, "----- not implemented ------");
break;
}
return (result);
}
static MYSTRING *
decode_decl_selective (decl, all_decls)
tree decl;
tree all_decls;
{
MYSTRING *result = newstring ("");
MYSTRING *mode_string;
tree type;
if (CH_ALREADY_GRANTED (decl))
/* do nothing */
return result;
CH_ALREADY_GRANTED (decl) = 1;
switch ((int)TREE_CODE (decl))
{
case VAR_DECL:
case BASED_DECL:
mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
{
mode_string = decode_mode_selective (DECL_ABSTRACT_ORIGIN (decl), all_decls);
if (mode_string->len)
PREPEND (result, mode_string->str);
FREE (mode_string);
}
break;
case TYPE_DECL:
if (CH_DECL_SIGNAL (decl))
{
/* this is really a signal */
tree fields = TYPE_FIELDS (TREE_TYPE (decl));
tree signame = DECL_NAME (decl);
tree sigdest;
if (IDENTIFIER_SIGNAL_DATA (signame))
{
for ( ; fields != NULL_TREE;
fields = TREE_CHAIN (fields))
{
MYSTRING *mode_string;
mode_string = get_type_selective (TREE_TYPE (fields),
all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
}
sigdest = IDENTIFIER_SIGNAL_DEST (signame);
if (sigdest != NULL_TREE)
{
mode_string = decode_mode_selective (DECL_NAME (sigdest), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
}
}
else
{
/* avoid defining a mode as itself */
mode_string = decode_mode_selective (TREE_TYPE (decl), all_decls);
APPEND (result, mode_string->str);
FREE (mode_string);
}
break;
case FUNCTION_DECL:
{
tree args;
type = TREE_TYPE (decl);
args = TYPE_ARG_TYPES (type);
args = TYPE_ARG_TYPES (type);
mode_string = print_proc_tail_selective (type, args, all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
}
break;
case FIELD_DECL:
mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
break;
case CONST_DECL:
if (DECL_INITIAL (decl) == NULL_TREE
|| TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
break;
mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
if (mode_string->len)
APPEND (result, mode_string->str);
FREE (mode_string);
mode_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
if (mode_string->len)
{
MAYBE_NEWLINE (result);
APPEND (result, mode_string->str);
}
FREE (mode_string);
break;
}
MAYBE_NEWLINE (result);
return (result);
}
static void
globalize_decl (decl)
tree decl;
{
if (!TREE_PUBLIC (decl) && DECL_NAME (decl) &&
(TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL))
{
extern FILE *asm_out_file;
extern char *first_global_object_name;
char *name = XSTR (XEXP (DECL_RTL (decl), 0), 0);
if (!first_global_object_name)
first_global_object_name = name + (name[0] == '*');
ASM_GLOBALIZE_LABEL (asm_out_file, name);
}
}
static void
grant_one_decl (decl)
tree decl;
{
MYSTRING *result;
if (DECL_SOURCE_LINE (decl) == 0)
return;
result = decode_decl (decl);
if (result->len)
{
APPEND (result, ";\n");
APPEND (gstring, result->str);
}
FREE (result);
}
static void
grant_one_decl_selective (decl, all_decls)
tree decl;
tree all_decls;
{
MYSTRING *result;
MYSTRING *fixups;
tree d = DECL_ABSTRACT_ORIGIN (decl);
if (CH_ALREADY_GRANTED (d))
/* already done */
return;
result = decode_decl (d);
if (!result->len)
{
/* nothing to do */
FREE (result);
return;
}
APPEND (result, ";\n");
/* now process all undefined items in the decl */
fixups = decode_decl_selective (d, all_decls);
if (fixups->len)
{
PREPEND (result, fixups->str);
}
FREE (fixups);
/* we have finished a decl */
APPEND (selective_gstring, result->str);
FREE (result);
}
static int
compare_memory_file (fname, buf)
char *fname;
char *buf;
{
FILE *fb;
int c;
/* check if we have something to write */
if (!buf || !strlen (buf))
return (0);
if ((fb = fopen (fname, "r")) == NULL)
return (1);
while ((c = getc (fb)) != EOF)
{
if (c != *buf++)
{
fclose (fb);
return (1);
}
}
fclose (fb);
return (*buf ? 1 : 0);
}
void
write_grant_file ()
{
FILE *fb;
/* We only write out the grant file if it has changed,
to avoid changing its time-stamp and triggering an
unnecessary 'make' action. Return if no change. */
if (gstring == NULL || !spec_module_generated ||
!compare_memory_file (grant_file_name, gstring->str))
return;
fb = fopen (grant_file_name, "w");
if (fb == NULL)
pfatal_with_name (grant_file_name);
/* write file. Due to problems with record sizes on VAX/VMS
write string to '\n' */
#ifdef VMS
/* do it this way for VMS, cause of problems with
record sizes */
p = gstring->str;
while (*p)
{
p1 = strchr (p, '\n');
c = *++p1;
*p1 = '\0';
fprintf (fb, "%s", p);
*p1 = c;
p = p1;
}
#else
/* faster way to write */
if (write (fileno (fb), gstring->str, gstring->len) < 0)
{
int save_errno = errno;
unlink (grant_file_name);
errno = save_errno;
pfatal_with_name (grant_file_name);
}
#endif
fclose (fb);
}
/* handle grant statement */
void
set_default_grant_file ()
{
char *p, *tmp, *fname;
if (dump_base_name)
fname = dump_base_name; /* Probably invoked via gcc */
else
{ /* Probably invoked directly (not via gcc) */
fname = asm_file_name;
if (!fname)
fname = main_input_filename ? main_input_filename : input_filename;
if (!fname)
return;
}
p = strrchr (fname, '.');
if (!p)
{
tmp = (char *) alloca (strlen (fname) + 10);
strcpy (tmp, fname);
}
else
{
int i = p - fname;
tmp = (char *) alloca (i + 10);
strncpy (tmp, fname, i);
tmp[i] = '\0';
}
strcat (tmp, ".grt");
default_grant_file = build_string (strlen (tmp), tmp);
grant_file_name = TREE_STRING_POINTER (default_grant_file);
if (gstring == NULL)
gstring = newstring ("");
if (selective_gstring == NULL)
selective_gstring = newstring ("");
}
/* Make DECL visible under the name NAME in the (fake) outermost scope. */
void
push_granted (name, decl)
tree name ATTRIBUTE_UNUSED, decl ATTRIBUTE_UNUSED;
{
#if 0
IDENTIFIER_GRANTED_VALUE (name) = decl;
granted_decls = tree_cons (name, decl, granted_decls);
#endif
}
void
chill_grant (old_prefix, new_prefix, postfix, forbid)
tree old_prefix;
tree new_prefix;
tree postfix;
tree forbid;
{
if (pass == 1)
{
#if 0
tree old_name = old_prefix == NULL_TREE ? postfix
: get_identifier3 (IDENTIFIER_POINTER (old_prefix),
"!", IDENTIFIER_POINTER (postfix));
tree new_name = new_prefix == NULL_TREE ? postfix
: get_identifier3 (IDENTIFIER_POINTER (new_prefix),
"!", IDENTIFIER_POINTER (postfix));
#endif
tree alias = build_alias_decl (old_prefix, new_prefix, postfix);
CH_DECL_GRANTED (alias) = 1;
DECL_SEIZEFILE (alias) = current_seizefile_name;
TREE_CHAIN (alias) = current_module->granted_decls;
current_module->granted_decls = alias;
if (forbid)
warning ("FORBID is not yet implemented"); /* FIXME */
}
}
/* flag GRANT ALL only once. Avoids search in case of GRANT ALL. */
static int grant_all_seen = 0;
/* check if a decl is in the list of granted decls. */
static int
search_in_list (name, granted_decls)
tree name;
tree granted_decls;
{
tree vars;
for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
if (DECL_SOURCE_LINE (vars))
{
if (DECL_POSTFIX_ALL (vars))
{
grant_all_seen = 1;
return 1;
}
else if (name == DECL_NAME (vars))
return 1;
}
/* not found */
return 0;
}
static int
really_grant_this (decl, granted_decls)
tree decl;
tree granted_decls;
{
/* we never grant labels at module level */
if ((enum chill_tree_code)TREE_CODE (decl) == LABEL_DECL)
return 0;
if (grant_all_seen)
return 1;
switch ((enum chill_tree_code)TREE_CODE (decl))
{
case VAR_DECL:
case BASED_DECL:
case FUNCTION_DECL:
return search_in_list (DECL_NAME (decl), granted_decls);
case ALIAS_DECL:
case CONST_DECL:
return 1;
case TYPE_DECL:
if (CH_DECL_SIGNAL (decl))
return search_in_list (DECL_NAME (decl), granted_decls);
else
return 1;
default:
break;
}
/* this nerver should happen */
error_with_decl (decl, "function \"really_grant_this\" called for `%s'.");
return 1;
}
/* Write a SPEC MODULE using the declarations in the list DECLS. */
static int header_written = 0;
static char *header_template =
"--\n-- WARNING: this file was generated by\n\
-- GNUCHILL version %s\n-- based on gcc version %s\n--\n";
void
write_spec_module (decls, granted_decls)
tree decls;
tree granted_decls;
{
tree vars;
char *hdr;
if (granted_decls == NULL_TREE)
return;
use_seizefile_name = NULL_TREE;
if (!header_written)
{
hdr = (char*) alloca (strlen (gnuchill_version)
+ strlen (version_string)
+ strlen (header_template) + 1);
sprintf (hdr, header_template, gnuchill_version, version_string);
APPEND (gstring, hdr);
header_written = 1;
}
APPEND (gstring, IDENTIFIER_POINTER (current_module->name));
APPEND (gstring, ": SPEC MODULE\n");
/* first of all we look for GRANT ALL specified */
search_in_list (NULL_TREE, granted_decls);
if (grant_all_seen != 0)
{
/* write all identifiers to grant file */
for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
{
if (DECL_SOURCE_LINE (vars))
{
if (DECL_NAME (vars))
{
if ((TREE_CODE (vars) != CONST_DECL || !CH_DECL_ENUM (vars)) &&
really_grant_this (vars, granted_decls))
grant_one_decl (vars);
}
else if (DECL_POSTFIX_ALL (vars))
{
static int restricted = 0;
if (DECL_SEIZEFILE (vars) != use_seizefile_name
&& DECL_SEIZEFILE (vars))
{
use_seizefile_name = DECL_SEIZEFILE (vars);
restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
if (! restricted)
grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
mark_use_seizefile_written (use_seizefile_name);
}
if (! restricted)
{
APPEND (gstring, "SEIZE ALL;\n");
}
}
}
}
}
else
{
seizefile_list *wrk, *x;
/* do a selective write to the grantfile. This will reduce the
size of a grantfile and speed up compilation of
modules depending on this grant file */
if (selective_gstring == 0)
selective_gstring = newstring ("");
/* first of all process all SEIZE ALL's */
for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
{
if (DECL_SOURCE_LINE (vars)
&& DECL_POSTFIX_ALL (vars))
grant_seized_identifier (vars);
}
/* now walk through granted decls */
granted_decls = nreverse (granted_decls);
for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
{
grant_one_decl_selective (vars, decls);
}
granted_decls = nreverse (granted_decls);
/* append all SEIZES */
wrk = selective_seizes;
while (wrk != 0)
{
x = wrk->next;
APPEND (gstring, wrk->seizes->str);
FREE (wrk->seizes);
free (wrk);
wrk = x;
}
selective_seizes = 0;
/* append generated string to grant file */
APPEND (gstring, selective_gstring->str);
FREE (selective_gstring);
selective_gstring = NULL;
}
for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
if (DECL_SOURCE_LINE (vars))
{
MYSTRING *mode_string = decode_prefix_rename (vars);
APPEND (gstring, "GRANT ");
APPEND (gstring, mode_string->str);
FREE (mode_string);
APPEND (gstring, ";\n");
}
APPEND (gstring, "END;\n");
spec_module_generated = 1;
/* initialize this for next spec module */
grant_all_seen = 0;
}
/*
* after the dark comes, after all of the modules are at rest,
* we tuck the compilation unit to bed... A story in pass 1
* and a hug-and-a-kiss goodnight in pass 2.
*/
void
chill_finish_compile ()
{
tree global_list;
tree chill_init_function;
tasking_setup ();
build_enum_tables ();
/* We only need an initializer function for the source file if
a) there's module-level code to be called, or
b) tasking-related stuff to be initialized. */
if (module_init_list != NULL_TREE || tasking_list != NULL_TREE)
{
extern tree initializer_type;
static tree chill_init_name;
/* declare the global initializer list */
global_list = do_decl (get_identifier ("_ch_init_list"),
build_chill_pointer_type (initializer_type), 1, 0,
NULL_TREE, 1);
/* Now, we're building the function which is the *real*
constructor - if there's any module-level code in this
source file, the compiler puts the file's initializer entry
onto the global initializer list, so each module's body code
will eventually get called, after all of the processes have
been started up. */
/* This is better done in pass 2 (when first_global_object_name
may have been set), but that is too late.
Perhaps rewrite this so nothing is done in pass 1. */
if (pass == 1)
{
extern char *first_global_object_name;
/* If we don't do this spoof, we get the name of the first
tasking_code variable, and not the file name. */
char *tmp = first_global_object_name;
first_global_object_name = NULL;
chill_init_name = get_file_function_name ('I');
first_global_object_name = tmp;
/* strip off the file's extension, if any. */
tmp = strrchr (IDENTIFIER_POINTER (chill_init_name), '.');
if (tmp)
*tmp = '\0';
}
start_chill_function (chill_init_name, void_type_node, NULL_TREE,
NULL_TREE, NULL_TREE);
TREE_PUBLIC (current_function_decl) = 1;
chill_init_function = current_function_decl;
/* For each module that we've compiled, that had module-level
code to be called, add its entry to the global initializer
list. */
if (pass == 2)
{
tree module_init;
for (module_init = module_init_list;
module_init != NULL_TREE;
module_init = TREE_CHAIN (module_init))
{
tree init_entry = TREE_VALUE (module_init);
/* assign module_entry.next := _ch_init_list; */
expand_expr_stmt (
build_chill_modify_expr (
build_component_ref (init_entry,
get_identifier ("__INIT_NEXT")),
global_list));
/* assign _ch_init_list := &module_entry; */
expand_expr_stmt (
build_chill_modify_expr (global_list,
build1 (ADDR_EXPR, ptr_type_node, init_entry)));
}
}
tasking_registry ();
make_decl_rtl (current_function_decl, NULL, 1);
finish_chill_function ();
if (pass == 2)
{
assemble_constructor (IDENTIFIER_POINTER (chill_init_name));
globalize_decl (chill_init_function);
}
/* ready now to link decls onto this list in pass 2. */
module_init_list = NULL_TREE;
tasking_list = NULL_TREE;
}
}