aboutsummaryrefslogtreecommitdiff
path: root/gcc/ch/grant.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ch/grant.c')
-rw-r--r--gcc/ch/grant.c3060
1 files changed, 0 insertions, 3060 deletions
diff --git a/gcc/ch/grant.c b/gcc/ch/grant.c
deleted file mode 100644
index f143aec4708..00000000000
--- a/gcc/ch/grant.c
+++ /dev/null
@@ -1,3060 +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"
-#include "target.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 && targetm.have_ctors_dtors)
- (* targetm.asm_out.constructor)
- (XEXP (DECL_RTL (chill_init_function), 0), DEFAULT_INIT_PRIORITY);
-
- /* ready now to link decls onto this list in pass 2. */
- module_init_list = NULL_TREE;
- tasking_list = NULL_TREE;
- }
-}
-
-
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-08 15:58:47 +0000