diff options
Diffstat (limited to 'gcc/ch/grant.c')
-rw-r--r-- | gcc/ch/grant.c | 3061 |
1 files changed, 0 insertions, 3061 deletions
diff --git a/gcc/ch/grant.c b/gcc/ch/grant.c deleted file mode 100644 index 29e7ddc1bb5..00000000000 --- a/gcc/ch/grant.c +++ /dev/null @@ -1,3061 +0,0 @@ -/* Implement grant-file output & seize-file input for CHILL. - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001 - 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 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 PARAMS ((tree)); -static MYSTRING *decode_constant PARAMS ((tree)); -static void grant_one_decl PARAMS ((tree)); -static MYSTRING *get_type PARAMS ((tree)); -static MYSTRING *decode_mode PARAMS ((tree)); -static MYSTRING *decode_prefix_rename PARAMS ((tree)); -static MYSTRING *decode_constant_selective PARAMS ((tree, tree)); -static MYSTRING *decode_mode_selective PARAMS ((tree, tree)); -static MYSTRING *get_type_selective PARAMS ((tree, tree)); -static MYSTRING *decode_decl_selective PARAMS ((tree, tree)); -static MYSTRING *newstring PARAMS ((const char *)); -static void strfree PARAMS ((MYSTRING *)); -static MYSTRING *append PARAMS ((MYSTRING *, const char *)); -static MYSTRING *prepend PARAMS ((MYSTRING *, const char *)); -static void grant_use_seizefile PARAMS ((const char *)); -static MYSTRING *decode_layout PARAMS ((tree)); -static MYSTRING *grant_array_type PARAMS ((tree)); -static MYSTRING *grant_array_type_selective PARAMS ((tree, tree)); -static MYSTRING *get_tag_value PARAMS ((tree)); -static MYSTRING *get_tag_value_selective PARAMS ((tree, tree)); -static MYSTRING *print_enumeral PARAMS ((tree)); -static MYSTRING *print_enumeral_selective PARAMS ((tree, tree)); -static MYSTRING *print_integer_type PARAMS ((tree)); -static tree find_enum_parent PARAMS ((tree, tree)); -static MYSTRING *print_integer_selective PARAMS ((tree, tree)); -static MYSTRING *print_struct PARAMS ((tree)); -static MYSTRING *print_struct_selective PARAMS ((tree, tree)); -static MYSTRING *print_proc_exceptions PARAMS ((tree)); -static MYSTRING *print_proc_tail PARAMS ((tree, tree, int)); -static MYSTRING *print_proc_tail_selective PARAMS ((tree, tree, tree)); -static tree find_in_decls PARAMS ((tree, tree)); -static int in_ridpointers PARAMS ((tree)); -static void grant_seized_identifier PARAMS ((tree)); -static void globalize_decl PARAMS ((tree)); -static void grant_one_decl_selective PARAMS ((tree, tree)); -static int compare_memory_file PARAMS ((const char *, const char *)); -static int search_in_list PARAMS ((tree, tree)); -static int really_grant_this PARAMS ((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) - const 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; - const 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; - const char *in; -{ - MYSTRING *res = inout; - if (strlen (in)) - { - res = newstring (in); - res = APPEND (res, inout->str); - FREE (inout); - } - return res; -} - -static void -grant_use_seizefile (seize_filename) - const 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; - const 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; - const 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: - { - const 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)) - { - const 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) - const char *fname; - const 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) - fatal_io_error ("can't open %s", 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; - fatal_io_error ("can't write to %s", grant_file_name); - } -#endif - fclose (fb); -} - - -/* handle grant statement */ - -void -set_default_grant_file () -{ - char *p, *tmp; - const char *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; -#define 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) - + sizeof (HEADER_TEMPLATE) /* includes \0 */); - 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) - { - /* If we don't do this spoof, we get the name of the first - tasking_code variable, and not the file name. */ - char *q; - const 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. */ - q = strrchr (IDENTIFIER_POINTER (chill_init_name), '.'); - if (q) - *q = '\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; - } -} - - |