diff options
Diffstat (limited to 'gcc/ch/grant.c')
| -rw-r--r-- | gcc/ch/grant.c | 3053 |
1 files changed, 3053 insertions, 0 deletions
diff --git a/gcc/ch/grant.c b/gcc/ch/grant.c new file mode 100644 index 0000000..5dcf450 --- /dev/null +++ b/gcc/ch/grant.c @@ -0,0 +1,3053 @@ +/* Implement grant-file output & seize-file input for CHILL. + Copyright (C) 1992, 93, 94, 95, 1996 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, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include <stdio.h> +#include <string.h> +#include <limits.h> +#include "config.h" +#include "tree.h" +#include "ch-tree.h" +#include "lex.h" +#include "flags.h" +#include "actions.h" +#include "input.h" +#include "errno.h" +#include "rtl.h" +#include "tasking.h" + +/* Disable possible macro over-rides, so the externs parse + portably. */ +#undef strchr +#undef strrchr + +#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 void assemble_constructor PROTO((char *)); +extern void assemble_name PROTO((FILE *, char *)); +extern void error PROTO((char *, ...)); +extern tree tasking_list; +extern void tasking_registry PROTO((void)); +extern void tasking_setup PROTO((void)); +extern void build_enum_tables PROTO((void)); +extern tree process_type; +extern void warning PROTO((char *, ...)); +extern tree get_file_function_name PROTO((int)); +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, "%d", 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; + char *op; + char wrk[256]; + 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 ((enum chill_tree_code)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) + { + extern char* strchr (); + 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 () +{ +#undef strrchr + extern char *strrchr (); + 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, decl; +{ +#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; + } + + /* 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; + } +} + + |