Migrate from devo/gcc/ch.
From-SVN: r22038
--- /dev/null
+This directory contains the GNU front-end for the Chill language,
+contributed by Cygnus Solutions.
+
+Chill is the "CCITT High-Level Language", where CCITT is the old
+name for what is now ITU, the International Telecommunications Union.
+It is is language in the Modula2 family, and targets many of the
+same applications as Ada (especially large embedded systems).
+Chill was never used much in the United States, but is still
+being used in Europe, Brazil, Korea, and other places.
+
+Chill has been standardized by a series of reports/standards.
+The GNU implementation mostly follows the 1988 version of
+the language, with some backwards compatibility options for
+the 1984 version, and some other extensions. However, it
+does not implement all of the features of any standard.
+The most recent standard is ?, available from ?.
+
+The GNU Chill implementation is not being actively developed.
+Cygnus has one customer we are maintaining Chill for,
+but we are not planning on putting major work into Chill.
+This Net release is for educational purposes (as an example
+of a different Gcc front-end), and for those who find it useful.
+It is an unsupported hacker release. Bug reports without
+patches are likely to get ignored. Questions may get answered or
+ignored depending on our mood! If you want to try your luck,
+you can send a note to David Brolley <brolley@cygnus.com> or
+Per Bothner <bothner@cygnus.com>.
+
+One known problem is that we only support native builds of GNU Chill.
+If you need a cross-compiler, you will find various problems,
+including the directory structure, and the setjmp-based exception
+handling mechanism.
+
+The Chill run-time system is in the runtime sub-directory.
+Notice rts.c contains a poor main's implementation of Chill
+"processes" (threads). It is not added to libchill.a.
+We only use it for testing. (Our customer uses a different
+implementation for product work.)
+
+The GNU Chill implementation was primarily written by
+Per Bothner, along with Bill Cox, Wilfried Moser, Michael
+Tiemann, and David Brolley.
--- /dev/null
+/* Implement actions for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+ Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+#include <limits.h>
+#include "config.h"
+#include "tree.h"
+#include "rtl.h"
+#include "expr.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include "flags.h"
+#include "actions.h"
+#include "obstack.h"
+#include "assert.h"
+
+#define obstack_chunk_alloc xmalloc
+#define obstack_chunk_free free
+
+/* reserved tag definitions */
+
+#define TYPE_ID "id"
+#define TAG_OBJECT "chill_object"
+#define TAG_CLASS "chill_class"
+
+extern int flag_short_enums;
+extern int current_nesting_level;
+
+extern tree build_chill_compound_expr PROTO((tree));
+extern tree build_chill_exception_decl PROTO((char *));
+extern tree convert PROTO((tree, tree));
+extern rtx emit_line_note_force PROTO((char *, int));
+extern void error PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern rtx gen_nop PROTO((void));
+extern tree get_identifier PROTO((char *));
+extern void pedwarn PROTO((char *, ...));
+extern void sorry PROTO((char *, ...));
+extern void warning PROTO((char *, ...));
+
+extern struct obstack *expression_obstack, permanent_obstack;
+extern struct obstack *current_obstack, *saveable_obstack;
+
+/* This flag is checked throughout the non-CHILL-specific
+ in the front end. */
+tree chill_integer_type_node;
+tree chill_unsigned_type_node;
+
+/* Never used. Referenced from c-typeck.c, which we use. */
+int current_function_returns_value = 0;
+int current_function_returns_null = 0;
+
+/* data imported from toplev.c */
+
+extern char *dump_base_name;
+
+/* set from command line parameter, to exit after
+ grant file written, generating no code. */
+int grant_only_flag = 0;
+\f
+char *
+lang_identify ()
+{
+ return "chill";
+}
+
+
+void
+init_chill ()
+{
+}
+
+void
+print_lang_statistics ()
+{
+}
+
+
+void
+lang_finish ()
+{
+#if 0
+ extern int errorcount, sorrycount;
+
+ /* this should be the last action in compiling a module.
+ If there are other actions to be performed at lang_finish
+ please insert before this */
+
+ /* FIXME: in case of a syntax error, this leaves the grant file incomplete */
+ /* for the moment we print a warning in case of errors and
+ continue granting */
+ if ((errorcount || sorrycount) && grant_count)
+ {
+ warning ("%d errors, %d sorries, do granting", errorcount, sorrycount);
+ errorcount = sorrycount = 0;
+ }
+#endif
+}
+
+void
+chill_check_decl (decl)
+ tree decl;
+{
+ tree type = TREE_TYPE (decl);
+ static int alreadyWarned = 0;
+
+ if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */
+ {
+ if (!alreadyWarned)
+ {
+ error ("GNU compiler does not support statically allocated objects");
+ alreadyWarned = 1;
+ }
+ error_with_decl (decl, "`%s' cannot be statically allocated");
+ }
+}
+\f
+/* Comparison function for sorting identifiers in RAISES lists.
+ Note that because IDENTIFIER_NODEs are unique, we can sort
+ them by address, saving an indirection. */
+static int
+id_cmp (p1, p2)
+ tree *p1, *p2;
+{
+ return (int)TREE_VALUE (*p1) - (int)TREE_VALUE (*p2);
+}
+
+/* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions
+ listed in RAISES. */
+tree
+build_exception_variant (type, raises)
+ tree type, raises;
+{
+ int i;
+ tree v = TYPE_MAIN_VARIANT (type);
+ tree t, t2;
+ int constp = TYPE_READONLY (type);
+ int volatilep = TYPE_VOLATILE (type);
+
+ if (!raises)
+ return build_type_variant (v, constp, volatilep);
+
+ if (TREE_CHAIN (raises))
+ { /* Sort the list */
+ tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree));
+ for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++)
+ a[i] = t;
+ /* NULL terminator for list. */
+ a[i] = NULL_TREE;
+ qsort (a, i, sizeof (tree), id_cmp);
+ while (i--)
+ TREE_CHAIN (a[i]) = a[i+1];
+ raises = a[0];
+ }
+
+ for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v))
+ {
+ if (TYPE_READONLY (v) != constp
+ || TYPE_VOLATILE (v) != volatilep)
+ continue;
+
+ t = raises;
+ t2 = TYPE_RAISES_EXCEPTIONS (v);
+ while (t && t2)
+ {
+ if (TREE_TYPE (t) == TREE_TYPE (t2))
+ {
+ t = TREE_CHAIN (t);
+ t2 = TREE_CHAIN (t2);
+ }
+ else break;
+ }
+ if (t || t2)
+ continue;
+ /* List of exceptions raised matches previously found list.
+
+ @@ Nice to free up storage used in consing up the
+ @@ list of exceptions raised. */
+ return v;
+ }
+
+ /* Need to build a new variant. */
+ if (TREE_PERMANENT (type))
+ {
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+ v = copy_node (type);
+ pop_obstacks ();
+ }
+ else
+ v = copy_node (type);
+
+ TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type);
+ TYPE_NEXT_VARIANT (type) = v;
+ if (raises && ! TREE_PERMANENT (raises))
+ {
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+ raises = copy_list (raises);
+ pop_obstacks ();
+ }
+ TYPE_RAISES_EXCEPTIONS (v) = raises;
+ return v;
+}
+#if 0
+\f
+tree
+build_rts_call (name, type, args)
+ char *name;
+ tree type, args;
+{
+ tree decl = lookup_name (get_identifier (name));
+ tree converted_args = NULL_TREE;
+ tree result, length = NULL_TREE;
+
+ assert (decl != NULL_TREE);
+ while (args)
+ {
+ tree arg = TREE_VALUE (args);
+ if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE
+ || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE)
+ {
+ length = size_in_bytes (TREE_TYPE (arg));
+ arg = build_chill_addr_expr (arg, (char *)0);
+ }
+ converted_args = tree_cons (NULL_TREE, arg, converted_args);
+ args = TREE_CHAIN (args);
+ }
+ if (length != NULL_TREE)
+ converted_args = tree_cons (NULL_TREE, length, converted_args);
+ converted_args = nreverse (converted_args);
+ result = build_chill_function_call (decl, converted_args);
+ if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE)
+ result = build1 (INDIRECT_REF, type, result);
+ else
+ result = convert (type, result);
+ return result;
+}
+#endif
+
+/*
+ * queue name of unhandled exception
+ * to avoid multiple unhandled warnings
+ * in one compilation module
+ */
+
+struct already_type
+{
+ struct already_type *next;
+ char *name;
+};
+
+static struct already_type *already_warned = 0;
+
+static void
+warn_unhandled (ex)
+ char *ex;
+{
+ struct already_type *p = already_warned;
+
+ while (p)
+ {
+ if (!strcmp (p->name, ex))
+ return;
+ p = p->next;
+ }
+
+ /* not yet warned */
+ p = (struct already_type *)xmalloc (sizeof (struct already_type));
+ p->next = already_warned;
+ p->name = (char *)xmalloc (strlen (ex) + 1);
+ strcpy (p->name, ex);
+ already_warned = p;
+ pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex);
+}
+
+/*
+ * build a call to the following function:
+ * void __cause_ex1 (char* ex, const char *file,
+ * const unsigned lineno);
+ * if the exception is handled or
+ * void __unhandled_ex (char *ex, char *file, unsigned lineno)
+ * if the exception is not handled.
+ */
+tree
+build_cause_exception (exp_name, warn_if_unhandled)
+ tree exp_name;
+ int warn_if_unhandled;
+{
+ /* We don't use build_rts_call() here, because the string (array of char)
+ would be followed by its length in the parameter list built by
+ build_rts_call, and the runtime routine doesn't want a length parameter.*/
+ tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name));
+ tree function, fname, lineno, result;
+ int handled = is_handled (exp_name);
+
+ switch (handled)
+ {
+ case 0:
+ /* no handler */
+ if (warn_if_unhandled)
+ warn_unhandled (IDENTIFIER_POINTER (exp_name));
+ function = lookup_name (get_identifier ("__unhandled_ex"));
+ fname = force_addr_of (get_chill_filename ());
+ lineno = get_chill_linenumber ();
+ break;
+ case 1:
+ /* local handler */
+ function = lookup_name (get_identifier ("__cause_ex1"));
+ fname = force_addr_of (get_chill_filename ());
+ lineno = get_chill_linenumber ();
+ break;
+ case 2:
+ /* function may propagate this exception */
+ function = lookup_name (get_identifier ("__cause_ex1"));
+ fname = lookup_name (get_identifier (CALLER_FILE));
+ if (fname == NULL_TREE)
+ fname = error_mark_node;
+ lineno = lookup_name (get_identifier (CALLER_LINE));
+ if (lineno == NULL_TREE)
+ lineno = error_mark_node;
+ break;
+ }
+ result =
+ build_chill_function_call (function,
+ tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0),
+ tree_cons (NULL_TREE, fname,
+ tree_cons (NULL_TREE, lineno, NULL_TREE))));
+ return result;
+}
+
+void
+expand_cause_exception (exp_name)
+ tree exp_name;
+{
+ expand_expr_stmt (build_cause_exception (exp_name, 1));
+}
+
+/* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE);
+ otherwise return EXPR. */
+
+tree
+check_expression (expr, condition, exception)
+ tree expr, condition, exception;
+{
+ if (integer_zerop (condition))
+ return expr;
+ else
+ return build (COMPOUND_EXPR, TREE_TYPE (expr),
+ fold (build (TRUTH_ANDIF_EXPR, boolean_type_node,
+ condition, build_cause_exception (exception, 0))),
+ expr);
+}
+
+/* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT,
+ somewhat optimized and with some warnings suppressed.
+ If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes. */
+
+tree
+test_range (value, lo_limit, hi_limit)
+ tree value, lo_limit, hi_limit;
+{
+ if (lo_limit || hi_limit)
+ {
+ int old_inhibit_warnings = inhibit_warnings;
+ tree lo_check, hi_check, check;
+
+ /* This is a hack so that `shorten_compare' doesn't warn the
+ user about useless range checks that are too much work to
+ optimize away here. */
+ inhibit_warnings = 1;
+
+ lo_check = lo_limit ?
+ fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) :
+ boolean_false_node; /* fake passing the check */
+
+ hi_check = hi_limit ?
+ fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) :
+ boolean_false_node; /* fake passing the check */
+
+ if (lo_check == boolean_false_node)
+ check = hi_check;
+ else if (hi_check == boolean_false_node)
+ check = lo_check;
+ else
+ check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
+ lo_check, hi_check));
+
+ inhibit_warnings = old_inhibit_warnings;
+ return check;
+ }
+ else
+ return boolean_false_node;
+}
+
+/* Return EXPR, except if range_checking is on, return an expression
+ that also checks that value >= low_limit && value <= hi_limit.
+ If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes. */
+
+tree
+check_range (expr, value, lo_limit, hi_limit)
+ tree expr, value, lo_limit, hi_limit;
+{
+ tree check = test_range (value, lo_limit, hi_limit);
+ if (!integer_zerop (check))
+ {
+ if (current_function_decl == NULL_TREE)
+ {
+ if (TREE_CODE (check) == INTEGER_CST)
+ error ("range failure (not inside function)");
+ else
+ warning ("possible range failure (not inside function)");
+ }
+ else
+ {
+ if (TREE_CODE (check) == INTEGER_CST)
+ warning ("expression will always cause RANGEFAIL");
+ if (range_checking)
+ expr = check_expression (expr, check,
+ ridpointers[(int) RID_RANGEFAIL]);
+ }
+ }
+ return expr;
+}
+
+/* Same as EXPR, except raise EMPTY if EXPR is NULL. */
+
+tree
+check_non_null (expr)
+ tree expr;
+{
+ if (empty_checking)
+ {
+ expr = save_if_needed (expr);
+ return check_expression (expr,
+ build_compare_expr (EQ_EXPR,
+ expr, null_pointer_node),
+ ridpointers[(int) RID_EMPTY]);
+ }
+ return expr;
+}
+\f
+/*
+ * There are four conditions to generate a runtime check:
+ * 1) assigning a longer INT to a shorter (signs irrelevant)
+ * 2) assigning a signed to an unsigned
+ * 3) assigning an unsigned to a signed of the same size.
+ * 4) TYPE is a discrete subrange
+ */
+tree
+chill_convert_for_assignment (type, expr, place)
+ tree type, expr;
+ char *place; /* location description for error messages */
+{
+ tree ttype = type;
+ tree etype = TREE_TYPE (expr);
+ tree result;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return expr;
+ if (TREE_CODE (expr) == TYPE_DECL)
+ {
+ error ("right hand side of assignment is a mode");
+ return error_mark_node;
+ }
+
+ if (! CH_COMPATIBLE (expr, type))
+ {
+ error ("incompatible modes in %s", place);
+ return error_mark_node;
+ }
+
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ ttype = TREE_TYPE (ttype);
+ if (etype && TREE_CODE (etype) == REFERENCE_TYPE)
+ etype = TREE_TYPE (etype);
+
+ if (etype
+ && (CH_STRING_TYPE_P (ttype)
+ || (chill_varying_type_p (ttype)
+ && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype))))
+ && (CH_STRING_TYPE_P (etype)
+ || (chill_varying_type_p (etype)
+ && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype)))))
+ {
+ tree cond;
+ if (range_checking)
+ expr = save_if_needed (expr);
+ cond = string_assignment_condition (ttype, expr);
+ if (TREE_CODE (cond) == INTEGER_CST)
+ {
+ if (integer_zerop (cond))
+ {
+ error ("bad string length in %s", place);
+ return error_mark_node;
+ }
+ /* Otherwise, the condition is always true, so no runtime test. */
+ }
+ else if (range_checking)
+ expr = check_expression (expr,
+ invert_truthvalue (cond),
+ ridpointers[(int) RID_RANGEFAIL]);
+ }
+
+ if (range_checking
+ && discrete_type_p (ttype)
+ && etype != NULL_TREE
+ && discrete_type_p (etype))
+ {
+ int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype),
+ TYPE_SIZE (etype));
+ int cond2 = TREE_UNSIGNED (ttype)
+ && (! TREE_UNSIGNED (etype));
+ int cond3 = (! TREE_UNSIGNED (type))
+ && TREE_UNSIGNED (etype)
+ && tree_int_cst_equal (TYPE_SIZE (ttype),
+ TYPE_SIZE (etype));
+ int cond4 = TREE_TYPE (ttype)
+ && discrete_type_p (TREE_TYPE (ttype));
+
+ if (cond1 || cond2 || cond3 || cond4)
+ {
+ tree type_min = TYPE_MIN_VALUE (ttype);
+ tree type_max = TYPE_MAX_VALUE (ttype);
+
+ expr = save_if_needed (expr);
+ if (expr && type_min && type_max)
+ expr = check_range (expr, expr, type_min, type_max);
+ }
+ }
+ result = convert (type, expr);
+
+ /* If the type is a array of PACK bits and the expression is an array constructor,
+ then build a CONSTRUCTOR for a bitstring. Bitstrings are zero based, so
+ decrement the value of each CONSTRUCTOR element by the amount of the lower
+ bound of the array. */
+ if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type)
+ && TREE_CODE (result) == CONSTRUCTOR)
+ {
+ tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+ tree new_list = NULL_TREE;
+ long index;
+ tree element;
+ for (element = TREE_OPERAND (result, 1);
+ element != NULL_TREE;
+ element = TREE_CHAIN (element))
+ {
+ if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node))
+ {
+ tree purpose = TREE_PURPOSE (element);
+ switch (TREE_CODE (purpose))
+ {
+ case INTEGER_CST:
+ new_list = tree_cons (NULL_TREE,
+ size_binop (MINUS_EXPR, purpose, domain_min),
+ new_list);
+ break;
+ case RANGE_EXPR:
+ for (index = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0));
+ index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1));
+ index++)
+ new_list = tree_cons (NULL_TREE,
+ size_binop (MINUS_EXPR,
+ build_int_2 (index, 0),
+ domain_min),
+ new_list);
+ break;
+ default:
+ abort ();
+ }
+ }
+ }
+ TREE_OPERAND (result, 1) = nreverse (new_list);
+ TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type));
+ }
+
+ return result;
+}
+\f
+/* Check that EXPR has valid type for a RETURN or RESULT expression,
+ converting to the right type. ACTION is "RESULT" or "RETURN". */
+
+static tree
+adjust_return_value (expr, action)
+ tree expr;
+ char *action;
+{
+ tree type = TREE_TYPE (TREE_TYPE (current_function_decl));
+
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ {
+ if (CH_LOCATION_P (expr))
+ {
+ if (! CH_READ_COMPATIBLE (TREE_TYPE (type),
+ TREE_TYPE (expr)))
+ {
+ error ("mode mismatch in %s expression", action);
+ return error_mark_node;
+ }
+ return convert (type, expr);
+ }
+ else
+ {
+ error ("%s expression must be referable", action);
+ return error_mark_node;
+ }
+ }
+ else if (! CH_COMPATIBLE (expr, type))
+ {
+ error ("mode mismatch in %s expression", action);
+ return error_mark_node;
+ }
+ return convert (type, expr);
+}
+\f
+void
+chill_expand_result (expr, result_or_return)
+ tree expr;
+ int result_or_return;
+{
+ tree type;
+ char *action_name = result_or_return ? "RESULT" : "RETURN";
+
+ if (pass == 1)
+ return;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return;
+
+ CH_FUNCTION_SETS_RESULT (current_function_decl) = 1;
+
+ if (chill_at_module_level || global_bindings_p ())
+ error ("%s not allowed outside a PROC", action_name);
+
+ result_never_set = 0;
+
+ if (chill_result_decl == NULL_TREE)
+ {
+ error ("%s action in PROC with no declared RESULTS", action_name);
+ return;
+ }
+ type = TREE_TYPE (chill_result_decl);
+
+ if (TREE_CODE (type) == ERROR_MARK)
+ return;
+
+ expr = adjust_return_value (expr, action_name);
+
+ expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr));
+}
+\f
+/*
+ * error if EXPR not NULL and procedure doesn't
+ * have a return type;
+ * warning if EXPR NULL,
+ * procedure *has* a return type, and a previous
+ * RESULT actions hasn't saved a return value.
+ */
+void
+chill_expand_return (expr, implicit)
+ tree expr;
+ int implicit; /* 1 if an implicit return at end of function. */
+{
+ tree valtype;
+
+ if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
+ return;
+ if (chill_at_module_level || global_bindings_p ())
+ {
+ error ("RETURN not allowed outside PROC");
+ return;
+ }
+
+ if (pass == 1)
+ return;
+
+ result_never_set = 0;
+
+ valtype = TREE_TYPE (TREE_TYPE (current_function_decl));
+ if (TREE_CODE (valtype) == VOID_TYPE)
+ {
+ if (expr != NULL_TREE)
+ error ("RETURN with a value, in PROC returning void");
+ expand_null_return ();
+ }
+ else if (TREE_CODE (valtype) != ERROR_MARK)
+ {
+ if (expr == NULL_TREE)
+ {
+ if (!CH_FUNCTION_SETS_RESULT (current_function_decl)
+ && !implicit)
+ warning ("RETURN with no value and no RESULT action in procedure");
+ expr = chill_result_decl;
+ }
+ else
+ expr = adjust_return_value (expr, "RETURN");
+ expr = build (MODIFY_EXPR, valtype,
+ DECL_RESULT (current_function_decl),
+ expr);
+ TREE_SIDE_EFFECTS (expr) = 1;
+ expand_return (expr);
+ }
+}
+
+void
+lookup_and_expand_goto (name)
+ tree name;
+{
+ if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
+ return;
+ if (!ignoring)
+ {
+ tree decl = lookup_name (name);
+ if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
+ error ("no label named `%s'", IDENTIFIER_POINTER (name));
+ else if (DECL_CONTEXT (decl) != current_function_decl)
+ error ("cannot GOTO label `%s' outside current function",
+ IDENTIFIER_POINTER (name));
+ else
+ {
+ TREE_USED (decl) = 1;
+ expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
+ expand_goto (decl);
+ }
+ }
+}
+
+void
+lookup_and_handle_exit (name)
+ tree name;
+{
+ if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
+ return;
+ if (!ignoring)
+ {
+ tree label = munge_exit_label (name);
+ tree decl = lookup_name (label);
+ if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
+ error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name));
+ else if (DECL_CONTEXT (decl) != current_function_decl)
+ error ("cannot EXIT label `%s' outside current function",
+ IDENTIFIER_POINTER (name));
+ else
+ {
+ TREE_USED (decl) = 1;
+ expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
+ expand_goto (decl);
+ }
+ }
+}
+\f
+/* ELSE-range handling: The else-range is a chain of trees which collectively
+ represent the ranges to be tested for the (ELSE) case label. Each element in
+ the chain represents a range to be tested. The boundaries of the range are
+ represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */
+
+/* This function updates the else-range by removing the given integer constant. */
+static tree
+update_else_range_for_int_const (else_range, label)
+ tree else_range, label;
+{
+ int lowval, highval;
+ int label_value = TREE_INT_CST_LOW (label);
+ tree this_range, prev_range, new_range;
+
+ /* First, find the range element containing the integer, if it exists. */
+ prev_range = NULL_TREE;
+ for (this_range = else_range ;
+ this_range != NULL_TREE;
+ this_range = TREE_CHAIN (this_range))
+ {
+ lowval = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
+ highval = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+ if (label_value >= lowval && label_value <= highval)
+ break;
+ prev_range = this_range;
+ }
+
+ /* If a range element containing the integer was found, then update the range. */
+ if (this_range != NULL_TREE)
+ {
+ tree next = TREE_CHAIN (this_range);
+ if (label_value == lowval)
+ {
+ /* The integer is the lower bound of the range element. If it is also the
+ upper bound, then remove this range element, otherwise update it. */
+ if (label_value == highval)
+ {
+ if (prev_range == NULL_TREE)
+ else_range = next;
+ else
+ TREE_CHAIN (prev_range) = next;
+ }
+ else
+ TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0);
+ }
+ else if (label_value == highval)
+ {
+ /* The integer is the upper bound of the range element, so ajust it. */
+ TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
+ }
+ else
+ {
+ /* The integer is in the middle of the range element, so split it. */
+ new_range = tree_cons (
+ build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next);
+ TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
+ TREE_CHAIN (this_range) = new_range;
+ }
+ }
+ return else_range;
+}
+
+/* Update the else-range to remove a range of values/ */
+static tree
+update_else_range_for_range (else_range, low_target, high_target)
+ tree else_range, low_target, high_target;
+{
+ tree this_range, prev_range, new_range, next_range;
+ int low_range_val, high_range_val;
+ int low_target_val = TREE_INT_CST_LOW (low_target);
+ int high_target_val = TREE_INT_CST_LOW (high_target);
+
+ /* find the first else-range element which overlaps the target range. */
+ prev_range = NULL_TREE;
+ for (this_range = else_range ;
+ this_range != NULL_TREE;
+ this_range = TREE_CHAIN (this_range))
+ {
+ low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
+ high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+ if (low_target_val >= low_range_val && low_target_val <= high_range_val
+ || high_target_val >= low_range_val && high_target_val <= high_range_val)
+ break;
+ prev_range = this_range;
+ }
+ if (this_range == NULL_TREE)
+ return else_range;
+
+ /* This first else-range element might be truncated at the top or completely
+ contain the target range. */
+ if (low_range_val < low_target_val)
+ {
+ next_range = TREE_CHAIN (this_range);
+ if (high_range_val > high_target_val)
+ {
+ new_range = tree_cons (
+ build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range);
+ TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
+ TREE_CHAIN (this_range) = new_range;
+ return else_range;
+ }
+
+ TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
+ if (next_range == NULL_TREE)
+ return else_range;
+
+ prev_range = this_range;
+ this_range = next_range;
+ high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+ }
+
+ /* There may then follow zero or more else-range elements which are completely
+ contained in the target range. */
+ while (high_range_val <= high_target_val)
+ {
+ this_range = TREE_CHAIN (this_range);
+ if (prev_range == NULL_TREE)
+ else_range = this_range;
+ else
+ TREE_CHAIN (prev_range) = this_range;
+
+ if (this_range == NULL_TREE)
+ return else_range;
+ high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+ }
+
+ /* Finally, there may be a else-range element which is truncated at the bottom. */
+ low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
+ if (low_range_val <= high_target_val)
+ TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0);
+
+ return else_range;
+}
+
+static tree
+update_else_range_for_range_expr (else_range, label)
+ tree else_range, label;
+{
+ if (TREE_OPERAND (label, 0) == NULL_TREE)
+ {
+ if (TREE_OPERAND (label, 1) == NULL_TREE)
+ else_range = NULL_TREE; /* (*) -- matches everything */
+ }
+ else
+ else_range = update_else_range_for_range (
+ else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1));
+
+ return else_range;
+}
+
+static tree
+update_else_range_for_type (else_range, label)
+ tree else_range, label;
+{
+ tree type = TREE_TYPE (label);
+ else_range = update_else_range_for_range (
+ else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
+ return else_range;
+}
+
+static tree
+compute_else_range (selector, alternatives, selector_no)
+ tree selector, alternatives;
+ int selector_no;
+{
+ /* Start with an else-range that spans the entire range of the selector type. */
+ tree type = TREE_TYPE (TREE_VALUE (selector));
+ tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE);
+
+ /* Now remove the values represented by each case lebel specified for that
+ selector. The remaining range is the else-range. */
+ for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
+ {
+ tree label;
+ tree label_list = TREE_PURPOSE (alternatives);
+ int this_selector;
+ for (this_selector = 0; this_selector < selector_no ; ++this_selector)
+ label_list = TREE_CHAIN (label_list);
+
+ for (label = TREE_VALUE (label_list);
+ label != NULL_TREE;
+ label = TREE_CHAIN (label))
+ {
+ tree label_value = TREE_VALUE (label);
+ if (TREE_CODE (label_value) == INTEGER_CST)
+ range = update_else_range_for_int_const (range, label_value);
+ else if (TREE_CODE (label_value) == RANGE_EXPR)
+ range = update_else_range_for_range_expr (range, label_value);
+ else if (TREE_CODE (label_value) == TYPE_DECL)
+ range = update_else_range_for_type (range, label_value);
+
+ if (range == NULL_TREE)
+ break;
+ }
+ }
+
+ return range;
+}
+
+void
+compute_else_ranges (selectors, alternatives)
+ tree selectors, alternatives;
+{
+ tree selector;
+ int selector_no = 0;
+
+ for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector))
+ {
+ if (ELSE_LABEL_SPECIFIED (selector))
+ TREE_PURPOSE (selector) =
+ compute_else_range (selector, alternatives, selector_no);
+ selector_no++;
+ }
+}
+
+static tree
+check_case_value (label_value, selector)
+ tree label_value, selector;
+{
+ if (TREE_CODE (label_value) == ERROR_MARK)
+ return label_value;
+ if (TREE_CODE (selector) == ERROR_MARK)
+ return selector;
+
+ /* Z.200 (6.4 Case action) says: "The class of any discrete expression
+ in the case selector list must be compatible with the corresponding
+ (by position) class of the resulting list of classes of the case label
+ list occurrences ...". We don't actually construct the resulting
+ list of classes, but this test should be more-or-less equivalent.
+ I think... */
+ if (!CH_COMPATIBLE_CLASSES (selector, label_value))
+ {
+ error ("case selector not compatible with label");
+ return error_mark_node;
+ }
+
+ /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */
+ STRIP_TYPE_NOPS (label_value);
+
+ if (TREE_CODE (label_value) != INTEGER_CST)
+ {
+ error ("case label does not reduce to an integer constant");
+ return error_mark_node;
+ }
+
+ constant_expression_warning (label_value);
+ return label_value;
+}
+
+void
+chill_handle_case_default ()
+{
+ tree duplicate;
+ register tree label = build_decl (LABEL_DECL, NULL_TREE,
+ NULL_TREE);
+ int success = pushcase (NULL_TREE, 0, label, &duplicate);
+
+ if (success == 1)
+ error ("ELSE label not within a CASE statement");
+#if 0
+ else if (success == 2)
+ {
+ error ("multiple default labels found in a CASE statement");
+ error_with_decl (duplicate, "this is the first ELSE label");
+ }
+#endif
+}
+\f
+/* Handle cases label such as (I:J): or (modename): */
+
+static void
+chill_handle_case_label_range (min_value, max_value, selector)
+ tree min_value, max_value, selector;
+{
+ register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+ min_value = check_case_value (min_value, selector);
+ max_value = check_case_value (max_value, selector);
+ if (TREE_CODE (min_value) != ERROR_MARK
+ && TREE_CODE (max_value) != ERROR_MARK)
+ {
+ tree duplicate;
+ int success = pushcase_range (min_value, max_value,
+ convert, label, &duplicate);
+ if (success == 1)
+ error ("label found outside of CASE statement");
+ else if (success == 2)
+ {
+ error ("duplicate CASE value");
+ error_with_decl (duplicate, "this is the first entry for that value");
+ }
+ else if (success == 3)
+ error ("CASE value out of range");
+ else if (success == 4)
+ error ("empty range");
+ else if (success == 5)
+ error ("label within scope of cleanup or variable array");
+ }
+}
+
+void
+chill_handle_case_label (label_value, selector)
+ tree label_value, selector;
+{
+ if (label_value == NULL_TREE
+ || TREE_CODE (label_value) == ERROR_MARK)
+ return;
+ if (TREE_CODE (label_value) == RANGE_EXPR)
+ {
+ if (TREE_OPERAND (label_value, 0) == NULL_TREE)
+ chill_handle_case_default (); /* i.e. (ELSE): or (*): */
+ else
+ chill_handle_case_label_range (TREE_OPERAND (label_value, 0),
+ TREE_OPERAND (label_value, 1),
+ selector);
+ }
+ else if (TREE_CODE (label_value) == TYPE_DECL)
+ {
+ tree type = TREE_TYPE (label_value);
+ if (! discrete_type_p (type))
+ error ("mode in label is not discrete");
+ else
+ chill_handle_case_label_range (TYPE_MIN_VALUE (type),
+ TYPE_MAX_VALUE (type),
+ selector);
+ }
+ else
+ {
+ register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+
+ label_value = check_case_value (label_value, selector);
+
+ if (TREE_CODE (label_value) != ERROR_MARK)
+ {
+ tree duplicate;
+ int success = pushcase (label_value, convert, label, &duplicate);
+ if (success == 1)
+ error ("label not within a CASE statement");
+ else if (success == 2)
+ {
+ error ("duplicate case value");
+ error_with_decl (duplicate,
+ "this is the first entry for that value");
+ }
+ else if (success == 3)
+ error ("CASE value out of range");
+ else if (success == 4)
+ error ("empty range");
+ else if (success == 5)
+ error ("label within scope of cleanup or variable array");
+ }
+ }
+}
+
+int
+chill_handle_single_dimension_case_label (
+ selector, label_spec, expand_exit_needed, caseaction_flag
+)
+ tree selector, label_spec;
+ int *expand_exit_needed, *caseaction_flag;
+{
+ tree labels, one_label;
+ int no_completeness_check = 0;
+
+ if (*expand_exit_needed || *caseaction_flag == 1)
+ {
+ expand_exit_something ();
+ *expand_exit_needed = 0;
+ }
+
+ for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels))
+ for (one_label = TREE_VALUE (labels); one_label != NULL_TREE;
+ one_label = TREE_CHAIN (one_label))
+ {
+ if (TREE_VALUE (one_label) == case_else_node)
+ no_completeness_check = 1;
+
+ chill_handle_case_label (TREE_VALUE (one_label), selector);
+ }
+
+ *caseaction_flag = 1;
+
+ return no_completeness_check;
+}
+
+static tree
+chill_handle_multi_case_label_range (low, high, selector)
+ tree low, high, selector;
+{
+ tree low_expr, high_expr, and_expr;
+ tree selector_type;
+ int low_target_val, high_target_val;
+ int low_type_val, high_type_val;
+
+ /* we can eliminate some tests is the low and/or high value in the given range
+ are outside the range of the selector type. */
+ low_target_val = TREE_INT_CST_LOW (low);
+ high_target_val = TREE_INT_CST_LOW (high);
+ selector_type = TREE_TYPE (selector);
+ low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
+ high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
+
+ if (low_target_val > high_type_val || high_target_val < low_type_val)
+ return boolean_false_node; /* selector never in range */
+
+ if (low_type_val >= low_target_val)
+ {
+ if (high_type_val <= high_target_val)
+ return boolean_true_node; /* always in the range */
+ return build_compare_expr (LE_EXPR, selector, high);
+ }
+
+ if (high_type_val <= high_target_val)
+ return build_compare_expr (GE_EXPR, selector, low);
+
+ /* The target range in completely within the range of the selector, but we
+ might be able to save a test if the upper bound is the same as the lower
+ bound. */
+ if (low_target_val == high_target_val)
+ return build_compare_expr (EQ_EXPR, selector, low);
+
+ /* No optimizations possible. Just generate tests against the upper and lower
+ bound of the target */
+ low_expr = build_compare_expr (GE_EXPR, selector, low);
+ high_expr = build_compare_expr (LE_EXPR, selector, high);
+ and_expr = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr);
+
+ return and_expr;
+}
+
+static tree
+chill_handle_multi_case_else_label (selector)
+ tree selector;
+{
+ tree else_range, selector_value, selector_type;
+ tree low, high, larg;
+
+ else_range = TREE_PURPOSE (selector);
+ if (else_range == NULL_TREE)
+ return boolean_false_node; /* no values in ELSE range */
+
+ /* Test each of the ranges in the else-range chain */
+ selector_value = TREE_VALUE (selector);
+ selector_type = TREE_TYPE (selector_value);
+ low = convert (selector_type, TREE_PURPOSE (else_range));
+ high = convert (selector_type, TREE_VALUE (else_range));
+ larg = chill_handle_multi_case_label_range (low, high, selector_value);
+
+ for (else_range = TREE_CHAIN (else_range);
+ else_range != NULL_TREE;
+ else_range = TREE_CHAIN (else_range))
+ {
+ tree rarg;
+ low = convert (selector_type, TREE_PURPOSE (else_range));
+ high = convert (selector_type, TREE_VALUE (else_range));
+ rarg = chill_handle_multi_case_label_range (low, high, selector_value);
+ larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
+ }
+
+ return larg;
+}
+
+static tree
+chill_handle_multi_case_label (selector, label)
+ tree selector, label;
+{
+ tree expr;
+
+ if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK)
+ return;
+
+ if (TREE_CODE (label) == INTEGER_CST)
+ {
+ int target_val = TREE_INT_CST_LOW (label);
+ tree selector_type = TREE_TYPE (TREE_VALUE (selector));
+ int low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
+ int high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
+ if (target_val < low_type_val || target_val > high_type_val)
+ expr = boolean_false_node;
+ else
+ expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label);
+ }
+ else if (TREE_CODE (label) == RANGE_EXPR)
+ {
+ if (TREE_OPERAND (label, 0) == NULL_TREE)
+ {
+ if (TREE_OPERAND (label, 1) == NULL_TREE)
+ expr = boolean_true_node; /* (*) -- matches everything */
+ else
+ expr = chill_handle_multi_case_else_label (selector);
+ }
+ else
+ {
+ tree low = TREE_OPERAND (label, 0);
+ tree high = TREE_OPERAND (label, 1);
+ if (TREE_CODE (low) != INTEGER_CST)
+ {
+ error ("Lower bound of range must be a discrete literal expression");
+ expr = error_mark_node;
+ }
+ if (TREE_CODE (high) != INTEGER_CST)
+ {
+ error ("Upper bound of range must be a discrete literal expression");
+ expr = error_mark_node;
+ }
+ if (expr != error_mark_node)
+ {
+ expr = chill_handle_multi_case_label_range (
+ low, high, TREE_VALUE (selector));
+ }
+ }
+ }
+ else if (TREE_CODE (label) == TYPE_DECL)
+ {
+ tree type = TREE_TYPE (label);
+ if (! discrete_type_p (type))
+ {
+ error ("mode in label is not discrete");
+ expr = error_mark_node;
+ }
+ else
+ expr = chill_handle_multi_case_label_range (
+ TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector));
+ }
+ else
+ {
+ error ("The CASE label is not valid");
+ expr = error_mark_node;
+ }
+
+ return expr;
+}
+
+static tree
+chill_handle_multi_case_label_list (selector, labels)
+ tree selector, labels;
+{
+ tree one_label, selector_value, larg, rarg;
+
+ one_label = TREE_VALUE (labels);
+ larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
+
+ for (one_label = TREE_CHAIN (one_label);
+ one_label != NULL_TREE;
+ one_label = TREE_CHAIN (one_label))
+ {
+ rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
+ larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
+ }
+
+ return larg;
+}
+
+tree
+build_multi_case_selector_expression (selector_list, label_spec)
+ tree selector_list, label_spec;
+{
+ tree labels, selector, larg, rarg;
+
+ labels = label_spec;
+ selector = selector_list;
+ larg = chill_handle_multi_case_label_list(selector, labels);
+
+ for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector);
+ labels != NULL_TREE && selector != NULL_TREE;
+ labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector))
+ {
+ rarg = chill_handle_multi_case_label_list(selector, labels);
+ larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg);
+ }
+
+ if (labels != NULL_TREE || selector != NULL_TREE)
+ error ("The number of CASE selectors does not match the number of CASE label lists");
+
+ return larg;
+}
+
+#define BITARRAY_TEST(ARRAY, INDEX) \
+ ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
+ & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)))
+#define BITARRAY_SET(ARRAY, INDEX) \
+ ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
+ |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))
+
+extern HOST_WIDE_INT all_cases_count PROTO((tree, int*));
+extern void mark_seen_cases PROTO((tree, unsigned char*, long, int));
+
+/* CASES_SEEN is a set (bitarray) of length COUNT.
+ For each element that is zero, print an error message,
+ assume the element have the given TYPE. */
+
+static void
+print_missing_cases (type, cases_seen, count)
+ tree type;
+ unsigned char *cases_seen;
+ long count;
+{
+ long i;
+ for (i = 0; i < count; i++)
+ {
+ if (BITARRAY_TEST(cases_seen, i) == 0)
+ {
+ char buf[20];
+ long x = i;
+ long j;
+ tree t = type;
+ char *err_val_name = "???";
+ if (TYPE_MIN_VALUE (t)
+ && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST)
+ x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t));
+ while (TREE_TYPE (t) != NULL_TREE)
+ t = TREE_TYPE (t);
+ switch (TREE_CODE (t))
+ {
+ tree v;
+ case BOOLEAN_TYPE:
+ err_val_name = x ? "TRUE" : "FALSE";
+ break;
+ case CHAR_TYPE:
+ if ((x >= ' ' && x < 127) && x != '\'' && x != '^')
+ sprintf (buf, "'%c'", x);
+ else
+ sprintf (buf, "'^(%d)'", x);
+ err_val_name = buf;
+ j = i;
+ while (j < count && !BITARRAY_TEST(cases_seen, j))
+ j++;
+ if (j > i + 1)
+ {
+ long y = x+j-i-1;
+ err_val_name += strlen (err_val_name);
+ if ((y >= ' ' && y < 127) && y != '\'' && y != '^')
+ sprintf (err_val_name, "%s:'%c'", buf, y);
+ else
+ sprintf (err_val_name, "%s:'^(%d)'", buf, y);
+ i = j - 1;
+ }
+ break;
+ case ENUMERAL_TYPE:
+ for (v = TYPE_VALUES (t); v && x; v = TREE_CHAIN (v))
+ x--;
+ if (v)
+ err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v));
+ break;
+ default:
+ j = i;
+ while (j < count && !BITARRAY_TEST(cases_seen, j))
+ j++;
+ if (j == i + 1)
+ sprintf (buf, "%d", x);
+ else
+ sprintf (buf, "%d:%d", x, x+j-i-1);
+ i = j - 1;
+ err_val_name = buf;
+ break;
+ }
+ error ("incomplete CASE - %s not handled", err_val_name);
+ }
+ }
+}
+
+void
+check_missing_cases (type)
+ tree type;
+{
+ int is_sparse;
+ /* For each possible selector value. a one iff it has been matched
+ by a case value alternative. */
+ unsigned char *cases_seen;
+ /* The number of possible selector values. */
+ HOST_WIDE_INT size = all_cases_count (type, &is_sparse);
+ long bytes_needed = (size+HOST_BITS_PER_CHAR)/HOST_BITS_PER_CHAR;
+
+ if (size == -1)
+ warning ("CASE selector with variable range");
+ else if (size < 0 || size > 600000
+ /* We deliberately use malloc here - not xmalloc. */
+ || (cases_seen = (char*) malloc (bytes_needed)) == NULL)
+ warning ("too many cases to do CASE completeness testing");
+ else
+ {
+ bzero (cases_seen, bytes_needed);
+ mark_seen_cases (type, cases_seen, size, is_sparse);
+ print_missing_cases (type, cases_seen, size);
+ free (cases_seen);
+ }
+}
+
+/*
+ * We build an expression tree here because, in many contexts,
+ * we don't know the type of result that's desired. By the
+ * time we get to expanding the tree, we do know.
+ */
+tree
+build_chill_case_expr (exprlist, casealtlist_expr,
+ optelsecase_expr)
+ tree exprlist, casealtlist_expr, optelsecase_expr;
+{
+ return build (CASE_EXPR, NULL_TREE, exprlist,
+ optelsecase_expr ?
+ tree_cons (NULL_TREE,
+ optelsecase_expr,
+ casealtlist_expr) :
+ casealtlist_expr);
+}
+
+/* This function transforms the selector_list and alternatives into a COND_EXPR. */
+tree
+build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr)
+ tree selector_list, alternatives, else_expr;
+{
+ tree expr;
+
+ selector_list = check_case_selector_list (selector_list);
+
+ if (alternatives == NULL_TREE)
+ return NULL_TREE;
+
+ alternatives = nreverse (alternatives);
+ /* alternatives represents the CASE label specifications and resulting values in
+ the reverse order in which they appeared.
+ If there is an ELSE expression, then use it. If there is no
+ ELSE expression, make the last alternative (which is the first in the list)
+ into the ELSE expression. This is safe because, if the CASE is complete
+ (as required), then the last condition need not be checked anyway. */
+ if (else_expr != NULL_TREE)
+ expr = else_expr;
+ else
+ {
+ expr = TREE_VALUE (alternatives);
+ alternatives = TREE_CHAIN (alternatives);
+ }
+
+ for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
+ {
+ tree value = TREE_VALUE (alternatives);
+ tree labels = TREE_PURPOSE (alternatives);
+ tree cond = build_multi_case_selector_expression(selector_list, labels);
+ expr = build_nt (COND_EXPR, cond, value, expr);
+ }
+
+ return expr;
+}
+
+\f
+/* This is called with the assumption that RHS has been stabilized.
+ It has one purpose: to iterate through the CHILL list of LHS's */
+void
+expand_assignment_action (loclist, modifycode, rhs)
+ tree loclist;
+ enum chill_tree_code modifycode;
+ tree rhs;
+{
+ if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK
+ || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
+ return;
+
+ if (TREE_CHAIN (loclist) != NULL_TREE)
+ { /* Multiple assignment */
+ tree target;
+ if (TREE_TYPE (rhs) != NULL_TREE)
+ rhs = save_expr (rhs);
+ else if (TREE_CODE (rhs) == CONSTRUCTOR)
+ error ("type of tuple cannot be implicit in multiple assignent");
+ else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR)
+ error ("conditional expression cannot be used in multiple assignent");
+ else
+ error ("internal error - unknown type in multiple assignment");
+
+ if (modifycode != NOP_EXPR)
+ {
+ error ("no operator allowed in multiple assignment,");
+ modifycode = NOP_EXPR;
+ }
+
+ for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target))
+ {
+ if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)),
+ TREE_TYPE (TREE_VALUE (loclist))))
+ {
+ error
+ ("location modes in multiple assignment are not equivalent");
+ break;
+ }
+ }
+ }
+ for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist))
+ chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs);
+}
+
+void
+chill_expand_assignment (lhs, modifycode, rhs)
+ tree lhs;
+ enum chill_tree_code modifycode;
+ tree rhs;
+{
+ tree loc;
+
+ while (TREE_CODE (lhs) == COMPOUND_EXPR)
+ {
+ expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0);
+ emit_queue ();
+ lhs = TREE_OPERAND (lhs, 1);
+ }
+
+ if (TREE_CODE (lhs) == ERROR_MARK)
+ return;
+
+ /* errors for assignment to BUFFER, EVENT locations.
+ what about SIGNALs? FIXME: Need similar test in
+ build_chill_function_call. */
+ if (TREE_CODE (lhs) == IDENTIFIER_NODE)
+ {
+ tree decl = lookup_name (lhs);
+ if (decl)
+ {
+ tree type = TREE_TYPE (decl);
+ if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
+ {
+ error ("You may not assign a value to a BUFFER or EVENT location");
+ return;
+ }
+ }
+ }
+
+ if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs))
+ {
+ error ("can't assign value to READonly location");
+ return;
+ }
+ if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs)))
+ {
+ error ("cannot assign to location with non-value property");
+ return;
+ }
+
+ if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE)
+ lhs = convert_from_reference (lhs);
+
+ /* check for lhs is a location */
+ loc = lhs;
+ while (1)
+ {
+ if (TREE_CODE (loc) == SLICE_EXPR)
+ loc = TREE_OPERAND (loc, 0);
+ else if (TREE_CODE (loc) == SET_IN_EXPR)
+ loc = TREE_OPERAND (loc, 1);
+ else
+ break;
+ }
+ if (! CH_LOCATION_P (loc))
+ {
+ error ("lefthand side of assignment is not a location");
+ return;
+ }
+
+ /* If a binary op has been requested, combine the old LHS value with
+ the RHS producing the value we should actually store into the LHS. */
+
+ if (modifycode != NOP_EXPR)
+ {
+ lhs = stabilize_reference (lhs);
+ /* This is to handle border-line cases such
+ as: LHS OR := [I]. This seems to be permitted
+ by the letter of Z.200, though it violates
+ its spirit, since LHS:=LHS OR [I] is
+ *not* legal. */
+ if (TREE_TYPE (rhs) == NULL_TREE)
+ rhs = convert (TREE_TYPE (lhs), rhs);
+ rhs = build_chill_binary_op (modifycode, lhs, rhs);
+ }
+
+ rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment");
+
+ /* handle the LENGTH (vary_array) := expr action */
+ loc = lhs;
+ if (TREE_CODE (loc) == NOP_EXPR)
+ loc = TREE_OPERAND (loc, 0);
+ if (TREE_CODE (loc) == COMPONENT_REF
+ && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0)))
+ && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id)
+ {
+ expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs);
+ }
+ else if (TREE_CODE (lhs) == SLICE_EXPR)
+ {
+ tree func = lookup_name (get_identifier ("__pscpy"));
+ tree dst = TREE_OPERAND (lhs, 0);
+ tree dst_offset = TREE_OPERAND (lhs, 1);
+ tree length = TREE_OPERAND (lhs, 2);
+ tree src, src_offset;
+ if (TREE_CODE (rhs) == SLICE_EXPR)
+ {
+ src = TREE_OPERAND (rhs, 0);
+ /* Should check that the TREE_OPERAND (src, 0) is
+ the same as length and powerserlen (src). FIXME */
+ src_offset = TREE_OPERAND (rhs, 1);
+ }
+ else
+ {
+ src = rhs;
+ src_offset = integer_zero_node;
+ }
+ expand_expr_stmt (build_chill_function_call (func,
+ tree_cons (NULL_TREE, force_addr_of (dst),
+ tree_cons (NULL_TREE, powersetlen (dst),
+ tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset),
+ tree_cons (NULL_TREE, force_addr_of (src),
+ tree_cons (NULL_TREE, powersetlen (src),
+ tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset),
+ tree_cons (NULL_TREE, convert (long_unsigned_type_node, length),
+ NULL_TREE)))))))));
+ }
+
+ else if (TREE_CODE (lhs) == SET_IN_EXPR)
+ {
+ tree from_pos = save_expr (TREE_OPERAND (lhs, 0));
+ tree set = TREE_OPERAND (lhs, 1);
+ tree domain = TYPE_DOMAIN (TREE_TYPE (set));
+ tree set_length = size_binop (PLUS_EXPR,
+ size_binop (MINUS_EXPR,
+ TYPE_MAX_VALUE (domain),
+ TYPE_MIN_VALUE (domain)),
+ integer_one_node);
+ tree filename = force_addr_of (get_chill_filename());
+
+ if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
+ sorry("bitstring slice");
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (
+ get_identifier ("__setbitpowerset")),
+ tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
+ tree_cons (NULL_TREE, set_length,
+ tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
+ tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
+ tree_cons (NULL_TREE, rhs,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, get_chill_linenumber(),
+ NULL_TREE)))))))));
+ }
+
+ /* Handle arrays of packed bitfields. Currently, this is limited to bitfields
+ which are 1 bit wide, so use the powerset runtime function. */
+ else if (TREE_CODE (lhs) == PACKED_ARRAY_REF)
+ {
+ tree from_pos = save_expr (TREE_OPERAND (lhs, 1));
+ tree array = TREE_OPERAND (lhs, 0);
+ tree domain = TYPE_DOMAIN (TREE_TYPE (array));
+ tree array_length = size_binop (PLUS_EXPR,
+ size_binop (MINUS_EXPR,
+ TYPE_MAX_VALUE (domain),
+ TYPE_MIN_VALUE (domain)),
+ integer_one_node);
+ tree filename = force_addr_of (get_chill_filename());
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (
+ get_identifier ("__setbitpowerset")),
+ tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"),
+ tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length),
+ tree_cons (NULL_TREE, convert (long_integer_type_node,
+ TYPE_MIN_VALUE (domain)),
+ tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
+ tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs),
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, get_chill_linenumber(),
+ NULL_TREE)))))))));
+ }
+
+ /* The following is probably superceded by the
+ above code for SET_IN_EXPR. FIXME! */
+ else if (TREE_CODE (lhs) == BIT_FIELD_REF)
+ {
+ tree set = TREE_OPERAND (lhs, 0);
+ tree numbits = TREE_OPERAND (lhs, 1);
+ tree from_pos = save_expr (TREE_OPERAND (lhs, 2));
+ tree domain = TYPE_DOMAIN (TREE_TYPE (set));
+ tree set_length = size_binop (PLUS_EXPR,
+ size_binop (MINUS_EXPR,
+ TYPE_MAX_VALUE (domain),
+ TYPE_MIN_VALUE (domain)),
+ integer_one_node);
+ tree filename = force_addr_of (get_chill_filename());
+ tree to_pos;
+ switch (TREE_CODE (TREE_TYPE (rhs)))
+ {
+ case SET_TYPE:
+ to_pos = size_binop (MINUS_EXPR,
+ size_binop (PLUS_EXPR, from_pos, numbits),
+ integer_one_node);
+ break;
+ case BOOLEAN_TYPE:
+ to_pos = from_pos;
+ break;
+ default:
+ abort ();
+ }
+
+ if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
+ sorry("bitstring slice");
+ expand_expr_stmt (
+ build_chill_function_call( lookup_name (
+ get_identifier ("__setbitpowerset")),
+ tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
+ tree_cons (NULL_TREE, set_length,
+ tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
+ tree_cons (NULL_TREE, from_pos,
+ tree_cons (NULL_TREE, rhs,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, get_chill_linenumber(),
+ NULL_TREE)))))))));
+ }
+
+ else
+ expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
+}
+\f
+/* Also assumes that rhs has been stabilized */
+void
+expand_varying_length_assignment (lhs, rhs)
+ tree lhs, rhs;
+{
+ tree base_array, min_domain_val;
+
+ pedwarn ("LENGTH on left-hand-side is non-portable");
+
+ if (! CH_LOCATION_P (lhs))
+ {
+ error ("Can only set LENGTH of array location");
+ return;
+ }
+
+ /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
+ rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1);
+
+ base_array = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs));
+ min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array));
+
+ lhs = build_component_ref (lhs, var_length_id);
+ rhs = size_binop (MINUS_EXPR, rhs, min_domain_val);
+
+ expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
+}
+\f
+void
+push_action ()
+{
+ push_handler ();
+ if (ignoring)
+ return;
+ emit_line_note (input_filename, lineno);
+}
--- /dev/null
+#!/bin/sh
+# Compile GNU Chill programs.
+: || exec /bin/sh -f $0 $argv:q
+
+# The compiler name might be different when doing cross-compilation
+# (this should be configured)
+gcc_name=gcc
+whatgcc=gcc
+speclang=-xnone
+startfile=chillrt0
+gnuchill_script_flags=
+gnuchill_version=unknown
+extraflags=
+
+# replace the command name by the name of the new command
+progname=`basename $0`
+case "$0" in
+ */*)
+ gcc=`echo $0 | sed -e "s;/[^/]*$;;"`/$gcc_name
+ ;;
+ *)
+ gcc=$gcc_name
+ ;;
+esac
+
+# $first is yes for first arg, no afterwards.
+first=yes
+# If next arg is the argument of an option, $quote is non-empty.
+# More precisely, it is the option that wants an argument.
+quote=
+# $library is made empty to disable use of libchill.
+library="-lchill"
+libpath=chillrt
+numargs=$#
+
+for arg
+do
+ if [ $first = yes ]
+ then
+ # Need some 1st arg to `set' which does not begin with `-'.
+ # We get rid of it after the loop ends.
+ set gcc
+ first=no
+ fi
+ # If you have to ask what this does, you should not edit this file. :-)
+ # The ``S'' at the start is so that echo -nostdinc does not eat the
+ # -nostdinc.
+ arg=`echo "S$arg" | sed "s/^S//; s/'/'\\\\\\\\''/g"`
+ if [ x$quote != x ]
+ then
+ quote=
+ else
+ quote=
+ case $arg in
+ -nostdlib)
+ # Inhibit linking with -lchill.
+ library=
+ libpath=
+ startfile=
+ ;;
+ -B*)
+ gcc=`echo $arg | sed -e "s/^-B//"`$gcc_name
+ ;;
+ -[bBVDUoeTuIYmLiA] | -Tdata | -Xlinker)
+ # these switches take following word as argument,
+ # so don't treat it as a file name.
+ quote=$arg
+ ;;
+ -[cSEM] | -MM)
+ # Don't specify libraries if we won't link,
+ # since that would cause a warning.
+ library=
+ libpath=
+ startfile=
+ ;;
+ -x*)
+ speclang=$arg
+ ;;
+ -v)
+ # catch `chill -v'
+ if [ $numargs = 1 ] ; then
+ library=
+ libpath=
+ startfile=
+ fi
+ echo "GNUCHILL version $gnuchill_version"
+ ;;
+ -fgrant-only | -fchill-grant-only)
+ #inhibit production of an object file
+ extraflags="-S -o /dev/null"
+ library=
+ libpath=
+ startfile=
+ ;;
+ -*)
+ # Pass other options through; they don't need -x and aren't inputs.
+ ;;
+ *)
+ # If file ends in .i, put options around it.
+ # But not if a specified -x option is currently active.
+ case "$speclang $arg" in -xnone\ *.[i])
+ set "$@" -xchill "'$arg'" -xnone
+ continue
+ esac
+ ;;
+ esac
+ fi
+ set "$@" "'$arg'"
+done
+
+# Get rid of that initial 1st arg
+if [ $first = no ]; then
+ shift
+else
+ echo "$0: No input files specified."
+ exit 1
+fi
+
+if [ x$quote != x ]
+then
+ echo "$0: argument to \`$quote' missing"
+ exit 1
+fi
+
+# The '-ansi' flag prevents cpp from changing this:
+# NEWMODE x = SET (sun, mon, thu, wed, thu, fri, sat);
+#to this:
+# NEWMODE x = SET (1, mon, thu, wed, thu, fri, sat);
+#which is a CHILL syntax error.
+eval $whatgcc -ansi $gnuchill_script_flags $startfile "$@" $libpath $library $extraflags
--- /dev/null
+# Top level configure fragment for GNU CHILL.
+# Copyright (C) 1994 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language - name of language as it would appear in $(LANGUAGES)
+# compilers - value to add to $(COMPILERS)
+# stagestuff - files to add to $(STAGESTUFF)
+# diff_excludes - files to ignore when building diffs between two versions.
+
+language="CHILL"
+
+compilers="cc1chill"
+
+stagestuff="chill chill-cross cc1chill"
+
+diff_excludes="-x -x ch/chill.info*"
--- /dev/null
+#!/bin/sh
+# Configuration script for GNU CHILL
+# Copyright (C) 1994 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+#
+# Shell script to create proper links to machine-dependent files in
+# preparation for compiling gcc.
+#
+# Options: --srcdir=DIR specifies directory where sources are.
+# --host=HOST specifies host configuration.
+# --target=TARGET specifies target configuration.
+# --build=TARGET specifies configuration of machine you are
+# using to compile GCC.
+# --prefix=DIR specifies directory to install in.
+# --local-prefix=DIR specifies directory to put local ./include in.
+# --exec-prefix=DIR specifies directory to install executables in.
+# --with-gnu-ld arrange to work with GNU ld.
+# --with-gnu-as arrange to work with GAS.
+# --with-stabs arrange to use stabs instead of host debug format.
+# --with-elf arrange to use elf instead of host debug format.
+# --nfp assume system has no FPU.
+#
+# If configure succeeds, it leaves its status in config.status.
+# If configure fails after disturbing the status quo,
+# config.status is removed.
+#
+
+progname=$0
+# Configure the runtime and regression-test directories
+SUBDIRS="runtime utils"
+SUBDIRS="$SUBDIRS testsuite/compile"
+SUBDIRS="$SUBDIRS testsuite/execute"
+SUBDIRS="$SUBDIRS testsuite/execute/telebras"
+SUBDIRS="$SUBDIRS testsuite/noncompile"
+SUBDIRS="$SUBDIRS testsuite/examples"
+SUBDIRS="$SUBDIRS testsuite/execute/oe"
+SUBDIRS="$SUBDIRS testsuite/compile/elektra"
+SUBDIRS="$SUBDIRS testsuite/compile/votrics"
+
+# Default --srcdir to the directory where the script is found,
+# if a directory was specified.
+# The second sed call is to convert `.//configure' to `./configure'.
+srcdir=`echo $0 | sed 's|//|/|' | sed 's|/[^/]*$||'`
+if [ x$srcdir = x$0 ]
+then
+srcdir=
+fi
+
+host=
+
+# Default prefix to /usr/local.
+prefix=/usr/local
+
+# local_prefix specifies where to find the directory /usr/local/include
+# We don't use $(prefix) for this
+# because we always want GCC to search /usr/local/include
+# even if GCC is installed somewhere other than /usr/local.
+# Think THREE TIMES before specifying any other value for this!
+# DO NOT make this use $prefix!
+local_prefix=/usr/local
+# CYGNUS LOCAL: for our purposes, this must be prefix. This is apparently
+# only done for the benefit of glibc, and we don't use glibc.
+local_prefix='$(prefix)'
+# Default is to let the Makefile set exec_prefix from $(prefix)
+exec_prefix='$(prefix)'
+
+# CYGNUS LOCAL. Default to nothing.
+program_transform_name=
+program_transform_set=
+site=
+
+remove=rm
+hard_link=ln
+symbolic_link='ln -s'
+copy=cp
+
+# Record all the arguments, to write them in config.status.
+arguments=$*
+
+#for Test
+#remove="echo rm"
+#hard_link="echo ln"
+#symbolic_link="echo ln -s"
+
+target=
+host=
+build=
+
+for arg in $*;
+do
+ case $next_arg in
+ --srcdir)
+ srcdir=$arg
+ next_arg=
+ ;;
+ --host)
+ host=$arg
+ next_arg=
+ ;;
+ --target)
+ target=$arg
+ next_arg=
+ ;;
+ --build)
+ build=$arg
+ next_arg=
+ ;;
+ --prefix)
+ prefix=$arg
+ next_arg=
+ ;;
+ --local-prefix)
+ local_prefix=$arg
+ next_arg=
+ ;;
+ --exec-prefix)
+ exec_prefix=$arg
+ next_arg=
+ ;;
+ --program-transform-name) # CYGNUS LOCAL
+ # Double any backslashes or dollar signs in the argument.
+ if [ -n "${arg}" ] ; then
+ program_transform_name="${program_transform_name} -e `echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`"
+ fi
+ program_transform_set=yes
+ next_arg=
+ ;;
+ --program-prefix) # CYGNUS LOCAL
+ if [ -n "${arg}" ]; then
+ program_transform_name="${program_transform_name} -e s,^,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+ fi
+ program_transform_set=yes
+ next_arg=
+ ;;
+ --program-suffix) # CYGNUS LOCAL
+ if [ -n "${arg}" ]; then
+ program_transform_name="${program_transform_name} -e s,\$\$,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+ fi
+ program_transform_set=yes
+ next_arg=
+ ;;
+ --site) # CYGNUS LOCAL
+ site=${arg}
+ next_arg=
+ ;;
+ --x-*)
+ next_arg=
+ ;;
+ *)
+ case $arg in
+ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s)
+ next_arg=--srcdir
+ ;;
+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*)
+ srcdir=`echo $arg | sed 's/-*s[a-z]*=//'`
+ ;;
+ -host | --host | --hos | --ho | --h)
+ next_arg=--host
+ ;;
+ -host=* | --host=* | --hos=* | --ho=* | --h=*)
+ host=`echo $arg | sed 's/-*h[a-z]*=//'`
+ ;;
+ -target | --target | --targe | --targ | --tar | --ta | --t)
+ next_arg=--target
+ ;;
+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+ target=`echo $arg | sed 's/-*t[a-z]*=//'`
+ ;;
+ -build | --build | --buil | --bui | --bu | --b)
+ next_arg=--build
+ ;;
+ -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*)
+ build=`echo $arg | sed 's/-*b[a-z]*=//'`
+ ;;
+ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+ next_arg=--prefix
+ ;;
+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+ prefix=`echo $arg | sed 's/-*p[a-z]*=//'`
+ ;;
+ -local-prefix | --local-prefix | --local-prefi | --local-pref | --local-pre \
+ | --local-pr | --local-p | --local- | --local | --loc | --lo | --l)
+ next_arg=--local-prefix
+ ;;
+ -local-prefix=* | --local-prefix=* | --local-prefi=* | --local-pref=* \
+ | --local-pre=* | --local-pr=* | --local-p=* | --local-=* | --local=* \
+ | --loc=* | --lo=* | --l=*)
+ local_prefix=`echo $arg | sed 's/-*l[-a-z]*=//'`
+ ;;
+ -exec-prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre \
+ | --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e)
+ next_arg=--exec-prefix
+ ;;
+ -exec-prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* \
+ | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* \
+ | --exe=* | --ex=* | --e=*)
+ exec_prefix=`echo $arg | sed 's/-*e[-a-z]*=//'`
+ ;;
+ -program-transform-name | --program-transform-name \
+ | --program-transform-nam | --program-transform-na \
+ | --program-transform-n | --program-transform- | --program-transform \
+ | --program-transfor | --program-transfo | --program-transf \
+ | --program-trans | --program-tran | --program-tra \
+ | --program-tr | --program-t)
+ next_arg=--program-transform-name
+ # CYGNUS LOCAL
+ ;;
+ -program-transform-name=* | --program-transform-name=* \
+ | --program-transform-nam=* | --program-transform-na=* \
+ | --program-transform-n=* | --program-transform-=* \
+ | --program-transform=* | --program-transfor=* | --program-transfo=* \
+ | --program-transf=* | --program-trans=* | --program-tran=* \
+ | --program-tra=* | --program-tr=* | --program-t=*)
+ # CYGNUS LOCAL
+ arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'`
+ # Double any \ or $ in the argument.
+ if [ -n "${arg}" ] ; then
+ program_transform_name="${program_transform_name} -e `echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`"
+ fi
+ program_transform_set=yes
+ ;;
+ -program-prefix | --program-prefix | --program-prefi \
+ | --program-pref | --program-pre | --program-pr \
+ | --program-p)
+ next_arg=--program-prefix
+ # CYGNUS LOCAL
+ ;;
+ -program-prefix=* | --program-prefix=* | --program-prefi=* \
+ | --program-pref=* | --program-pre=* | --program-pr=* \
+ | --program-p=*)
+ # CYGNUS LOCAL
+ arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'`
+ if [ -n "${arg}" ]; then
+ program_transform_name="${program_transform_name} -e s,^,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+ fi
+ program_transform_set=yes
+ ;;
+ -program-suffix | --program-suffix | --program-suffi \
+ | --program-suff | --program-suf | --program-su \
+ | --program-s)
+ next_arg=--program-suffix
+ # CYGNUS LOCAL
+ ;;
+ -program-suffix=* | --program-suffix=* | --program-suffi=* \
+ | --program-suff=* | --program-suf=* | --program-su=* \
+ | --program-s=*)
+ # CYGNUS LOCAL
+ arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'`
+ if [ -n "${arg}" ]; then
+ program_transform_name="${program_transform_name} -e s,\$\$,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+ fi
+ program_transform_set=yes
+ ;;
+ -site | --site | --sit) # CYGNUS LOCAL
+ next_arg=--site
+ ;;
+ -site=* | --site=* | --sit=* | --si=*) # CYGNUS LOCAL
+ site=`echo ${arg} | sed 's/^[-a-z]*=//'`
+ ;;
+ -with-gnu-ld | --with-gnu-ld | --with-gnu-l)
+ gnu_ld=yes
+ ;;
+ -gas | --gas | --ga | --g | -with-gnu-as | --with-gnu-as | -with-gnu-a)
+ gas=yes
+ ;;
+ -nfp | --nfp | --nf | --n)
+ nfp=yes
+ ;;
+ -with-stabs | -with-stab | -with-sta | -with-st | -with-s \
+ | --with-stabs | --with-stab | --with-sta | --with-st | --with-s \
+ | -stabs | -stab | -sta | -st \
+ | --stabs | --stab | --sta | --st)
+ stabs=yes
+ ;;
+ -with-elf | -with-el | -with-se \
+ | --with-elf | --with-el | --with-e \
+ | -elf | -el | -e \
+ |--elf | --el | --e)
+ elf=yes
+ ;;
+ -with-* | --with-*) ;; #ignored
+ -without-* | --without-*) ;; #ignored
+ -enable-* | --enable-*) ;; #ignored
+ -x | --x) ;; # ignored
+ -x-*=* | --x-*=*) ;; # ignored
+ -x-* | --x-*)
+ next_arg=--x-ignored # ignored
+ ;;
+ --he*) ;; # ignored for now (--help)
+ --vers*) ;; # ignored for now (--version)
+ -v | -verb* | --verb*) ;; # ignored for now (--verbose)
+ --program-*) ;; #ignored (--program-prefix, --program-suffix)
+ --c*) ;; #ignored (--cache-file)
+ --q*) ;; #ignored (--quiet)
+ --si*) ;; #ignored (--silent)
+ -*)
+ echo "Invalid option \`$arg'" 1>&2
+ exit 1
+ ;;
+ *)
+# Allow configure HOST TARGET
+ if [ x$host = x ]
+ then
+ host=$target
+ fi
+ target=$arg
+ ;;
+ esac
+ esac
+done
+
+# Find the source files, if location was not specified.
+if [ x$srcdir = x ]
+then
+ srcdirdefaulted=1
+ srcdir=.
+ if [ ! -r tree.c ]
+ then
+ srcdir=..
+ fi
+fi
+
+if [ ! -r ${srcdir}/grant.c ]
+then
+ if [ x$srcdirdefaulted = x ]
+ then
+ echo "$progname: Can't find CHILL frontend sources in \`${srcdir}'" 1>&2
+ else
+ echo "$progname: Can't find CHILL frontend sources in \`.' or \`..'" 1>&2
+ fi
+ exit 1
+fi
+
+# Make sure that scripts are executable
+[ -w ${srcdir} -a -f ${srcdir}/regression.sh ] && \
+ chmod +x ${srcdir}/regression.sh
+[ -w ${srcdir} -a -f ${srcdir}/regression.prpt ] && \
+ chmod +x ${srcdir}/regression.prpt
+[ -w ${srcdir} -a -f ${srcdir}/regression.awk3 ] && \
+ chmod +x ${srcdir}/regression.awk3
+
+if [ -r ${srcdir}/config.status ] && [ x$srcdir != x. ]
+then
+ echo "$progname: \`configure' has been run in \`${srcdir}'" 1>&2
+ exit 1
+fi
+
+host_xmake_file=
+host_truncate_target=
+
+# Complain if an arg is missing
+if [ x$build = x ]
+then
+ # If host was specified, always use it for build also to avoid
+ # confusion. If someone wants a cross compiler where build != host,
+ # then they must specify build explicitly. Since this case is
+ # extremely rare, it does not matter that it is slightly inconvenient.
+ if [ x$host != x ]
+ then
+ build=$host
+
+ # This way of testing the result of a command substitution is
+ # defined by Posix.2 (section 3.9.1) as well as traditional shells.
+ elif build=`${srcdir}/../config.guess`
+ then
+ echo "This appears to be a ${build} system." 1>&2
+
+ elif [ x$target != x ]
+ then
+ echo 'Config.guess failed to determine the host type. Defaulting to target.'
+ build=$target
+ else
+ echo 'Config.guess failed to determine the host type. You need to specify one.' 1>&2
+ echo "\
+Usage: `basename $progname` [--host=HOST] [--build=BUILD]
+ [--prefix=DIR] [--gxx-include-dir=DIR] [--local-pref=DIR] [--exec-pref=DIR]
+ [--with-gnu-as] [--with-gnu-ld] [--with-stabs] [--with-elf] [--nfp] TARGET" 1>&2
+ echo "Where HOST, TARGET and BUILD are three-part configuration names " 1>&2
+ if [ -r config.status ]
+ then
+ tail +2 config.status 1>&2
+ fi
+ exit 1
+ fi
+fi
+
+# If $host was not specified, use $build.
+if [ x$host = x ]
+then
+ host=$build
+fi
+
+# If $target was not specified, use $host.
+if [ x$target = x ]
+then
+ target=$host
+fi
+
+# Validate the specs, and canonicalize them.
+canon_build=`/bin/sh $srcdir/../config.sub $build` || exit 1
+canon_host=`/bin/sh $srcdir/../config.sub $host` || exit 1
+canon_target=`/bin/sh $srcdir/../config.sub $target` || exit 1
+
+rm -f config.bak
+if [ -f config.status ]; then mv -f config.status config.bak; fi
+
+#
+# For the current directory and all of the designated SUBDIRS,
+# do the rest of the script...
+#
+if [ ! -d testsuite ] ; then mkdir testsuite; fi
+_SUBDIRS=
+for d in $SUBDIRS; do
+ [ -d $srcdir/$d ] && _SUBDIRS="$_SUBDIRS $d"
+done
+
+savesrcdir=$srcdir
+STARTDIR=`pwd`
+
+for subdir in $_SUBDIRS
+do
+ tmake_file=
+ host_xmake_file=
+ oldsrcdir=$savesrcdir
+
+ # ${invsubdir} is inverse of ${subdir), *with* trailing /, if needed.
+ invsubdir=`echo ${subdir}/ | sed -e 's|\./||g' -e 's|[^/]*/|../|g'`
+
+ # Re-adjust the path
+ # Also create a .gdbinit file which runs the one in srcdir
+ # and tells GDB to look there for source files.
+
+ case $oldsrcdir in
+ ".") srcdir=. ;;
+ /*) # absolute path
+ srcdir=${oldsrcdir}/${subdir} ;;
+ *) # otherwise relative
+ srcdir=${invsubdir}${oldsrcdir}/${subdir} ;;
+ esac
+
+ if [ -r ${oldsrcdir}/${subdir}/.gdbinit -a ${oldsrcdir} != "." ] ; then
+ cat > ${subdir}/.gdbinit <<EOF
+dir .
+dir ${srcdir}
+source ${srcdir}/.gdbinit
+EOF
+ fi
+
+ case $oldsrcdir in
+ /*) ;;
+ *) oldsrcdir=${invsubdir}${oldsrcdir} ;;
+ esac
+ mainsrcdir=${oldsrcdir}/..
+ test -d $subdir || mkdir $subdir
+ cd $subdir
+ #
+ # Create Makefile.tem from Makefile.in.
+ # Make it set VPATH if necessary so that the sources are found.
+ # Also change its value of srcdir.
+ rm -f Makefile.tem
+ echo "VPATH = ${srcdir}" \
+ | cat - ${srcdir}/Makefile.in \
+ | sed "s@^srcdir = \.@srcdir = ${srcdir}@" > Makefile.tem
+
+ # Conditionalize the makefile for this host machine.
+ if [ -f ${mainsrcdir}/config/${host_xmake_file} ]
+ then
+ rm -f Makefile.xx
+ sed -e "/####host/ r ${mainsrcdir}/config/${host_xmake_file}" Makefile.tem > Makefile.xx
+ echo "Merged ${host_xmake_file}."
+ rm -f Makefile.tem
+ mv Makefile.xx Makefile.tem
+ else
+ # Say in the makefile that there is no host_xmake_file,
+ # by using a name which (when interpreted relative to $srcdir/config)
+ # will duplicate another dependency: $srcdir/Makefile.in.
+ host_xmake_file=../Makefile.in
+ fi
+
+ # Define variables host_canonical, build_canonical, and target_canonical
+ # because some Cygnus local changes in the Makefile depend on them.
+ echo host_canonical = ${canon_host} > Makefile.xx
+ echo target_canonical = ${canon_target} >> Makefile.xx
+ echo build_canonical = ${canon_build} >> Makefile.xx
+ cat Makefile.tem >> Makefile.xx
+ mv Makefile.xx Makefile.tem
+
+ # Conditionalize the makefile for this target machine.
+ if [ -f ${mainsrcdir}/config/${tmake_file} ]
+ then
+ rm -f Makefile.xx
+ sed -e "/####target/ r ${mainsrcdir}/config/${tmake_file}" Makefile.tem > Makefile.xx
+ echo "Merged ${tmake_file}."
+ rm -f Makefile.tem
+ mv Makefile.xx Makefile.tem
+ else
+ # Say in the makefile that there is no tmake_file,
+ # by using a name which (when interpreted relative to $srcdir/config)
+ # will duplicate another dependency: $srcdir/Makefile.in.
+ tmake_file=../Makefile.in
+ fi
+
+ # CYGNUS LOCAL
+ # Conditionalize the makefile for this site.
+ if [ -f ${mainsrcdir}/config/ms-${site} ]
+ then
+ rm -f Makefile.xx
+ sed -e "/####site/ r ${mainsrcdir}/config/ms-${site}" Makefile.tem > Makefile.xx
+ echo "Merged ms-${site}."
+ rm -f Makefile.tem
+ mv Makefile.xx Makefile.tem
+ fi
+
+ # CYGNUS LOCAL
+ # If this is a cross compilation, and we have newlib in the build
+ # tree, then define inhibit_libc in LIBGCC2_CFLAGS. This will cause
+ # __eprintf to be left out of libgcc.a, but that's OK because newlib
+ # has its own version of assert.h.
+ if [ x$host != x$target ]; then
+ sed -e 's/^\(LIBGCC2_CFLAGS[ ]*=[ ]*\)/\1-Dinhibit_libc /' Makefile.tem > Makefile.tem2
+ rm -f Makefile.tem
+ mv Makefile.tem2 Makefile.tem
+ fi
+
+ # Remove all formfeeds, since some Makes get confused by them.
+ # Also arrange to give the variables `target', `host_xmake_file',
+ # `tmake_file', `prefix', `local_prefix', `exec_prefix', `FIXINCLUDES'
+ # and `INSTALL_HEADERS_DIR' values in the Makefile from the values
+ # they have in this script.
+ # CYGNUS LOCAL: FLOAT_H, CROSS_FLOAT_H, objdir
+ rm -f Makefile.xx
+ sed -e "s/\f//" -e "s/^target=.*$/target=${target}/" \
+ -e "s|^xmake_file=.*$|xmake_file=${host_xmake_file}|" \
+ -e "s|^tmake_file=.*$|tmake_file=${tmake_file}|" \
+ -e "s|^version=.*$|version=${version}|" \
+ -e "s|^prefix[ ]*=.*|prefix = $prefix|" \
+ -e "s|^local_prefix[ ]*=.*|local_prefix = $local_prefix|" \
+ -e "s|^exec_prefix[ ]*=.*|exec_prefix = $exec_prefix|" \
+ -e "s|^objdir[ ]*=.*|objdir=`pwd`|" \
+ Makefile.tem > Makefile.xx
+ rm -f Makefile.tem
+ mv Makefile.xx Makefile.tem
+
+ # Install Makefile for real, after making final changes.
+ # Define macro CROSS_COMPILE in compilation if this is a cross-compiler.
+ # Also use all.cross instead of all.internal, and add cross-make to Makefile.
+ if [ x$canon_host = x$canon_target ]
+ then
+ rm -f Makefile
+ if [ x$canon_host = x$canon_build ]
+ then
+ mv Makefile.tem Makefile
+ else
+ # When building gcc with a cross-compiler, we need to fix a
+ # few things.
+ echo "build= $build" > Makefile
+ sed -e "/####build/ r ${mainsrcdir}/build-make" Makefile.tem >> Makefile
+ rm -f Makefile.tem Makefile.xx
+ fi
+ else
+ rm -f Makefile
+ echo "CROSS=-DCROSS_COMPILE" > Makefile
+ sed -e "/####cross/ r ${mainsrcdir}/cross-make" Makefile.tem >> Makefile
+ rm -f Makefile.tem Makefile.xx
+ fi
+
+ echo "Created \`$subdir/Makefile'."
+
+ if [ xx${vint} != xx ]
+ then
+ vintmsg=" (vint)"
+ fi
+
+ # Describe the chosen configuration in config.status.
+ # Make that file a shellscript which will reestablish the same configuration.
+
+ rm -f config.bak
+ if [ -f config.status ]; then mv -f config.status config.bak; fi
+
+ echo "#!/bin/sh
+ # This directory was configured as follows:
+cd $invsubdir; ${progname}" $arguments > config.new
+ echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new
+ chmod a+x config.new
+
+ # If we aren't executing the configure script in .
+ if [ x$subdir != x. ]
+ then
+ if [ -f $srcdir/configure ]
+ then
+ echo "Running \`${CONFIG_SHELL-sh} $srcdir/configure $arguments\'"
+ ${CONFIG_SHELL-sh} $srcdir/configure $arguments
+ echo "${srcdir}/configure" $arguments >> config.new
+ echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new
+ fi
+ fi
+
+ if [ -f config.bak ] && cmp config.bak config.new >/dev/null 2>/dev/null;
+ then
+ mv -f config.bak config.status
+ rm -f config.new
+ else
+ mv -f config.new config.status
+ rm -f config.bak
+ fi
+
+ cd $STARTDIR
+done # end of current-dir SUBDIRS loop
+
+srcdir=$savesrcdir
+
+# Describe the chosen configuration in config.status.
+# Make that file a shellscript which will reestablish the same configuration.
+echo "#!/bin/sh
+# This directory was configured as follows:
+${progname}" $arguments > config.new
+echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new
+chmod a+x config.new
+if [ -f config.bak ] && cmp config.bak config.new >/dev/null 2>/dev/null;
+then
+ mv -f config.bak config.status
+ rm -f config.new
+else
+ mv -f config.new config.status
+ rm -f config.bak
+fi
+
+exit 0
--- /dev/null
+/* Language-level data type conversion for GNU CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+/* This file contains the functions for converting CHILL expressions
+ to different data types. The only entry point is `convert'.
+ Every language front end must have a `convert' function
+ but what kind of conversions it does will depend on the language. */
+
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "convert.h"
+#include "lex.h"
+
+extern void error PROTO((char *, ...));
+extern tree initializer_constant_valid_p PROTO((tree, tree));
+extern tree bit_one_node, bit_zero_node;
+extern tree string_one_type_node;
+extern tree bitstring_one_type_node;
+\f
+static tree
+convert_to_reference (reftype, expr)
+ tree reftype, expr;
+{
+ while (TREE_CODE (expr) == NOP_EXPR) /* RETYPE_EXPR */
+ expr = TREE_OPERAND (expr, 0);
+
+ if (! CH_LOCATION_P (expr))
+ error("internal error: trying to make loc-identity with non-location");
+ else
+ {
+ mark_addressable (expr);
+ return fold (build1 (ADDR_EXPR, reftype, expr));
+ }
+
+ return error_mark_node;
+}
+
+tree
+convert_from_reference (expr)
+ tree expr;
+{
+ tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
+ TREE_READONLY (e) = TREE_READONLY (expr);
+ return e;
+}
+
+/* Convert EXPR to a boolean type. */
+
+static tree
+convert_to_boolean (type, expr)
+ tree type, expr;
+{
+ register tree intype = TREE_TYPE (expr);
+
+ if (integer_zerop (expr))
+ return boolean_false_node;
+ if (integer_onep (expr))
+ return boolean_true_node;
+
+ /* Convert a singleton bitstring to a Boolean.
+ Needed if flag_old_strings. */
+ if (CH_BOOLS_ONE_P (intype))
+ {
+ if (TREE_CODE (expr) == CONSTRUCTOR)
+ {
+ tree valuelist = TREE_OPERAND (expr, 1);
+ if (valuelist == NULL_TREE)
+ return boolean_false_node;
+ if (TREE_CHAIN (valuelist) == NULL_TREE
+ && TREE_PURPOSE (valuelist) == NULL_TREE
+ && integer_zerop (TREE_VALUE (valuelist)))
+ return boolean_true_node;
+ }
+ return build_chill_bitref (expr,
+ build_tree_list (NULL_TREE,
+ integer_zero_node));
+ }
+
+ if (INTEGRAL_TYPE_P (intype))
+ return build1 (CONVERT_EXPR, type, expr);
+
+ error ("cannot convert to a boolean mode");
+ return boolean_false_node;
+}
+
+/* Convert EXPR to a char type. */
+
+static tree
+convert_to_char (type, expr)
+ tree type, expr;
+{
+ register tree intype = TREE_TYPE (expr);
+ register enum chill_tree_code form = TREE_CODE (intype);
+
+ if (form == CHAR_TYPE)
+ return build1 (NOP_EXPR, type, expr);
+
+ /* Convert a singleton string to a char.
+ Needed if flag_old_strings. */
+ if (CH_CHARS_ONE_P (intype))
+ {
+ if (TREE_CODE (expr) == STRING_CST)
+ {
+ expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
+ TREE_TYPE (expr) = char_type_node;
+ return expr;
+ }
+ else
+ return build (ARRAY_REF, char_type_node, expr, integer_zero_node);
+
+ }
+
+ /* For now, assume it will always fit */
+ if (form == INTEGER_TYPE)
+ return build1 (CONVERT_EXPR, type, expr);
+
+ error ("cannot convert to a char mode");
+
+ {
+ register tree tem = build_int_2 (0, 0);
+ TREE_TYPE (tem) = type;
+ return tem;
+ }
+}
+\f
+tree
+base_type_size_in_bytes (type)
+ tree type;
+{
+ if (type == NULL_TREE
+ || TREE_CODE (type) == ERROR_MARK
+ || TREE_CODE (type) != ARRAY_TYPE)
+ return error_mark_node;
+ return size_in_bytes (TREE_TYPE (type));
+}
+
+/*
+ * build a singleton array type, of TYPE objects.
+ */
+tree
+build_array_type_for_scalar (type)
+ tree type;
+{
+ /* KLUDGE */
+ if (type == char_type_node)
+ return build_string_type (type, integer_one_node);
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+
+ return build_chill_array_type
+ (type,
+ tree_cons (NULL_TREE,
+ build_chill_range_type (NULL_TREE,
+ integer_zero_node, integer_zero_node),
+ NULL_TREE),
+ 0, NULL_TREE);
+
+}
+\f
+#if 0
+static tree
+unreferenced_type_of (type)
+ tree type;
+{
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+ while (TREE_CODE (type) == REFERENCE_TYPE)
+ type = TREE_TYPE (type);
+ return type;
+}
+#endif
+
+
+/* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
+ Return the TREE_LIST node, or NULL_TREE on failure. */
+
+static tree
+remove_tree_element (key, listp)
+ tree *listp;
+ tree key;
+{
+ tree node = *listp;
+ for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
+ {
+ if (TREE_PURPOSE (node) == key)
+ {
+ *listp = TREE_CHAIN (node);
+ TREE_CHAIN (node) = NULL_TREE;
+ return node;
+ }
+ }
+ return NULL_TREE;
+}
+
+/* This is quite the same as check_range in actions.c, but with
+ different error message. */
+
+static tree
+check_ps_range (value, lo_limit, hi_limit)
+ tree value;
+ tree lo_limit;
+ tree hi_limit;
+{
+ tree check = test_range (value, lo_limit, hi_limit);
+
+ if (!integer_zerop (check))
+ {
+ if (TREE_CODE (check) == INTEGER_CST)
+ {
+ error ("powerset tuple element out of range");
+ return error_mark_node;
+ }
+ else
+ value = check_expression (value, check,
+ ridpointers[(int) RID_RANGEFAIL]);
+ }
+ return value;
+}
+
+static tree
+digest_powerset_tuple (type, inits)
+ tree type;
+ tree inits;
+{
+ tree list;
+ tree result;
+ tree domain = TYPE_DOMAIN (type);
+ int i = 0;
+ int is_erroneous = 0, is_constant = 1, is_simple = 1;
+ if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK)
+ return error_mark_node;
+ for (list = TREE_OPERAND (inits, 1); list; list = TREE_CHAIN (list), i++)
+ {
+ tree val = TREE_VALUE (list);
+ if (TREE_CODE (val) == ERROR_MARK)
+ {
+ is_erroneous = 1;
+ continue;
+ }
+ if (!TREE_CONSTANT (val))
+ is_constant = 0;
+ else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
+ is_simple = 0;
+ if (! CH_COMPATIBLE (val, domain))
+ {
+ error ("incompatible member of powerset tuple (at position #%d)", i);
+ is_erroneous = 1;
+ continue;
+ }
+ /* check range of value */
+ val = check_ps_range (val, TYPE_MIN_VALUE (domain),
+ TYPE_MAX_VALUE (domain));
+ if (TREE_CODE (val) == ERROR_MARK)
+ {
+ is_erroneous = 1;
+ continue;
+ }
+
+ /* Updating the list in place is in principle questionable,
+ but I can't think how it could hurt. */
+ TREE_VALUE (list) = convert (domain, val);
+
+ val = TREE_PURPOSE (list);
+ if (val == NULL_TREE)
+ continue;
+
+ if (TREE_CODE (val) == ERROR_MARK)
+ {
+ is_erroneous = 1;
+ continue;
+ }
+ if (! CH_COMPATIBLE (val, domain))
+ {
+ error ("incompatible member of powerset tuple (at position #%d)", i);
+ is_erroneous = 1;
+ continue;
+ }
+ val = check_ps_range (val, TYPE_MIN_VALUE (domain),
+ TYPE_MAX_VALUE (domain));
+ if (TREE_CODE (val) == ERROR_MARK)
+ {
+ is_erroneous = 1;
+ continue;
+ }
+ TREE_PURPOSE (list) = convert (domain, val);
+ if (!TREE_CONSTANT (val))
+ is_constant = 0;
+ else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
+ is_simple = 0;
+ }
+ result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
+ if (is_erroneous)
+ return error_mark_node;
+ if (is_constant)
+ TREE_CONSTANT (result) = 1;
+ if (is_constant && is_simple)
+ TREE_STATIC (result) = 1;
+ return result;
+}
+
+static tree
+digest_structure_tuple (type, inits)
+ tree type;
+ tree inits;
+{
+ tree elements = CONSTRUCTOR_ELTS (inits);
+ tree values = NULL_TREE;
+ int is_constant = 1;
+ int is_simple = 1;
+ int is_erroneous = 0;
+ tree field;
+ int labelled_elements = 0;
+ int unlabelled_elements = 0;
+ for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
+ { /* Regular fixed field. */
+ tree value = remove_tree_element (DECL_NAME (field), &elements);
+
+ if (value)
+ labelled_elements++;
+ else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
+ {
+ value = elements;
+ elements = TREE_CHAIN (elements);
+ unlabelled_elements++;
+ }
+
+ if (value)
+ {
+ tree val;
+ char msg[120];
+ sprintf (msg, "initializer for field `%.80s'",
+ IDENTIFIER_POINTER (DECL_NAME (field)));
+ val = chill_convert_for_assignment (TREE_TYPE (field),
+ TREE_VALUE (value), msg);
+ if (TREE_CODE (val) == ERROR_MARK)
+ is_erroneous = 1;
+ else
+ {
+ TREE_VALUE (value) = val;
+ TREE_CHAIN (value) = values;
+ TREE_PURPOSE (value) = field;
+ values = value;
+ if (TREE_CODE (val) == ERROR_MARK)
+ is_erroneous = 1;
+ else if (!TREE_CONSTANT (val))
+ is_constant = 0;
+ else if (!initializer_constant_valid_p (val,
+ TREE_TYPE (val)))
+ is_simple = 0;
+ }
+ }
+ else
+ {
+ pedwarn ("no initializer value for fixed field `%s'",
+ IDENTIFIER_POINTER (DECL_NAME (field)));
+ }
+ }
+ else
+ {
+ tree variant;
+ tree selected_variant = NULL_TREE;
+ tree variant_values = NULL_TREE;
+
+ /* In a tagged variant structure mode, try to figure out
+ (from the fixed fields), which is the selected variant. */
+ if (TYPE_TAGFIELDS (TREE_TYPE (field)))
+ {
+ for (variant = TYPE_FIELDS (TREE_TYPE (field));
+ variant; variant = TREE_CHAIN (variant))
+ {
+ tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant));
+ tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field));
+ if (DECL_NAME (variant) == ELSE_VARIANT_NAME)
+ {
+ selected_variant = variant;
+ break;
+ }
+ for (; tag_labels && tag_fields;
+ tag_labels = TREE_CHAIN (tag_labels),
+ tag_fields = TREE_CHAIN (tag_fields))
+ {
+ tree tag_value = values;
+ int found = 0;
+ tree tag_decl = TREE_VALUE (tag_fields);
+ tree tag_value_set = TREE_VALUE (tag_labels);
+ for ( ; tag_value; tag_value = TREE_CHAIN (tag_value))
+ {
+ if (TREE_PURPOSE (tag_value) == tag_decl)
+ {
+ tag_value = TREE_VALUE (tag_value);
+ break;
+ }
+ }
+ if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST)
+ {
+ pedwarn ("non-constant value for tag field `%s'",
+ IDENTIFIER_POINTER (DECL_NAME (tag_decl)));
+ goto get_values;
+ }
+
+ /* Check if the value of the tag (as given in a
+ previous field) matches the case label list. */
+ for (; tag_value_set;
+ tag_value_set = TREE_CHAIN (tag_value_set))
+ {
+ if (tree_int_cst_equal (TREE_VALUE (tag_value_set),
+ tag_value))
+ {
+ found = 1;
+ break;
+ }
+ }
+ if (!found)
+ break;
+ }
+ if (!tag_fields)
+ {
+ selected_variant = variant;
+ break;
+ }
+ }
+ }
+ get_values:
+ for (variant = TYPE_FIELDS (TREE_TYPE (field));
+ variant; variant = TREE_CHAIN (variant))
+ {
+ tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant));
+ tree vfield;
+ for (vfield = vfield0; vfield; vfield = TREE_CHAIN (vfield))
+ {
+ tree value = remove_tree_element (DECL_NAME (vfield),
+ &elements);
+
+ if (value)
+ labelled_elements++;
+ else if (variant == selected_variant
+ && elements && TREE_PURPOSE (elements) == NULL_TREE)
+ {
+ value = elements;
+ elements = TREE_CHAIN (elements);
+ unlabelled_elements++;
+ }
+
+ if (value)
+ {
+ if (selected_variant && selected_variant != variant)
+ {
+ error ("field `%s' in wrong variant",
+ IDENTIFIER_POINTER (DECL_NAME (vfield)));
+ is_erroneous = 1;
+ }
+ else
+ {
+ if (!selected_variant && vfield != vfield0)
+ pedwarn ("missing variant fields (at least `%s')",
+ IDENTIFIER_POINTER (DECL_NAME (vfield0)));
+ selected_variant = variant;
+ if (CH_COMPATIBLE (TREE_VALUE (value),
+ TREE_TYPE (vfield)))
+ {
+ tree val = convert (TREE_TYPE (vfield),
+ TREE_VALUE (value));
+ TREE_PURPOSE (value) = vfield;
+ TREE_VALUE (value) = val;
+ TREE_CHAIN (value) = variant_values;
+ variant_values = value;
+ if (TREE_CODE (val) == ERROR_MARK)
+ is_erroneous = 1;
+ else if (!TREE_CONSTANT (val))
+ is_constant = 0;
+ else if (!initializer_constant_valid_p
+ (val, TREE_TYPE (val)))
+ is_simple = 0;
+ }
+ else
+ {
+ is_erroneous = 1;
+ error ("bad initializer for field `%s'",
+ IDENTIFIER_POINTER (DECL_NAME (vfield)));
+ }
+ }
+ }
+ else if (variant == selected_variant)
+ {
+ pedwarn ("no initializer value for variant field `%s'",
+ IDENTIFIER_POINTER (DECL_NAME (field)));
+ }
+ }
+ }
+ if (selected_variant == NULL_TREE)
+ pedwarn ("no selected variant");
+ else
+ {
+ variant_values = build (CONSTRUCTOR,
+ TREE_TYPE (selected_variant),
+ NULL_TREE, nreverse (variant_values));
+ variant_values
+ = build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE,
+ build_tree_list (selected_variant, variant_values));
+ values = tree_cons (field, variant_values, values);
+ }
+ }
+ }
+
+ if (labelled_elements && unlabelled_elements)
+ pedwarn ("mixture of labelled and unlabelled tuple elements");
+
+ /* Check for unused initializer elements. */
+ unlabelled_elements = 0;
+ for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements))
+ {
+ if (TREE_PURPOSE (elements) == NULL_TREE)
+ unlabelled_elements++;
+ else
+ {
+ if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0)
+ error ("probably not a structure tuple");
+ else
+ error ("excess initializer for field `%s'",
+ IDENTIFIER_POINTER (TREE_PURPOSE (elements)));
+ is_erroneous = 1;
+ }
+ }
+ if (unlabelled_elements)
+ {
+ error ("excess unnamed initializers");
+ is_erroneous = 1;
+ }
+
+ CONSTRUCTOR_ELTS (inits) = nreverse (values);
+ TREE_TYPE (inits) = type;
+ if (is_erroneous)
+ return error_mark_node;
+ if (is_constant)
+ TREE_CONSTANT (inits) = 1;
+ if (is_constant && is_simple)
+ TREE_STATIC (inits) = 1;
+ return inits;
+}
+
+/* Return a Chill representation of the INTEGER_CST VAL.
+ The result may be in a static buffer, */
+
+char *
+display_int_cst (val)
+ tree val;
+{
+ static char buffer[50];
+ HOST_WIDE_INT x;
+ tree fields;
+ if (TREE_CODE (val) != INTEGER_CST)
+ return "<not a constant>";
+
+ x = TREE_INT_CST_LOW (val);
+
+ switch (TREE_CODE (TREE_TYPE (val)))
+ {
+ case BOOLEAN_TYPE:
+ if (x == 0)
+ return "FALSE";
+ if (x == 1)
+ return "TRUE";
+ goto int_case;
+ case CHAR_TYPE:
+ if (x == '^')
+ strcpy (buffer, "'^^'");
+ else if (x == '\n')
+ strcpy (buffer, "'^J'");
+ else if (x < ' ' || x > '~')
+ sprintf (buffer, "'^(%u)'", x);
+ else
+ sprintf (buffer, "'%c'", x);
+ return buffer;
+ case ENUMERAL_TYPE:
+ for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE;
+ fields = TREE_CHAIN (fields))
+ {
+ if (tree_int_cst_equal (TREE_VALUE (fields), val))
+ return IDENTIFIER_POINTER (TREE_PURPOSE (fields));
+ }
+ goto int_case;
+ case POINTER_TYPE:
+ if (x == 0)
+ return "NULL";
+ goto int_case;
+ int_case:
+ default:
+ /* This code is derived from print-tree.c:print_code_brief. */
+ if (TREE_INT_CST_HIGH (val) == 0)
+ sprintf (buffer,
+#if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
+ "%1u",
+#else
+ "%1lu",
+#endif
+ x);
+ else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0)
+ sprintf (buffer,
+#if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
+ "-%1u",
+#else
+ "-%1lu",
+#endif
+ -x);
+ else
+ sprintf (buffer,
+#if HOST_BITS_PER_WIDE_INT == 64
+#if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
+ "H'%lx%016lx",
+#else
+ "H'%x%016x",
+#endif
+#else
+#if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
+ "H'%lx%08lx",
+#else
+ "H'%x%08x",
+#endif
+#endif
+ TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val));
+ return buffer;
+ }
+}
+
+static tree
+digest_array_tuple (type, init, allow_missing_elements)
+ tree type;
+ tree init;
+ int allow_missing_elements;
+{
+ tree element = CONSTRUCTOR_ELTS (init);
+ int is_constant = 1;
+ int is_simple = 1;
+ tree element_type = TREE_TYPE (type);
+ tree default_value = NULL_TREE;
+ tree element_list = NULL_TREE;
+ tree domain_min;
+ tree domain_max;
+ tree *ptr = &element_list;
+ int errors = 0;
+ int labelled_elements = 0;
+ int unlabelled_elements = 0;
+ tree first, last = NULL_TREE;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+
+ domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+ domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+
+ if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST)
+ {
+ error ("non-constant start index for tuple");
+ return error_mark_node;
+ }
+ if (TREE_CODE (domain_max) != INTEGER_CST)
+ is_constant = 0;
+
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ abort ();
+
+ for ( ; element != NULL_TREE; element = TREE_CHAIN (element))
+ {
+ tree purpose = TREE_PURPOSE (element);
+ tree value = TREE_VALUE (element);
+
+ if (purpose == NULL_TREE)
+ {
+ if (last == NULL_TREE)
+ first = domain_min;
+ else
+ {
+ HOST_WIDE_INT new_lo, new_hi;
+ add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last),
+ 1, 0,
+ &new_lo, &new_hi);
+ first = build_int_2 (new_lo, new_hi);
+ TREE_TYPE (first) = TYPE_DOMAIN (type);
+ }
+ last = first;
+ unlabelled_elements++;
+ }
+ else
+ {
+ labelled_elements++;
+ if (TREE_CODE (purpose) == INTEGER_CST)
+ first = last = purpose;
+ else if (TREE_CODE (purpose) == TYPE_DECL
+ && discrete_type_p (TREE_TYPE (purpose)))
+ {
+ first = TYPE_MIN_VALUE (TREE_TYPE (purpose));
+ last = TYPE_MAX_VALUE (TREE_TYPE (purpose));
+ }
+ else if (TREE_CODE (purpose) != RANGE_EXPR)
+ {
+ error ("invalid array tuple label");
+ errors++;
+ continue;
+ }
+ else if (TREE_OPERAND (purpose, 0) == NULL_TREE)
+ first = last = NULL_TREE; /* Default value. */
+ else
+ {
+ first = TREE_OPERAND (purpose, 0);
+ last = TREE_OPERAND (purpose, 1);
+ }
+ if ((first != NULL && TREE_CODE (first) != INTEGER_CST)
+ || (last != NULL && TREE_CODE (last) != INTEGER_CST))
+ {
+ error ("non-constant array tuple index range");
+ errors++;
+ }
+ }
+
+ if (! CH_COMPATIBLE (value, element_type))
+ {
+ char *err_val_name = first ? display_int_cst (first) : "(default)";
+ error ("incompatible array tuple element %s", err_val_name);
+ value = error_mark_node;
+ }
+ else
+ value = convert (element_type, value);
+ if (TREE_CODE (value) == ERROR_MARK)
+ errors++;
+ else if (!TREE_CONSTANT (value))
+ is_constant = 0;
+ else if (!initializer_constant_valid_p (value, TREE_TYPE (value)))
+ is_simple = 0;
+
+ if (first == NULL_TREE)
+ {
+ if (default_value != NULL)
+ {
+ error ("multiple (*) or (ELSE) array tuple labels");
+ errors++;
+ }
+ default_value = value;
+ continue;
+ }
+
+ if (first != last && tree_int_cst_lt (last, first))
+ {
+ error ("empty range in array tuple");
+ errors++;
+ continue;
+ }
+
+ ptr = &element_list;
+
+#define MAYBE_RANGE_OP(PURPOSE, OPNO) \
+ (TREE_CODE (PURPOSE) == RANGE_EXPR ? TREE_OPERAND (PURPOSE, OPNO): PURPOSE)
+#define CONSTRUCTOR_ELT_LO(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 0)
+#define CONSTRUCTOR_ELT_HI(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 1)
+ while (*ptr && tree_int_cst_lt (last,
+ CONSTRUCTOR_ELT_LO (*ptr)))
+ ptr = &TREE_CHAIN (*ptr);
+ if (*ptr && ! tree_int_cst_lt (CONSTRUCTOR_ELT_HI (*ptr), first))
+ {
+ char *err_val_name = display_int_cst (first);
+ error ("array tuple has duplicate index %s", err_val_name);
+ errors++;
+ continue;
+ }
+ if ((ptr == &element_list && tree_int_cst_lt (domain_max, last))
+ || (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min)))
+ {
+ if (purpose)
+ error ("array tuple index out of range");
+ else if (errors == 0)
+ error ("too many array tuple values");
+ errors++;
+ continue;
+ }
+ if (! tree_int_cst_lt (first, last))
+ purpose = first;
+ else if (purpose == NULL_TREE || TREE_CODE (purpose) != RANGE_EXPR)
+ purpose = build_nt (RANGE_EXPR, first, last);
+ *ptr = tree_cons (purpose, value, *ptr);
+ }
+
+ element_list = nreverse (element_list);
+
+ /* For each missing element, set it to the default value,
+ if there is one. Otherwise, emit an error. */
+
+ if (errors == 0
+ && (!allow_missing_elements || default_value != NULL_TREE))
+ {
+ /* Iterate over each *gap* between specified elements/ranges. */
+ tree prev_elt;
+ if (element_list &&
+ tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min))
+ {
+ ptr = &TREE_CHAIN (element_list);
+ prev_elt = element_list;
+ }
+ else
+ {
+ prev_elt = NULL_TREE;
+ ptr = &element_list;
+ }
+ for (;;)
+ {
+ tree first, last;
+ /* Calculate the first element of the gap. */
+ if (prev_elt == NULL_TREE)
+ first = domain_min;
+ else
+ {
+ first = CONSTRUCTOR_ELT_HI (prev_elt);
+ if (tree_int_cst_equal (first, domain_max))
+ break; /* We're done. Avoid overflow below. */
+ first = copy_node (first);
+ add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first),
+ 1, 0,
+ &TREE_INT_CST_LOW (first),
+ &TREE_INT_CST_HIGH (first));
+ }
+ /* Calculate the last element of the gap. */
+ if (*ptr)
+ {
+ /* Actually end up with correct type. */
+ last = size_binop (MINUS_EXPR,
+ CONSTRUCTOR_ELT_LO (*ptr),
+ integer_one_node);
+ }
+ else
+ last = domain_max;
+ if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first))
+ ; /* Empty "gap" - no missing elements. */
+ else if (default_value)
+ {
+ tree purpose;
+ if (tree_int_cst_equal (first, last))
+ purpose = first;
+ else
+ purpose = build_nt (RANGE_EXPR, first, last);
+ *ptr = tree_cons (purpose, default_value, *ptr);
+ }
+ else
+ {
+ char *err_val_name = display_int_cst (first);
+ if (TREE_CODE (last) != INTEGER_CST)
+ error ("dynamic array tuple without (*) or (ELSE)");
+ else if (tree_int_cst_equal (first, last))
+ error ("missing array tuple element %s", err_val_name);
+ else
+ {
+ char *first_name = (char *)
+ xmalloc (strlen (err_val_name) + 1);
+ strcpy (first_name, err_val_name);
+ err_val_name = display_int_cst (last);
+ error ("missing array tuple elements %s : %s",
+ first_name, err_val_name);
+ free (first_name);
+ }
+ errors++;
+ }
+ if (*ptr == NULL_TREE)
+ break;
+ prev_elt = *ptr;
+ ptr = &TREE_CHAIN (*ptr);
+ }
+ }
+ if (errors)
+ return error_mark_node;
+
+ element = build (CONSTRUCTOR, type, NULL_TREE, element_list);
+ TREE_CONSTANT (element) = is_constant;
+ if (is_constant && is_simple)
+ TREE_STATIC (element) = 1;
+ if (labelled_elements && unlabelled_elements)
+ pedwarn ("mixture of labelled and unlabelled tuple elements");
+ return element;
+}
+\f
+/* This function is needed because no-op CHILL conversions are not fully
+ understood by the initialization machinery. This function should only
+ be called when a conversion truly is a no-op. */
+
+static tree
+convert1 (type, expr)
+ tree type, expr;
+{
+ int was_constant = TREE_CONSTANT (expr);
+ STRIP_NOPS (expr);
+ was_constant |= TREE_CONSTANT (expr);
+ expr = copy_node (expr);
+ TREE_TYPE (expr) = type;
+ if (TREE_CONSTANT (expr) != was_constant) abort ();
+ TREE_CONSTANT (expr) = was_constant;
+ return expr;
+}
+
+/* Create an expression whose value is that of EXPR,
+ converted to type TYPE. The TREE_TYPE of the value
+ is always TYPE. This function implements all reasonable
+ conversions; callers should filter out those that are
+ not permitted by the language being compiled.
+
+ In CHILL, we assume that the type is Compatible with the
+ Class of expr, and generally complain otherwise.
+ However, convert is more general (e.g. allows enum<->int
+ conversion), so there should probably be at least two routines.
+ Maybe add something like convert_for_assignment. FIXME. */
+
+tree
+convert (type, expr)
+ tree type, expr;
+{
+ register tree e = expr;
+ register enum chill_tree_code code;
+ char *errstr;
+ int type_varying;
+
+ if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK)
+ return error_mark_node;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+
+ code = TREE_CODE (type);
+
+ if (type == TREE_TYPE (e))
+ return e;
+
+ if (TREE_TYPE (e) != NULL_TREE
+ && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE)
+ e = convert_from_reference (e);
+
+ /* Support for converting *to* a reference type is limited;
+ it is only here as a convenience for loc-identity declarations,
+ and loc parameters. */
+ if (code == REFERENCE_TYPE)
+ return convert_to_reference (type, e);
+
+ /* if expression was untyped because of its context (an if_expr or case_expr
+ in a tuple, perhaps) just apply the type */
+ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == ERROR_MARK)
+ {
+ TREE_TYPE (e) = type;
+ return e;
+ }
+
+ /* Turn a NULL keyword into [0, 0] for an instance */
+ if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node)
+ {
+ tree field0 = TYPE_FIELDS (type);
+ tree field1 = TREE_CHAIN (field0);
+ e = build (CONSTRUCTOR, type, NULL_TREE,
+ tree_cons (field0, integer_zero_node,
+ tree_cons (field1, integer_zero_node,
+ NULL_TREE)));
+ TREE_CONSTANT (e) = 1;
+ TREE_STATIC (e) = 1;
+ return e;
+ }
+
+ /* Turn a pointer into a function pointer for a procmode */
+ if (TREE_CODE (type) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE
+ && expr == null_pointer_node)
+ return convert1 (type, expr);
+
+ /* turn function_decl expression into a pointer to
+ that function */
+ if (TREE_CODE (expr) == FUNCTION_DECL
+ && TREE_CODE (type) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
+ {
+ e = build1 (ADDR_EXPR, type, expr);
+ TREE_CONSTANT (e) = 1;
+ return e;
+ }
+
+ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)
+ e = varying_to_slice (e);
+ type_varying = chill_varying_type_p (type);
+
+ /* Convert a char to a singleton string.
+ Needed for compatibility with 1984 version of Z.200. */
+ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == CHAR_TYPE
+ && (CH_CHARS_ONE_P (type) || type_varying))
+ {
+ if (TREE_CODE (e) == INTEGER_CST)
+ {
+ char ch = TREE_INT_CST_LOW (e);
+ e = build_chill_string (1, &ch);
+ }
+ else
+ e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE,
+ tree_cons (NULL_TREE, e, NULL_TREE));
+ }
+
+ /* Convert a Boolean to a singleton bitstring.
+ Needed for compatibility with 1984 version of Z.200. */
+ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == BOOLEAN_TYPE
+ && (CH_BOOLS_ONE_P (type) || type_varying))
+ {
+ if (TREE_CODE (e) == INTEGER_CST)
+ e = integer_zerop (e) ? bit_zero_node : bit_one_node;
+ else
+ e = build (COND_EXPR, bitstring_one_type_node,
+ e, bit_one_node, bit_zero_node);
+ }
+
+ if (type_varying)
+ {
+ tree nentries;
+ tree field0 = TYPE_FIELDS (type);
+ tree field1 = TREE_CHAIN (field0);
+ tree orig_e = e;
+ tree target_array_type = TREE_TYPE (field1);
+ tree needed_padding;
+ tree padding_max_size = 0;
+ int orig_e_constant = TREE_CONSTANT (orig_e);
+ if (TREE_TYPE (e) != NULL_TREE
+ && TREE_CODE (TREE_TYPE (e)) == ARRAY_TYPE)
+ {
+ /* Note that array_type_nelts returns 1 less than the size. */
+ nentries = array_type_nelts (TREE_TYPE (e));
+ needed_padding = size_binop (MINUS_EXPR,
+ array_type_nelts (target_array_type),
+ nentries);
+ if (TREE_CODE (needed_padding) != INTEGER_CST)
+ {
+ padding_max_size = size_in_bytes (TREE_TYPE (e));
+ if (TREE_CODE (padding_max_size) != INTEGER_CST)
+ padding_max_size = TYPE_ARRAY_MAX_SIZE (TREE_TYPE (e));
+ }
+ nentries = size_binop (PLUS_EXPR, nentries, integer_one_node);
+ }
+ else if (TREE_CODE (e) == CONSTRUCTOR)
+ {
+ HOST_WIDE_INT init_cnt = 0;
+ tree chaser = CONSTRUCTOR_ELTS (e);
+ for ( ; chaser; chaser = TREE_CHAIN (chaser))
+ init_cnt++; /* count initializer elements */
+ nentries = build_int_2 (init_cnt, 0);
+ needed_padding = integer_zero_node;
+ if (TREE_TYPE (e) == NULL_TREE)
+ e = digest_array_tuple (TREE_TYPE (field1), e, 1);
+ orig_e_constant = TREE_CONSTANT (e);
+ }
+ else
+ {
+ error ("initializer is not an array or string mode");
+ return error_mark_node;
+ }
+#if 0
+ FIXME check that nentries will fit in type;
+#endif
+ if (!integer_zerop (needed_padding))
+ {
+ tree padding, padding_type, padding_range;
+ if (TREE_CODE (needed_padding) == INTEGER_CST
+ && (long)TREE_INT_CST_LOW (needed_padding) < 0)
+ {
+ error ("destination is too small");
+ return error_mark_node;
+ }
+ padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
+ needed_padding);
+ padding_type
+ = build_simple_array_type (TREE_TYPE (target_array_type),
+ padding_range, NULL_TREE);
+ TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size;
+ if (CH_CHARS_TYPE_P (target_array_type))
+ MARK_AS_STRING_TYPE (padding_type);
+ padding = build (UNDEFINED_EXPR, padding_type);
+ if (TREE_CONSTANT (e))
+ e = build_chill_binary_op (CONCAT_EXPR, e, padding);
+ else
+ e = build (CONCAT_EXPR, target_array_type, e, padding);
+ }
+ e = convert (TREE_TYPE (field1), e);
+ /* We build this constructor by hand (rather than going through
+ digest_structure_tuple), to avoid some type-checking problem.
+ E.g. type may have non-null novelty, but its field1 will
+ have non-novelty. */
+ e = build (CONSTRUCTOR, type, NULL_TREE,
+ tree_cons (field0, nentries,
+ build_tree_list (field1, e)));
+ /* following was wrong, cause orig_e never will be TREE_CONSTANT. e
+ may become constant after digest_array_tuple. */
+ if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */
+ {
+ TREE_CONSTANT (e) = 1;
+ if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
+ TREE_STATIC (e) = 1;
+ }
+ }
+ if (TREE_TYPE (e) == NULL_TREE)
+ {
+ if (TREE_CODE (e) == CONSTRUCTOR)
+ {
+ if (TREE_CODE (type) == SET_TYPE)
+ return digest_powerset_tuple (type, e);
+ if (TREE_CODE (type) == RECORD_TYPE)
+ return digest_structure_tuple (type, e);
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ return digest_array_tuple (type, e, 0);
+ fatal ("internal error - bad CONSTRUCTOR passed to convert");
+ }
+ else if (TREE_CODE (e) == COND_EXPR)
+ e = build (COND_EXPR, type,
+ TREE_OPERAND (e, 0),
+ convert (type, TREE_OPERAND (e, 1)),
+ convert (type, TREE_OPERAND (e, 2)));
+ else if (TREE_CODE (e) == CASE_EXPR)
+ TREE_TYPE (e) = type;
+ else
+ {
+ error ("internal error: unknown type of expression");
+ return error_mark_node;
+ }
+ }
+
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))
+ || (CH_NOVELTY (type) != NULL_TREE
+ && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e))))
+ return convert1 (type, e);
+
+ if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
+ {
+ error ("void value not ignored as it ought to be");
+ return error_mark_node;
+ }
+ if (code == VOID_TYPE)
+ return build1 (CONVERT_EXPR, type, e);
+
+ if (code == SET_TYPE)
+ return convert1 (type, e);
+
+ if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
+ {
+ if (flag_old_strings)
+ {
+ if (CH_CHARS_ONE_P (TREE_TYPE (e)))
+ e = convert_to_char (char_type_node, e);
+ else if (CH_BOOLS_ONE_P (TREE_TYPE (e)))
+ e = convert_to_boolean (boolean_type_node, e);
+ }
+ return fold (convert_to_integer (type, e));
+ }
+ if (code == POINTER_TYPE)
+ return fold (convert_to_pointer (type, e));
+ if (code == REAL_TYPE)
+ return fold (convert_to_real (type, e));
+ if (code == BOOLEAN_TYPE)
+ return fold (convert_to_boolean (type, e));
+ if (code == CHAR_TYPE)
+ return fold (convert_to_char (type, e));
+
+ if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e)))
+ {
+ /* The mode of the expression is different from that of the type.
+ Earlier checks should have tested against different lengths.
+ But even if the lengths are the same, it is possible that one
+ type is a static type (and hence could be say SImode), while the
+ other type is dynamic type (and hence is BLKmode).
+ This causes problems when emitting instructions. */
+ tree ee = build1 (INDIRECT_REF, type,
+ build1 (NOP_EXPR, build_pointer_type (type),
+ build1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (e)),
+ e)));
+ TREE_READONLY (ee) = TYPE_READONLY (type);
+ return ee;
+ }
+
+ /* The default! */
+ return convert1 (type, e);
+}
+
+/* Return an expression whose value is EXPR, but whose class is CLASS. */
+
+tree
+convert_to_class (class, expr)
+ struct ch_class class;
+ tree expr;
+{
+ switch (class.kind)
+ {
+ case CH_NULL_CLASS:
+ case CH_ALL_CLASS:
+ return expr;
+ case CH_DERIVED_CLASS:
+ if (TREE_TYPE (expr) != class.mode)
+ expr = convert (class.mode, expr);
+ if (!CH_DERIVED_FLAG (expr))
+ {
+ expr = copy_node (expr);
+ CH_DERIVED_FLAG (expr) = 1;
+ }
+ return expr;
+ case CH_VALUE_CLASS:
+ case CH_REFERENCE_CLASS:
+ if (TREE_TYPE (expr) != class.mode)
+ expr = convert (class.mode, expr);
+ if (CH_DERIVED_FLAG (expr))
+ {
+ expr = copy_node (expr);
+ CH_DERIVED_FLAG (expr) = 0;
+ }
+ return expr;
+ }
+ return expr;
+}
--- /dev/null
+/* Process declarations and variables for GNU CHILL compiler.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+ This file is part of GNU CC.
+
+ GNU CC is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ GNU CC is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU CC; see the file COPYING. If not, write to
+ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+/* Process declarations and symbol lookup for CHILL front end.
+ Also constructs types; the standard scalar types at initialization,
+ and structure, union, array and enum types when they are declared. */
+
+/* NOTES on Chill name resolution
+
+ Chill allows one to refer to an identifier that is declared later in
+ the same Group. Hence, a single pass over the code (as in C) is
+ insufficient.
+
+ This implementation uses two complete passes over the source code,
+ plus some extra passes over internal data structures.
+
+ Loosely, during pass 1, a 'scope' object is created for each Chill
+ reach. Each scope object contains a list of 'decl' objects,
+ one for each 'defining occurrence' in the reach. (This list
+ is in the 'remembered_decls' field of each scope.)
+ The scopes and their decls are replayed in pass 2: As each reach
+ is entered, the decls saved from pass 1 are made visible.
+
+ There are some exceptions. Declarations that cannot be referenced
+ before their declaration (i.e. whose defining occurrence precede
+ their reach), can be deferred to pass 2. These include formal
+ parameter declarations, and names defined in a DO action.
+
+ During pass 2, as each scope is entered, we must make visible all
+ the declarations defined in the scope, before we generate any code.
+ We must also simplify the declarations from pass 1: For example
+ a VAR_DECL may have a array type whose bounds are expressions;
+ these need to be folded. But of course the expressions may contain
+ identifiers that may be defined later in the scope - or even in
+ a different module.
+
+ The "satisfy" process has two main phases:
+
+ 1: Binding. Each identifier *referenced* in a declaration (i.e. in
+ a mode or the RHS of a synonum declaration) must be bound to its
+ defining occurrence. This may need to be linking via
+ grants and/or seizes (which are represented by ALIAS_DECLs).
+ A further complication is handling implied name strings.
+
+ 2: Layout. Each CONST_DECL or TYPE_DECL *referenced* in a declaration
+ must than be replaced by its value (or type). Constants must be
+ folded. Types and declarstions must be laid out. DECL_RTL must be set.
+ While doing this, we must watch out for circular dependencies.
+
+ If a scope contains nested modulions, then the Binding phase must be
+ done for each nested module (recursively) before the Layout phase
+ can start for that scope. As an example of why this is needed, consider:
+
+ M1: MODULE
+ DCL a ARRAY [1:y] int; -- This should have 7 elements.
+ SYN x = 5;
+ SEIZE y;
+ END M1;
+ M2: MODULE
+ SYN x = 2;
+ SYN y = x + 5;
+ GRANT y;
+ END M2;
+
+ Here, the 'x' in "x + 5" must be Bound to the 'x' in module M2.
+ This must be done before we can Layout a.
+ The reason this is an issue is that we do *not* have a lookup
+ (or hash) table per scope (or module). Instead we have a single
+ global table we we keep adding and removing bindings from.
+ (This is both for speed, and because of gcc history.)
+
+ Note that a SEIZE generates a declaration in the current scope,
+ linked to something in the surrounding scope. Determining (binding)
+ the link must be done in pass 2. On the other hand, a GRANT
+ generates a declaration in the surrounding scope, linked to
+ something in the current scope. This linkage is Bound in pass 1.
+
+ The sequence for the above example is:
+ - Enter the declarations of M1 (i.e. {a, x, y}) into the hash table.
+ - For each of {a, x, y}, examine dependent expression (the
+ rhs of x, the bounds of a), and Bind any identifiers to
+ the current declarations (as found in the hash table). Specifically,
+ the 'y' in the array bounds of 'a' is bound to the 'y' declared by
+ the SEIZE declaration. Also, 'y' is Bound to the implicit
+ declaration in the global scope (generated from the GRANT in M2).
+ - Remove the bindings for M1 (i.e. {a, x, y}) from the hash table.
+ - Enter the declarations of M2 (i.e. {x, y}) into the hash table.
+ - For each of {x, y} examine the dependent expressions (the rhs of
+ x and y), and Bind any identifiers to their current declarartions
+ (in this case the 'x' in "x + 5" is bound to the 'x' that is 2.
+ - Remove the bindings for M2 (i.e. {x, y}) from the hash table.
+ - Perform Layout for M1: This requires the size of a, which
+ requires the value of y. The 'y' is Bound to the implicit
+ declaration in the global scope, which is Bound to the declaration
+ of y in M2. We now require the value of this 'y', which is "x + 5"
+ where x is bound to the x in M2 (thanks to our previous Binding
+ phase). So we get that the value of y is 7.
+ - Perform layout of M2. This implies calculating (constant folding)
+ the value of y - but we already did that, so we're done.
+
+ An example illustating the problem with implied names:
+
+ M1: MODULE
+ SEIZE y;
+ use(e); -- e is implied by y.
+ END M1;
+ M2: MODULE
+ GRANT y;
+ SYNMODE y = x;
+ SEIZE x;
+ END M2;
+ M3: MODULE
+ GRANT x;
+ SYNMODE x = SET (e);
+ END M3;
+
+ This implies that determining the implied name e in M1
+ must be done after Binding of y to x in M2.
+
+ Yet another nasty:
+ M1: MODULE
+ SEIZE v;
+ DCL a ARRAY(v:v) int;
+ END M1;
+ M2: MODULE
+ GRANT v;
+ SEIZE x;
+ SYN v x = e;
+ END M2;
+ M3: MODULE
+ GRANT x;
+ SYNMODE x = SET(e);
+ END M3;
+
+ This one implies that determining the implied name e in M2,
+ must be done before Layout of a in M1.
+
+ These two examples togother indicate the determining implieed
+ names requries yet another phase.
+ - Bind strong names in M1.
+ - Bind strong names in M2.
+ - Bind strong names in M3.
+ - Determine weak names implied by SEIZEs in M1.
+ - Bind the weak names in M1.
+ - Determine weak names implied by SEIZEs in M2.
+ - Bind the weak names in M2.
+ - Determine weak names implied by SEIZEs in M3.
+ - Bind the weak names in M3.
+ - Layout M1.
+ - Layout M2.
+ - Layout M3.
+
+ We must bind the strong names in every module before we can determine
+ weak names in any module (because of seized/granted synmode/newmodes).
+ We must bind the weak names in every module before we can do Layout
+ in any module.
+
+ Sigh.
+
+ */
+
+/* ??? not all decl nodes are given the most useful possible
+ line numbers. For example, the CONST_DECLs for enum values. */
+
+#include <stdio.h>
+#include "config.h"
+#include "tree.h"
+#include "flags.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include "obstack.h"
+#include "input.h"
+#include "rtl.h"
+
+#define IS_UNKNOWN_TYPE(type) (TYPE_SIZE(type)==0)
+#define BUILTIN_NESTING_LEVEL (-1)
+
+/* For backward compatibility, we define Chill INT to be the same
+ as SHORT (i.e. 16 bits), at least if C INT is the same as LONG.
+ This is a lose. */
+#define CHILL_INT_IS_SHORT (INT_TYPE_SIZE==LONG_TYPE_SIZE)
+
+extern int ignore_case;
+extern tree process_type;
+extern struct obstack *saveable_obstack;
+extern tree signal_code;
+extern int special_UC;
+
+extern void tasking_init PROTO((void));
+extern void error PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern void expand_decl PROTO((tree));
+static tree get_next_decl PROTO((void));
+extern tree get_parm_decls PROTO((void));
+extern void end_temporary_allocation PROTO((void));
+extern void indent_to PROTO((FILE *, int));
+#ifdef RTX_CODE
+extern rtx label_rtx PROTO((tree));
+#endif
+extern tree lookup_name_for_seizing PROTO((tree));
+extern tree lookup_name_current_level PROTO((tree));
+extern int operand_equal_p PROTO((tree, tree, int));
+extern void pedwarn_with_decl PROTO((tree, char *, ...));
+extern void print_node PROTO((FILE *, char *, tree, int));
+extern void push_granted PROTO((tree, tree));
+extern void push_obstacks PROTO((struct obstack *, struct obstack *));
+extern void rest_of_decl_compilation PROTO((tree, char *, int, int));
+extern void sorry PROTO((char *, ...));
+static void save_decl PROTO((tree));
+extern void start_identifier_warnings PROTO((void));
+extern void temporary_allocation PROTO((void));
+extern void warning PROTO((char *, ...));
+
+extern struct obstack permanent_obstack;
+extern int in_pseudo_module;
+
+struct module *current_module = NULL;
+struct module *first_module = NULL;
+struct module **next_module = &first_module;
+
+extern int in_pseudo_module;
+
+int module_number = 0;
+
+/* This is only used internally (by signed_type). */
+
+tree signed_boolean_type_node;
+
+tree global_function_decl = NULL_TREE;
+
+/* This is a temportary used by RESULT to store its value.
+ Note we cannot directly use DECL_RESULT for two reasons:
+ a) If DECL_RESULT is a register, it may get clobbered by a
+ subsequent function call; and
+ b) if the function returns a struct, we might (visibly) modify the
+ destination before we're supposed to. */
+tree chill_result_decl;
+
+int result_never_set;
+
+/* forward declarations */
+static void pushdecllist PROTO((tree, int));
+static int init_nonvalue_struct PROTO((tree));
+static int init_nonvalue_array PROTO((tree));
+
+int current_nesting_level = BUILTIN_NESTING_LEVEL;
+int current_module_nesting_level = 0;
+\f
+/* Lots of declarations copied from c-decl.c. */
+/* ??? not all decl nodes are given the most useful possible
+ line numbers. For example, the CONST_DECLs for enum values. */
+
+#if 0
+/* In grokdeclarator, distinguish syntactic contexts of declarators. */
+enum decl_context
+{ NORMAL, /* Ordinary declaration */
+ FUNCDEF, /* Function definition */
+ PARM, /* Declaration of parm before function body */
+ FIELD, /* Declaration inside struct or union */
+ BITFIELD, /* Likewise but with specified width */
+ TYPENAME}; /* Typename (inside cast or sizeof) */
+#endif
+
+#ifndef CHAR_TYPE_SIZE
+#define CHAR_TYPE_SIZE BITS_PER_UNIT
+#endif
+
+#ifndef SHORT_TYPE_SIZE
+#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2))
+#endif
+
+#ifndef INT_TYPE_SIZE
+#define INT_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#ifndef LONG_TYPE_SIZE
+#define LONG_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#ifndef LONG_LONG_TYPE_SIZE
+#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2)
+#endif
+
+#ifndef WCHAR_UNSIGNED
+#define WCHAR_UNSIGNED 0
+#endif
+
+#ifndef FLOAT_TYPE_SIZE
+#define FLOAT_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#ifndef DOUBLE_TYPE_SIZE
+#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
+#endif
+
+#ifndef LONG_DOUBLE_TYPE_SIZE
+#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
+#endif
+
+/* We let tm.h override the types used here, to handle trivial differences
+ such as the choice of unsigned int or long unsigned int for size_t.
+ When machines start needing nontrivial differences in the size type,
+ it would be best to do something here to figure out automatically
+ from other information what type to use. */
+
+#ifndef PTRDIFF_TYPE
+#define PTRDIFF_TYPE "long int"
+#endif
+
+#ifndef WCHAR_TYPE
+#define WCHAR_TYPE "int"
+#endif
+\f
+/* a node which has tree code ERROR_MARK, and whose type is itself.
+ All erroneous expressions are replaced with this node. All functions
+ that accept nodes as arguments should avoid generating error messages
+ if this node is one of the arguments, since it is undesirable to get
+ multiple error messages from one error in the input. */
+
+tree error_mark_node;
+
+/* INTEGER_TYPE and REAL_TYPE nodes for the standard data types */
+
+tree short_integer_type_node;
+tree integer_type_node;
+tree long_integer_type_node;
+tree long_long_integer_type_node;
+
+tree short_unsigned_type_node;
+tree unsigned_type_node;
+tree long_unsigned_type_node;
+tree long_long_unsigned_type_node;
+
+tree ptrdiff_type_node;
+
+tree unsigned_char_type_node;
+tree signed_char_type_node;
+tree char_type_node;
+tree wchar_type_node;
+tree signed_wchar_type_node;
+tree unsigned_wchar_type_node;
+
+tree float_type_node;
+tree double_type_node;
+tree long_double_type_node;
+
+tree complex_integer_type_node;
+tree complex_float_type_node;
+tree complex_double_type_node;
+tree complex_long_double_type_node;
+
+tree intQI_type_node;
+tree intHI_type_node;
+tree intSI_type_node;
+tree intDI_type_node;
+tree intTI_type_node;
+
+tree unsigned_intQI_type_node;
+tree unsigned_intHI_type_node;
+tree unsigned_intSI_type_node;
+tree unsigned_intDI_type_node;
+tree unsigned_intTI_type_node;
+
+/* a VOID_TYPE node. */
+
+tree void_type_node;
+tree void_list_node;
+
+/* Nodes for types `void *' and `const void *'. */
+tree ptr_type_node, const_ptr_type_node;
+
+/* type of initializer structure, which points to
+ a module's module-level code, and to the next
+ such structure. */
+tree initializer_type;
+
+/* type of a CHILL predefined value builtin routine */
+tree chill_predefined_function_type;
+
+/* type `int ()' -- used for implicit declaration of functions. */
+
+tree default_function_type;
+
+#if 0
+/* function types `double (double)' and `double (double, double)', etc. */
+
+tree double_ftype_double, double_ftype_double_double;
+tree int_ftype_int, long_ftype_long;
+
+/* Function type `void (void *, void *, int)' and similar ones */
+
+tree void_ftype_ptr_ptr_int, int_ftype_ptr_ptr_int, void_ftype_ptr_int_int;
+
+/* Function type `char *(char *, char *)' and similar ones */
+tree string_ftype_ptr_ptr, int_ftype_string_string;
+
+/* Function type `int (const void *, const void *, size_t)' */
+tree int_ftype_cptr_cptr_sizet;
+#endif
+
+char **boolean_code_name;
+
+/* Two expressions that are constants with value zero.
+ The first is of type `int', the second of type `void *'. */
+
+tree integer_zero_node;
+tree null_pointer_node;
+
+/* A node for the integer constant 1. */
+tree integer_one_node;
+
+/* A node for the integer constant -1. */
+tree integer_minus_one_node;
+
+/* Nodes for boolean constants TRUE and FALSE. */
+tree boolean_true_node, boolean_false_node;
+
+tree string_one_type_node; /* The type of CHARS(1). */
+tree bitstring_one_type_node; /* The type of BOOLS(1). */
+tree bit_zero_node; /* B'0' */
+tree bit_one_node; /* B'1' */
+
+/* Nonzero if we have seen an invalid cross reference
+ to a struct, union, or enum, but not yet printed the message. */
+
+tree pending_invalid_xref;
+/* File and line to appear in the eventual error message. */
+char *pending_invalid_xref_file;
+int pending_invalid_xref_line;
+
+/* After parsing the declarator that starts a function definition,
+ `start_function' puts here the list of parameter names or chain of decls.
+ `store_parm_decls' finds it here. */
+
+static tree current_function_parms;
+
+/* Nonzero when store_parm_decls is called indicates a varargs function.
+ Value not meaningful after store_parm_decls. */
+
+static int c_function_varargs;
+
+/* The FUNCTION_DECL for the function currently being compiled,
+ or 0 if between functions. */
+tree current_function_decl;
+
+/* These are irrelevant for Chill, but are referenced from from c-typeck.c. */
+int warn_format;
+int warn_traditional;
+int warn_bad_function_cast;
+
+/* Identifiers that hold VAR_LENGTH and VAR_DATA. */
+tree var_length_id, var_data_id;
+
+tree case_else_node;
+\f
+/* For each binding contour we allocate a scope structure
+ * which records the names defined in that contour.
+ * Contours include:
+ * 0) the global one
+ * 1) one for each function definition,
+ * where internal declarations of the parameters appear.
+ * 2) one for each compound statement,
+ * to record its declarations.
+ *
+ * The current meaning of a name can be found by searching the levels from
+ * the current one out to the global one.
+ */
+
+/* To communicate between pass 1 and 2, we maintain a list of "scopes".
+ Each scope corrresponds to a nested source scope/block that contain
+ that can contain declarations. The TREE_VALUE of the scope points
+ to the list of declarations declared in that scope.
+ The TREE_PURPOSE of the scope points to the surrounding scope.
+ (We may need to handle nested modules later. FIXME)
+ The TREE_CHAIN field contains a list of scope as they are seen
+ in chronological order. (Reverse order during first pass,
+ but it is reverse before pass 2.) */
+
+struct scope
+{
+ /* The enclosing scope. */
+ struct scope *enclosing;
+
+ /* The next scope, in chronlogical order. */
+ struct scope *next;
+
+ /* A chain of DECLs constructed using save_decl during pass 1. */
+ tree remembered_decls;
+
+ /* A chain of _DECL nodes for all variables, constants, functions,
+ and typedef types belong to this scope. */
+ tree decls;
+
+ /* List of declarations that have been granted into this scope. */
+ tree granted_decls;
+
+ /* List of implied (weak) names. */
+ tree weak_decls;
+
+ /* For each level, a list of shadowed outer-level local definitions
+ to be restored when this level is popped.
+ Each link is a TREE_LIST whose TREE_PURPOSE is an identifier and
+ whose TREE_VALUE is its old definition (a kind of ..._DECL node). */
+ tree shadowed;
+
+ /* For each level (except not the global one),
+ a chain of BLOCK nodes for all the levels
+ that were entered and exited one level down. */
+ tree blocks;
+
+ /* The BLOCK node for this level, if one has been preallocated.
+ If 0, the BLOCK is allocated (if needed) when the level is popped. */
+ tree this_block;
+
+ /* The binding level which this one is contained in (inherits from). */
+ struct scope *level_chain;
+
+ /* Nonzero for a level that corresponds to a module. */
+ char module_flag;
+
+ /* Zero means called from backend code. */
+ char two_pass;
+
+ /* The modules that are directly enclosed by this scope
+ are chained together. */
+ struct scope* first_child_module;
+ struct scope** tail_child_module;
+ struct scope* next_sibling_module;
+};
+
+/* The outermost binding level, for pre-defined (builtin) names. */
+
+static struct scope builtin_scope = { NULL, NULL, NULL_TREE};
+
+struct scope *global_scope;
+
+/* The binding level currently in effect. */
+
+static struct scope *current_scope = &builtin_scope;
+
+/* The most recently seen scope. */
+struct scope *last_scope = &builtin_scope;
+
+/* Binding level structures are initialized by copying this one. */
+
+static struct scope clear_scope
+ = {NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, 0, 0, 0};
+
+/* Chain of decls accessible through IDENTIFIER_OUTER_VALUE.
+ Decls with the same DECL_NAME are adjacent in the chain. */
+
+static tree outer_decls = NULL_TREE;
+
+/* Forward declarations. */
+
+tree pushdecl ();
+tree builtin_function ();
+
+tree lookup_name_current_level ();
+static void layout_array_type ();
+\f
+/* C-specific option variables. */
+
+/* Nonzero means allow type mismatches in conditional expressions;
+ just make their values `void'. */
+
+int flag_cond_mismatch;
+
+/* Nonzero means give `double' the same size as `float'. */
+
+int flag_short_double;
+
+/* Nonzero means don't recognize the keyword `asm'. */
+
+int flag_no_asm;
+
+/* Nonzero means don't recognize any builtin functions. */
+
+int flag_no_builtin;
+
+/* Nonzero means don't recognize the non-ANSI builtin functions.
+ -ansi sets this. */
+
+int flag_no_nonansi_builtin;
+
+/* Nonzero means do some things the same way PCC does. */
+
+int flag_traditional;
+
+/* Nonzero means to allow single precision math even if we're generally
+ being traditional. */
+int flag_allow_single_precision = 0;
+
+/* Nonzero means to treat bitfields as signed unless they say `unsigned'. */
+
+int flag_signed_bitfields = 1;
+int explicit_flag_signed_bitfields = 0;
+
+/* Nonzero means handle `#ident' directives. 0 means ignore them. */
+
+int flag_no_ident = 0;
+
+/* Nonzero means warn about implicit declarations. */
+
+int warn_implicit;
+
+/* Nonzero means give string constants the type `const char *'
+ to get extra warnings from them. These warnings will be too numerous
+ to be useful, except in thoroughly ANSIfied programs. */
+
+int warn_write_strings;
+
+/* Nonzero means warn about pointer casts that can drop a type qualifier
+ from the pointer target type. */
+
+int warn_cast_qual;
+
+/* Nonzero means warn about sizeof(function) or addition/subtraction
+ of function pointers. */
+
+int warn_pointer_arith;
+
+/* Nonzero means warn for non-prototype function decls
+ or non-prototyped defs without previous prototype. */
+
+int warn_strict_prototypes;
+
+/* Nonzero means warn for any global function def
+ without separate previous prototype decl. */
+
+int warn_missing_prototypes;
+
+/* Nonzero means warn about multiple (redundant) decls for the same single
+ variable or function. */
+
+int warn_redundant_decls = 0;
+
+/* Nonzero means warn about extern declarations of objects not at
+ file-scope level and about *all* declarations of functions (whether
+ extern or static) not at file-scope level. Note that we exclude
+ implicit function declarations. To get warnings about those, use
+ -Wimplicit. */
+
+int warn_nested_externs = 0;
+
+/* Warn about a subscript that has type char. */
+
+int warn_char_subscripts = 0;
+
+/* Warn if a type conversion is done that might have confusing results. */
+
+int warn_conversion;
+
+/* Warn if adding () is suggested. */
+
+int warn_parentheses;
+
+/* Warn if initializer is not completely bracketed. */
+
+int warn_missing_braces;
+
+/* Define the special tree codes that we use. */
+
+/* Table indexed by tree code giving a string containing a character
+ classifying the tree code. Possibilities are
+ t, d, s, c, r, <, 1 and 2. See ch-tree.def for details. */
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
+
+ char chill_tree_code_type[] = {
+ 'x',
+#include "ch-tree.def"
+ };
+#undef DEFTREECODE
+
+/* Table indexed by tree code giving number of expression
+ operands beyond the fixed part of the node structure.
+ Not used for types or decls. */
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
+
+int chill_tree_code_length[] = {
+ 0,
+#include "ch-tree.def"
+ };
+#undef DEFTREECODE
+
+
+/* Names of tree components.
+ Used for printing out the tree and error messages. */
+#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
+
+char *chill_tree_code_name[] = {
+ "@@dummy",
+#include "ch-tree.def"
+ };
+#undef DEFTREECODE
+
+/* Nonzero means `$' can be in an identifier.
+ See cccp.c for reasons why this breaks some obscure ANSI C programs. */
+
+#ifndef DOLLARS_IN_IDENTIFIERS
+#define DOLLARS_IN_IDENTIFIERS 0
+#endif
+int dollars_in_ident = DOLLARS_IN_IDENTIFIERS > 1;
+
+/* An identifier that is used internally to indicate
+ an "ALL" prefix for granting or seizing.
+ We use "*" rather than the external name "ALL", partly for convenience,
+ and partly to avoid case senstivity problems. */
+
+tree ALL_POSTFIX;
+\f
+void
+allocate_lang_decl (t)
+ tree t;
+{
+ /* Nothing needed */
+}
+
+void
+copy_lang_decl (node)
+ tree node;
+{
+ /* Nothing needed */
+}
+
+tree
+build_lang_decl (code, name, type)
+ enum chill_tree_code code;
+ tree name;
+ tree type;
+{
+ return build_decl (code, name, type);
+}
+\f
+/* Decode the string P as a language-specific option for C.
+ Return the number of strings consumed for a valid option.
+ Return 0 for an invalid option. */
+
+int
+c_decode_option (argc, argv)
+ int argc;
+ char **argv;
+{
+ char *p = argv[0];
+ if (!strcmp (p, "-ftraditional") || !strcmp (p, "-traditional"))
+ {
+ flag_traditional = 1;
+ flag_writable_strings = 1;
+#if DOLLARS_IN_IDENTIFIERS > 0
+ dollars_in_ident = 1;
+#endif
+ }
+ else if (!strcmp (p, "-fnotraditional") || !strcmp (p, "-fno-traditional"))
+ {
+ flag_traditional = 0;
+ flag_writable_strings = 0;
+ dollars_in_ident = DOLLARS_IN_IDENTIFIERS > 1;
+ }
+ else if (!strcmp (p, "-fsigned-char"))
+ flag_signed_char = 1;
+ else if (!strcmp (p, "-funsigned-char"))
+ flag_signed_char = 0;
+ else if (!strcmp (p, "-fno-signed-char"))
+ flag_signed_char = 0;
+ else if (!strcmp (p, "-fno-unsigned-char"))
+ flag_signed_char = 1;
+ else if (!strcmp (p, "-fsigned-bitfields")
+ || !strcmp (p, "-fno-unsigned-bitfields"))
+ {
+ flag_signed_bitfields = 1;
+ explicit_flag_signed_bitfields = 1;
+ }
+ else if (!strcmp (p, "-funsigned-bitfields")
+ || !strcmp (p, "-fno-signed-bitfields"))
+ {
+ flag_signed_bitfields = 0;
+ explicit_flag_signed_bitfields = 1;
+ }
+ else if (!strcmp (p, "-fshort-enums"))
+ flag_short_enums = 1;
+ else if (!strcmp (p, "-fno-short-enums"))
+ flag_short_enums = 0;
+ else if (!strcmp (p, "-fcond-mismatch"))
+ flag_cond_mismatch = 1;
+ else if (!strcmp (p, "-fno-cond-mismatch"))
+ flag_cond_mismatch = 0;
+ else if (!strcmp (p, "-fshort-double"))
+ flag_short_double = 1;
+ else if (!strcmp (p, "-fno-short-double"))
+ flag_short_double = 0;
+ else if (!strcmp (p, "-fasm"))
+ flag_no_asm = 0;
+ else if (!strcmp (p, "-fno-asm"))
+ flag_no_asm = 1;
+ else if (!strcmp (p, "-fbuiltin"))
+ flag_no_builtin = 0;
+ else if (!strcmp (p, "-fno-builtin"))
+ flag_no_builtin = 1;
+ else if (!strcmp (p, "-fno-ident"))
+ flag_no_ident = 1;
+ else if (!strcmp (p, "-fident"))
+ flag_no_ident = 0;
+ else if (!strcmp (p, "-ansi"))
+ flag_no_asm = 1, flag_no_nonansi_builtin = 1, dollars_in_ident = 0;
+ else if (!strcmp (p, "-Wimplicit"))
+ warn_implicit = 1;
+ else if (!strcmp (p, "-Wno-implicit"))
+ warn_implicit = 0;
+ else if (!strcmp (p, "-Wwrite-strings"))
+ warn_write_strings = 1;
+ else if (!strcmp (p, "-Wno-write-strings"))
+ warn_write_strings = 0;
+ else if (!strcmp (p, "-Wcast-qual"))
+ warn_cast_qual = 1;
+ else if (!strcmp (p, "-Wno-cast-qual"))
+ warn_cast_qual = 0;
+ else if (!strcmp (p, "-Wpointer-arith"))
+ warn_pointer_arith = 1;
+ else if (!strcmp (p, "-Wno-pointer-arith"))
+ warn_pointer_arith = 0;
+ else if (!strcmp (p, "-Wstrict-prototypes"))
+ warn_strict_prototypes = 1;
+ else if (!strcmp (p, "-Wno-strict-prototypes"))
+ warn_strict_prototypes = 0;
+ else if (!strcmp (p, "-Wmissing-prototypes"))
+ warn_missing_prototypes = 1;
+ else if (!strcmp (p, "-Wno-missing-prototypes"))
+ warn_missing_prototypes = 0;
+ else if (!strcmp (p, "-Wredundant-decls"))
+ warn_redundant_decls = 1;
+ else if (!strcmp (p, "-Wno-redundant-decls"))
+ warn_redundant_decls = 0;
+ else if (!strcmp (p, "-Wnested-externs"))
+ warn_nested_externs = 1;
+ else if (!strcmp (p, "-Wno-nested-externs"))
+ warn_nested_externs = 0;
+ else if (!strcmp (p, "-Wchar-subscripts"))
+ warn_char_subscripts = 1;
+ else if (!strcmp (p, "-Wno-char-subscripts"))
+ warn_char_subscripts = 0;
+ else if (!strcmp (p, "-Wconversion"))
+ warn_conversion = 1;
+ else if (!strcmp (p, "-Wno-conversion"))
+ warn_conversion = 0;
+ else if (!strcmp (p, "-Wparentheses"))
+ warn_parentheses = 1;
+ else if (!strcmp (p, "-Wno-parentheses"))
+ warn_parentheses = 0;
+ else if (!strcmp (p, "-Wreturn-type"))
+ warn_return_type = 1;
+ else if (!strcmp (p, "-Wno-return-type"))
+ warn_return_type = 0;
+ else if (!strcmp (p, "-Wcomment"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wno-comment"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wcomments"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wno-comments"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wtrigraphs"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wno-trigraphs"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wimport"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wno-import"))
+ ; /* cpp handles this one. */
+ else if (!strcmp (p, "-Wmissing-braces"))
+ warn_missing_braces = 1;
+ else if (!strcmp (p, "-Wno-missing-braces"))
+ warn_missing_braces = 0;
+ else if (!strcmp (p, "-Wall"))
+ {
+ extra_warnings = 1;
+ /* We save the value of warn_uninitialized, since if they put
+ -Wuninitialized on the command line, we need to generate a
+ warning about not using it without also specifying -O. */
+ if (warn_uninitialized != 1)
+ warn_uninitialized = 2;
+ warn_implicit = 1;
+ warn_return_type = 1;
+ warn_unused = 1;
+ warn_char_subscripts = 1;
+ warn_parentheses = 1;
+ warn_missing_braces = 1;
+ }
+ else
+ return 0;
+
+ return 1;
+}
+
+/* Hooks for print_node. */
+
+void
+print_lang_decl (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+ indent_to (file, indent + 3);
+ fprintf (file, "nesting_level %d ", DECL_NESTING_LEVEL (node));
+ if (DECL_WEAK_NAME (node))
+ fprintf (file, "weak_name ");
+ if (CH_DECL_SIGNAL (node))
+ fprintf (file, "decl_signal ");
+ print_node (file, "tasking_code",
+ (tree)DECL_TASKING_CODE_DECL (node), indent + 4);
+}
+
+
+void
+print_lang_type (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+ tree temp;
+
+ indent_to (file, indent + 3);
+ if (CH_IS_BUFFER_MODE (node))
+ fprintf (file, "buffer_mode ");
+ if (CH_IS_EVENT_MODE (node))
+ fprintf (file, "event_mode ");
+
+ if (CH_IS_EVENT_MODE (node) || CH_IS_BUFFER_MODE (node))
+ {
+ temp = max_queue_size (node);
+ if (temp)
+ print_node_brief (file, "qsize", temp, indent + 4);
+ }
+}
+
+void
+print_lang_identifier (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+ print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
+ print_node (file, "outer", IDENTIFIER_OUTER_VALUE (node), indent + 4);
+ print_node (file, "implicit", IDENTIFIER_IMPLICIT_DECL (node), indent + 4);
+ print_node (file, "error locus", IDENTIFIER_ERROR_LOCUS (node), indent + 4);
+ print_node (file, "signal_dest", IDENTIFIER_SIGNAL_DEST (node), indent + 4);
+ indent_to (file, indent + 3);
+ if (IDENTIFIER_SIGNAL_DATA(node))
+ fprintf (file, "signal_data ");
+}
+\f
+/* initialise non-value struct */
+
+static int
+init_nonvalue_struct (expr)
+ tree expr;
+{
+ tree type = TREE_TYPE (expr);
+ tree field;
+ int res = 0;
+
+ if (CH_IS_BUFFER_MODE (type))
+ {
+ expand_expr_stmt (
+ build_chill_modify_expr (
+ build_component_ref (expr, get_identifier ("__buffer_data")),
+ null_pointer_node));
+ return 1;
+ }
+ else if (CH_IS_EVENT_MODE (type))
+ {
+ expand_expr_stmt (
+ build_chill_modify_expr (
+ build_component_ref (expr, get_identifier ("__event_data")),
+ null_pointer_node));
+ return 1;
+ }
+ else if (CH_IS_ASSOCIATION_MODE (type))
+ {
+ expand_expr_stmt (
+ build_chill_modify_expr (expr,
+ chill_convert_for_assignment (type, association_init_value,
+ "association")));
+ return 1;
+ }
+ else if (CH_IS_ACCESS_MODE (type))
+ {
+ init_access_location (expr, type);
+ return 1;
+ }
+ else if (CH_IS_TEXT_MODE (type))
+ {
+ init_text_location (expr, type);
+ return 1;
+ }
+
+ for (field = TYPE_FIELDS (type); field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ type = TREE_TYPE (field);
+ if (CH_TYPE_NONVALUE_P (type))
+ {
+ tree exp = build_component_ref (expr, DECL_NAME (field));
+ if (TREE_CODE (type) == RECORD_TYPE)
+ res |= init_nonvalue_struct (exp);
+ else if (TREE_CODE (type) == ARRAY_TYPE)
+ res |= init_nonvalue_array (exp);
+ }
+ }
+ return res;
+}
+
+/* initialize non-value array */
+/* do it with DO FOR unique-id IN expr; ... OD; */
+static int
+init_nonvalue_array (expr)
+ tree expr;
+{
+ tree tmpvar = get_unique_identifier ("NONVALINIT");
+ tree type;
+ int res = 0;
+
+ push_loop_block ();
+ build_loop_iterator (tmpvar, expr, NULL_TREE, NULL_TREE, 0, 1, 0);
+ nonvalue_begin_loop_scope ();
+ build_loop_start (NULL_TREE);
+ tmpvar = lookup_name (tmpvar);
+ type = TREE_TYPE (tmpvar);
+ if (CH_TYPE_NONVALUE_P (type))
+ {
+ if (TREE_CODE (type) == RECORD_TYPE)
+ res |= init_nonvalue_struct (tmpvar);
+ else if (TREE_CODE (type) == ARRAY_TYPE)
+ res |= init_nonvalue_array (tmpvar);
+ }
+ build_loop_end ();
+ nonvalue_end_loop_scope ();
+ pop_loop_block ();
+ return res;
+}
+\f
+/* This excessive piece of code sets DECL_NESTING_LEVEL (DECL) to LEVEL. */
+
+void
+set_nesting_level (decl, level)
+ tree decl;
+ int level;
+{
+ static tree *small_ints = NULL;
+ static int max_small_ints = 0;
+
+ if (level < 0)
+ decl->decl.vindex = NULL_TREE;
+ else
+ {
+ if (level >= max_small_ints)
+ {
+ int new_max = level + 20;
+ if (small_ints == NULL)
+ small_ints = (tree*)xmalloc (new_max * sizeof(tree));
+ else
+ small_ints = (tree*)xrealloc (small_ints, new_max * sizeof(tree));
+ while (max_small_ints < new_max)
+ small_ints[max_small_ints++] = NULL_TREE;
+ }
+ if (small_ints[level] == NULL_TREE)
+ {
+ push_obstacks (&permanent_obstack, &permanent_obstack);
+ small_ints[level] = build_int_2 (level, 0);
+ pop_obstacks ();
+ }
+ /* set DECL_NESTING_LEVEL */
+ decl->decl.vindex = small_ints[level];
+ }
+}
+\f
+/* OPT_EXTERNAL is non-zero when the declaration is at module level.
+ * OPT_EXTERNAL == 2 means implicitly grant it.
+ */
+void
+do_decls (names, type, opt_static, lifetime_bound, opt_init, opt_external)
+ tree names;
+ tree type;
+ int opt_static;
+ int lifetime_bound;
+ tree opt_init;
+ int opt_external;
+{
+ if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
+ {
+ for (; names != NULL_TREE; names = TREE_CHAIN (names))
+ do_decl (TREE_VALUE (names), type, opt_static, lifetime_bound,
+ opt_init, opt_external);
+ }
+ else if (TREE_CODE (names) != ERROR_MARK)
+ do_decl (names, type, opt_static, lifetime_bound, opt_init, opt_external);
+}
+
+tree
+do_decl (name, type, is_static, lifetime_bound, opt_init, opt_external)
+ tree name, type;
+ int is_static;
+ int lifetime_bound;
+ tree opt_init;
+ int opt_external;
+{
+ tree decl;
+
+ if (current_function_decl == global_function_decl
+ && ! lifetime_bound /*&& opt_init != NULL_TREE*/)
+ seen_action = 1;
+
+ if (pass < 2)
+ {
+ push_obstacks (&permanent_obstack, &permanent_obstack);
+ decl = make_node (VAR_DECL);
+ DECL_NAME (decl) = name;
+ TREE_TYPE (decl) = type;
+ DECL_ASSEMBLER_NAME (decl) = name;
+
+ /* Try to put things in common when possible.
+ Tasking variables must go into common. */
+ DECL_COMMON (decl) = 1;
+ DECL_EXTERNAL (decl) = opt_external > 0;
+ TREE_PUBLIC (decl) = opt_external > 0;
+ TREE_STATIC (decl) = is_static;
+
+ if (pass == 0)
+ {
+ /* We have to set this here, since we build the decl w/o
+ calling `build_decl'. */
+ DECL_INITIAL (decl) = opt_init;
+ pushdecl (decl);
+ finish_decl (decl);
+ }
+ else
+ {
+ save_decl (decl);
+ pop_obstacks ();
+ }
+ DECL_INITIAL (decl) = opt_init;
+ if (opt_external > 1 || in_pseudo_module)
+ push_granted (DECL_NAME (decl), decl);
+ }
+ else /* pass == 2 */
+ {
+ tree temp = NULL_TREE;
+ int init_it = 0;
+
+ decl = get_next_decl ();
+
+ if (name != DECL_NAME (decl))
+ abort ();
+
+ type = TREE_TYPE (decl);
+
+ push_obstacks_nochange ();
+ if (TYPE_READONLY_PROPERTY (type))
+ {
+ if (CH_TYPE_NONVALUE_P (type))
+ {
+ error_with_decl (decl, "`%s' must not be declared readonly");
+ opt_init = NULL_TREE; /* prevent subsequent errors */
+ }
+ else if (opt_init == NULL_TREE && !opt_external)
+ error("declaration of readonly variable without initialization");
+ }
+ TREE_READONLY (decl) = TYPE_READONLY (type);
+
+ if (!opt_init && chill_varying_type_p (type))
+ {
+ tree fixed_part_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+ if (fixed_part_type != NULL_TREE && TREE_CODE (fixed_part_type) != ERROR_MARK)
+ {
+ if (CH_CHARS_TYPE_P (fixed_part_type))
+ opt_init = build_chill_string (0, "");
+ else
+ opt_init = build_nt (CONSTRUCTOR, NULL_TREE, NULL_TREE);
+ lifetime_bound = 1;
+ }
+ }
+
+ if (opt_init)
+ {
+ if (CH_TYPE_NONVALUE_P (type))
+ {
+ error_with_decl (decl,
+ "no initialisation allowed for `%s'");
+ temp = NULL_TREE;
+ }
+ else if (TREE_CODE (type) == REFERENCE_TYPE)
+ { /* A loc-identity declaration */
+ if (! CH_LOCATION_P (opt_init))
+ {
+ error_with_decl (decl,
+ "value for loc-identity `%s' is not a location");
+ temp = NULL_TREE;
+ }
+ else if (! CH_READ_COMPATIBLE (TREE_TYPE (type),
+ TREE_TYPE (opt_init)))
+ {
+ error_with_decl (decl,
+ "location for `%s' not read-compatible");
+ temp = NULL_TREE;
+ }
+ else
+ temp = convert (type, opt_init);
+ }
+ else
+ { /* Normal location declaration */
+ char place[80];
+ sprintf (place, "`%.60s' initializer",
+ IDENTIFIER_POINTER (DECL_NAME (decl)));
+ temp = chill_convert_for_assignment (type, opt_init, place);
+ }
+ }
+ else if (CH_TYPE_NONVALUE_P (type))
+ {
+ temp = NULL_TREE;
+ init_it = 1;
+ }
+ DECL_INITIAL (decl) = NULL_TREE;
+
+ if (temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK)
+ {
+ /* The same for stack variables (assuming no nested modules). */
+ if (lifetime_bound || !is_static)
+ {
+ if (is_static && ! TREE_CONSTANT (temp))
+ error_with_decl (decl, "nonconstant initializer for `%s'");
+ else
+ DECL_INITIAL (decl) = temp;
+ }
+ }
+ finish_decl (decl);
+ /* Initialize the variable unless initialized statically. */
+ if ((!is_static || ! lifetime_bound) &&
+ temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK)
+ {
+ int was_used = TREE_USED (decl);
+ emit_line_note (input_filename, lineno);
+ expand_expr_stmt (build_chill_modify_expr (decl, temp));
+ /* Don't let the initialization count as "using" the variable. */
+ TREE_USED (decl) = was_used;
+ if (current_function_decl == global_function_decl)
+ build_constructor = 1;
+ }
+ else if (init_it && TREE_CODE (type) != ERROR_MARK)
+ {
+ /* Initialize variables with non-value type */
+ int was_used = TREE_USED (decl);
+ int something_initialised = 0;
+
+ emit_line_note (input_filename, lineno);
+ if (TREE_CODE (type) == RECORD_TYPE)
+ something_initialised = init_nonvalue_struct (decl);
+ else if (TREE_CODE (type) == ARRAY_TYPE)
+ something_initialised = init_nonvalue_array (decl);
+ if (! something_initialised)
+ {
+ error ("do_decl: internal error: don't know what to initialize");
+ abort ();
+ }
+ /* Don't let the initialization count as "using" the variable. */
+ TREE_USED (decl) = was_used;
+ if (current_function_decl == global_function_decl)
+ build_constructor = 1;
+ }
+ }
+ return decl;
+}
+\f
+/*
+ * ARGTYPES is a tree_list of formal argument types. TREE_VALUE
+ * is the type tree for each argument, while the attribute is in
+ * TREE_PURPOSE.
+ */
+tree
+build_chill_function_type (return_type, argtypes, exceptions, recurse_p)
+ tree return_type, argtypes, exceptions, recurse_p;
+{
+ tree ftype, arg;
+
+ if (exceptions != NULL_TREE)
+ {
+ /* if we have exceptions we add 2 arguments, callers filename
+ and linenumber. These arguments will be added automatically
+ when calling a function which may raise exceptions. */
+ argtypes = chainon (argtypes,
+ build_tree_list (NULL_TREE, ridpointers[(int) RID_PTR]));
+ argtypes = chainon (argtypes,
+ build_tree_list (NULL_TREE, ridpointers[(int) RID_LONG]));
+}
+
+ /* Indicate the argument list is complete. */
+ argtypes = chainon (argtypes,
+ build_tree_list (NULL_TREE, void_type_node));
+
+ /* INOUT and OUT parameters must be a REFERENCE_TYPE since
+ we'll be passing a temporary's address at call time. */
+ for (arg = argtypes; arg; arg = TREE_CHAIN (arg))
+ if (TREE_PURPOSE (arg) == ridpointers[(int) RID_LOC]
+ || TREE_PURPOSE (arg) == ridpointers[(int) RID_OUT]
+ || TREE_PURPOSE (arg) == ridpointers[(int) RID_INOUT]
+ )
+ TREE_VALUE (arg) =
+ build_chill_reference_type (TREE_VALUE (arg));
+
+ /* Cannot use build_function_type, because if does hash-canonlicalization. */
+ ftype = make_node (FUNCTION_TYPE);
+ TREE_TYPE (ftype) = return_type ? return_type : void_type_node ;
+ TYPE_ARG_TYPES (ftype) = argtypes;
+
+ if (exceptions)
+ ftype = build_exception_variant (ftype, exceptions);
+
+ if (recurse_p)
+ sorry ("RECURSIVE PROCs");
+
+ return ftype;
+}
+\f
+/*
+ * ARGTYPES is a tree_list of formal argument types.
+ */
+tree
+push_extern_function (name, typespec, argtypes, exceptions, granting)
+ tree name, typespec, argtypes, exceptions;
+ int granting; /* If 0 do pushdecl(); if 1 do push_granted(). */
+{
+ tree ftype, fndecl;
+
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+
+ if (pass < 2)
+ {
+ ftype = build_chill_function_type (typespec, argtypes,
+ exceptions, NULL_TREE);
+
+ fndecl = build_decl (FUNCTION_DECL, name, ftype);
+
+ DECL_EXTERNAL(fndecl) = 1;
+ TREE_STATIC (fndecl) = 1;
+ TREE_PUBLIC (fndecl) = 1;
+ if (pass == 0)
+ {
+ pushdecl (fndecl);
+ finish_decl (fndecl);
+ }
+ else
+ {
+ save_decl (fndecl);
+ pop_obstacks ();
+ }
+ make_function_rtl (fndecl);
+ }
+ else
+ {
+ fndecl = get_next_decl ();
+ finish_decl (fndecl);
+ }
+#if 0
+
+ if (granting)
+ push_granted (name, decl);
+ else
+ pushdecl(decl);
+#endif
+ return fndecl;
+}
+
+
+\f
+void
+push_extern_process (name, argtypes, exceptions, granting)
+ tree name, argtypes, exceptions;
+ int granting;
+{
+ tree decl, func, arglist;
+
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+
+ if (pass < 2)
+ {
+ tree proc_struct = make_process_struct (name, argtypes);
+ arglist = (argtypes == NULL_TREE) ? NULL_TREE :
+ tree_cons (NULL_TREE,
+ build_chill_pointer_type (proc_struct), NULL_TREE);
+ }
+ else
+ arglist = NULL_TREE;
+
+ func = push_extern_function (name, NULL_TREE, arglist,
+ exceptions, granting);
+
+ /* declare the code variable */
+ decl = generate_tasking_code_variable (name, &process_type, 1);
+ CH_DECL_PROCESS (func) = 1;
+ /* remember the code variable in the function decl */
+ DECL_TASKING_CODE_DECL (func) = (struct lang_decl *)decl;
+
+ add_taskstuff_to_list (decl, "_TT_Process", NULL_TREE, func, NULL_TREE);
+}
+\f
+void
+push_extern_signal (signame, sigmodelist, optsigdest)
+ tree signame, sigmodelist, optsigdest;
+{
+ tree decl, sigtype;
+
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+
+ sigtype =
+ build_signal_struct_type (signame, sigmodelist, optsigdest);
+
+ /* declare the code variable outside the process */
+ decl = generate_tasking_code_variable (signame, &signal_code, 1);
+ add_taskstuff_to_list (decl, "_TT_Signal", NULL_TREE, sigtype, NULL_TREE);
+}
+\f
+void
+print_mode (mode)
+ tree mode;
+{
+ while (mode != NULL_TREE)
+ {
+ switch (TREE_CODE (mode))
+ {
+ case POINTER_TYPE:
+ printf (" REF ");
+ mode = TREE_TYPE (mode);
+ break;
+ case INTEGER_TYPE:
+ case REAL_TYPE:
+ printf (" %s ", IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (mode))));
+ mode = NULL_TREE;
+ break;
+ case ARRAY_TYPE:
+ {
+ tree itype = TYPE_DOMAIN (mode);
+ if (CH_STRING_TYPE_P (mode))
+ printf (" STRING (%d) OF ",
+ TREE_INT_CST_LOW (TYPE_MAX_VALUE (itype)));
+ else
+ printf (" ARRAY (%d:%d) OF ",
+ TREE_INT_CST_LOW (TYPE_MIN_VALUE (itype)),
+ TREE_INT_CST_LOW (TYPE_MAX_VALUE (itype)));
+ mode = TREE_TYPE (mode);
+ break;
+ }
+ case RECORD_TYPE:
+ {
+ tree fields = TYPE_FIELDS (mode);
+ printf (" RECORD (");
+ while (fields != NULL_TREE)
+ {
+ printf (" %s:", IDENTIFIER_POINTER (DECL_NAME (fields)));
+ print_mode (TREE_TYPE (fields));
+ if (TREE_CHAIN (fields))
+ printf (",");
+ fields = TREE_CHAIN (fields);
+ }
+ printf (")");
+ mode = NULL_TREE;
+ break;
+ }
+ default:
+ abort ();
+ }
+ }
+}
+\f
+tree
+chill_munge_params (nodes, type, attr)
+ tree nodes, type, attr;
+{
+ tree node;
+ if (pass == 1)
+ {
+ /* Convert the list of identifiers to a list of types. */
+ for (node = nodes; node != NULL_TREE; node = TREE_CHAIN (node))
+ {
+ TREE_VALUE (node) = type; /* this was the identifier node */
+ TREE_PURPOSE (node) = attr;
+ }
+ }
+ return nodes;
+}
+
+/* Push the declarations described by SYN_DEFS into the current scope. */
+void
+push_syndecl (name, mode, value)
+ tree name, mode, value;
+{
+ if (pass == 1)
+ {
+ tree decl = make_node (CONST_DECL);
+ DECL_NAME (decl) = name;
+ DECL_ASSEMBLER_NAME (decl) = name;
+ TREE_TYPE (decl) = mode;
+ DECL_INITIAL (decl) = value;
+ TREE_READONLY (decl) = 1;
+ save_decl (decl);
+ if (in_pseudo_module)
+ push_granted (DECL_NAME (decl), decl);
+ }
+ else /* pass == 2 */
+ get_next_decl ();
+}
+
+
+\f
+/* Push the declarations described by (MODENAME,MODE) into the current scope.
+ MAKE_NEWMODE is 1 for NEWMODE, 0 for SYNMODE, and
+ -1 for internal use (in which case the mode does not need to be copied). */
+
+tree
+push_modedef (modename, mode, make_newmode)
+ tree modename;
+ tree mode; /* ignored if pass==2. */
+ int make_newmode;
+{
+ tree newdecl, newmode;
+
+ if (pass == 1)
+ {
+ /* FIXME: need to check here for SYNMODE fred fred; */
+ push_obstacks (&permanent_obstack, &permanent_obstack);
+
+ newdecl = build_lang_decl (TYPE_DECL, modename, mode);
+
+ if (make_newmode >= 0)
+ {
+ newmode = make_node (LANG_TYPE);
+ TREE_TYPE (newmode) = mode;
+ TREE_TYPE (newdecl) = newmode;
+ TYPE_NAME (newmode) = newdecl;
+ if (make_newmode > 0)
+ CH_NOVELTY (newmode) = newdecl;
+ }
+
+ save_decl (newdecl);
+ pop_obstacks ();
+
+ }
+ else /* pass == 2 */
+ {
+ /* FIXME: need to check here for SYNMODE fred fred; */
+ newdecl = get_next_decl ();
+ if (DECL_NAME (newdecl) != modename)
+ abort ();
+ if (TREE_CODE (TREE_TYPE (newdecl)) != ERROR_MARK)
+ {
+ /* ASSOCIATION, ACCESS, TEXT, BUFFER, and EVENT must not be READOnly */
+ if (TREE_READONLY (TREE_TYPE (newdecl)) &&
+ (CH_IS_ASSOCIATION_MODE (TREE_TYPE (newdecl)) ||
+ CH_IS_ACCESS_MODE (TREE_TYPE (newdecl)) ||
+ CH_IS_TEXT_MODE (TREE_TYPE (newdecl)) ||
+ CH_IS_BUFFER_MODE (TREE_TYPE (newdecl)) ||
+ CH_IS_EVENT_MODE (TREE_TYPE (newdecl))))
+ error_with_decl (newdecl, "`%s' must not be READonly");
+ rest_of_decl_compilation (newdecl, NULL_PTR,
+ global_bindings_p (), 0);
+ }
+ }
+ return newdecl;
+}
+\f
+/* Return a chain of FIELD_DECLs for the names in NAMELIST. All of
+ of type TYPE. When NAMELIST is passed in from the parser, it is
+ in reverse order.
+ LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
+ meaning (default, pack, nopack, POS (...) ). */
+
+tree
+grok_chill_fixedfields (namelist, type, layout)
+ tree namelist, type;
+ tree layout;
+{
+ tree decls = NULL_TREE;
+
+ if (layout != NULL_TREE && TREE_CHAIN (namelist) != NULL_TREE)
+ {
+ if (layout != integer_one_node && layout != integer_zero_node)
+ {
+ layout = NULL_TREE;
+ error ("POS may not be specified for a list of field declarations");
+ }
+ }
+
+ /* we build the chain of FIELD_DECLs backwards, effectively
+ unreversing the reversed names in NAMELIST. */
+ for (; namelist; namelist = TREE_CHAIN (namelist))
+ {
+ tree decl = build_decl (FIELD_DECL,
+ TREE_VALUE (namelist), type);
+ DECL_INITIAL (decl) = layout;
+ TREE_CHAIN (decl) = decls;
+ decls = decl;
+ }
+
+ return decls;
+}
+\f
+struct tree_pair
+{
+ tree value;
+ tree decl;
+};
+
+
+/* Function to help qsort sort variant labels by value order. */
+static int
+label_value_cmp (x, y)
+ struct tree_pair *x, *y;
+{
+ return TREE_INT_CST_LOW (x->value) - TREE_INT_CST_LOW (y->value);
+}
+\f
+tree
+make_chill_variants (tagfields, body, variantelse)
+ tree tagfields;
+ tree body;
+ tree variantelse;
+{
+ tree utype;
+ tree first = NULL_TREE;
+ for (; body; body = TREE_CHAIN (body))
+ {
+ tree decls = TREE_VALUE (body);
+ tree labellist = TREE_PURPOSE (body);
+
+ if (labellist != NULL_TREE
+ && TREE_CODE (TREE_VALUE (labellist)) == TREE_LIST
+ && TREE_VALUE (TREE_VALUE (labellist)) == case_else_node
+ && TREE_CHAIN (labellist) == NULL_TREE)
+ {
+ if (variantelse)
+ error ("(ELSE) case label as well as ELSE variant");
+ variantelse = decls;
+ }
+ else
+ {
+ tree rtype = start_struct (RECORD_TYPE, NULL_TREE);
+ rtype = finish_struct (rtype, decls);
+
+ first = chainon (first, build_decl (FIELD_DECL, NULL_TREE, rtype));
+
+ TYPE_TAG_VALUES (rtype) = labellist;
+ }
+ }
+
+ if (variantelse != NULL_TREE)
+ {
+ tree rtype = start_struct (RECORD_TYPE, NULL_TREE);
+ rtype = finish_struct (rtype, variantelse);
+ first = chainon (first,
+ build_decl (FIELD_DECL,
+ ELSE_VARIANT_NAME, rtype));
+ }
+
+ utype = start_struct (UNION_TYPE, NULL_TREE);
+ utype = finish_struct (utype, first);
+ TYPE_TAGFIELDS (utype) = tagfields;
+ return utype;
+}
+\f
+tree
+layout_chill_variants (utype)
+ tree utype;
+{
+ tree first = TYPE_FIELDS (utype);
+ int nlabels = 0, label_index = 0;
+ struct tree_pair *label_value_array;
+ tree decl;
+ extern int errorcount;
+
+ if (TYPE_SIZE (utype))
+ return utype;
+
+ for (decl = first; decl; decl = TREE_CHAIN (decl))
+ {
+ tree tagfields = TYPE_TAGFIELDS (utype);
+ tree t = TREE_TYPE (decl);
+ tree taglist = TYPE_TAG_VALUES (t);
+ if (DECL_NAME (decl) == ELSE_VARIANT_NAME)
+ continue;
+ if (tagfields == NULL_TREE)
+ continue;
+ for ( ; tagfields != NULL_TREE && taglist != NULL_TREE;
+ tagfields = TREE_CHAIN (tagfields), taglist = TREE_CHAIN (taglist))
+ {
+ tree labellist = TREE_VALUE (taglist);
+ for (; labellist; labellist = TREE_CHAIN (labellist))
+ {
+ int compat_error = 0;
+ tree label_value = TREE_VALUE (labellist);
+ if (TREE_CODE (label_value) == RANGE_EXPR)
+ {
+ if (TREE_OPERAND (label_value, 0) != NULL_TREE)
+ {
+ if (!CH_COMPATIBLE (TREE_OPERAND (label_value, 0),
+ TREE_TYPE (TREE_VALUE (tagfields)))
+ || !CH_COMPATIBLE (TREE_OPERAND (label_value, 1),
+ TREE_TYPE (TREE_VALUE (tagfields))))
+ compat_error = 1;
+ }
+ }
+ else if (TREE_CODE (label_value) == TYPE_DECL)
+ {
+ if (!CH_COMPATIBLE (label_value,
+ TREE_TYPE (TREE_VALUE (tagfields))))
+ compat_error = 1;
+ }
+ else if (TREE_CODE (label_value) == INTEGER_CST)
+ {
+ if (!CH_COMPATIBLE (label_value,
+ TREE_TYPE (TREE_VALUE (tagfields))))
+ compat_error = 1;
+ }
+ if (compat_error)
+ {
+ if (TYPE_FIELDS (t) == NULL_TREE)
+ error ("inconsistent modes between labels and tag field");
+ else
+ error_with_decl (TYPE_FIELDS (t),
+ "inconsistent modes between labels and tag field");
+ }
+ nlabels++;
+ }
+ }
+ if (tagfields != NULL_TREE)
+ error ("too few tag labels");
+ if (taglist != NULL_TREE)
+ error ("too many tag labels");
+ }
+
+ /* Check for duplicate label values. */
+ label_value_array = (struct tree_pair *)alloca (nlabels * sizeof (struct tree_pair));
+ for (decl = first; decl; decl = TREE_CHAIN (decl))
+ {
+ tree t = TREE_TYPE (decl);
+ /* Only one tag (first case_label_list) supported, for now. */
+ tree labellist = TYPE_TAG_VALUES (t);
+ if (labellist)
+ labellist = TREE_VALUE (labellist);
+
+ for (; labellist != NULL_TREE; labellist = TREE_CHAIN (labellist))
+ {
+ struct tree_pair p;
+
+ tree x = TREE_VALUE (labellist);
+ if (TREE_CODE (x) == RANGE_EXPR)
+ {
+ if (TREE_OPERAND (x, 0) != NULL_TREE)
+ {
+ if (TREE_CODE (TREE_OPERAND (x, 0)) != INTEGER_CST)
+ error ("case label lower limit is not a discrete constant expression");
+ if (TREE_CODE (TREE_OPERAND (x, 1)) != INTEGER_CST)
+ error ("case label upper limit is not a discrete constant expression");
+ }
+ continue;
+ }
+ else if (TREE_CODE (x) == TYPE_DECL)
+ continue;
+ else if (TREE_CODE (x) == ERROR_MARK)
+ continue;
+ else if (TREE_CODE (x) != INTEGER_CST) /* <-- FIXME: what about CONST_DECLs? */
+ {
+ error ("case label must be a discrete constant expression");
+ continue;
+ }
+
+ if (TREE_CODE (x) == CONST_DECL)
+ x = DECL_INITIAL (x);
+ if (TREE_CODE (x) != INTEGER_CST) abort ();
+ p.value = x;
+ p.decl = decl;
+ if (p.decl == NULL_TREE)
+ p.decl = TREE_VALUE (labellist);
+ label_value_array[label_index++] = p;
+ }
+ }
+ if (errorcount == 0)
+ {
+ int limit;
+ qsort (label_value_array,
+ label_index, sizeof (struct tree_pair), label_value_cmp);
+ limit = label_index - 1;
+ for (label_index = 0; label_index < limit; label_index++)
+ {
+ if (tree_int_cst_equal (label_value_array[label_index].value,
+ label_value_array[label_index+1].value))
+ {
+ error_with_decl (label_value_array[label_index].decl,
+ "variant label declared here...");
+ error_with_decl (label_value_array[label_index+1].decl,
+ "...is duplicated here");
+ }
+ }
+ }
+ layout_type (utype);
+ return utype;
+}
+\f
+/* Convert a TREE_LIST of tag field names into a list of
+ field decls, found from FIXED_FIELDS, re-using the input list. */
+
+tree
+lookup_tag_fields (tag_field_names, fixed_fields)
+ tree tag_field_names;
+ tree fixed_fields;
+{
+ tree list;
+ for (list = tag_field_names; list != NULL_TREE; list = TREE_CHAIN (list))
+ {
+ tree decl = fixed_fields;
+ for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl))
+ {
+ if (DECL_NAME (decl) == TREE_VALUE (list))
+ {
+ TREE_VALUE (list) = decl;
+ break;
+ }
+ }
+ if (decl == NULL_TREE)
+ {
+ error ("no field (yet) for tag %s",
+ IDENTIFIER_POINTER (TREE_VALUE (list)));
+ TREE_VALUE (list) = error_mark_node;
+ }
+ }
+ return tag_field_names;
+}
+
+/* If non-NULL, TAGFIELDS is the tag fields for this variant record.
+ BODY is a TREE_LIST of (optlabels, fixed fields).
+ If non-null, VARIANTELSE is a fixed field for the else part of the
+ variant record. */
+
+tree
+grok_chill_variantdefs (tagfields, body, variantelse)
+ tree tagfields, body, variantelse;
+{
+ tree t;
+
+ t = make_chill_variants (tagfields, body, variantelse);
+ if (pass != 1)
+ t = layout_chill_variants (t);
+ return build_decl (FIELD_DECL, NULL_TREE, t);
+}
+\f
+/*
+ In pass 1, PARMS is a list of types (with attributes).
+ In pass 2, PARMS is a chain of PARM_DECLs.
+ */
+
+int
+start_chill_function (label, rtype, parms, exceptlist, attrs)
+ tree label, rtype, parms, exceptlist, attrs;
+{
+ tree decl, fndecl, type, result_type, func_type;
+ int nested = current_function_decl != 0;
+ if (pass == 1)
+ {
+ func_type
+ = build_chill_function_type (rtype, parms, exceptlist, 0);
+ fndecl = build_decl (FUNCTION_DECL, label, func_type);
+
+ save_decl (fndecl);
+
+ /* Make the init_value nonzero so pushdecl knows this is not tentative.
+ error_mark_node is replaced below (in poplevel) with the BLOCK. */
+ DECL_INITIAL (fndecl) = error_mark_node;
+
+ DECL_EXTERNAL (fndecl) = 0;
+
+ /* This function exists in static storage.
+ (This does not mean `static' in the C sense!) */
+ TREE_STATIC (fndecl) = 1;
+
+ for (; attrs != NULL_TREE; attrs = TREE_CHAIN (attrs))
+ {
+ if (TREE_VALUE (attrs) == ridpointers[RID_GENERAL])
+ CH_DECL_GENERAL (fndecl) = 1;
+ else if (TREE_VALUE (attrs) == ridpointers[RID_SIMPLE])
+ CH_DECL_SIMPLE (fndecl) = 1;
+ else if (TREE_VALUE (attrs) == ridpointers[RID_RECURSIVE])
+ CH_DECL_RECURSIVE (fndecl) = 1;
+ else if (TREE_VALUE (attrs) == ridpointers[RID_INLINE])
+ DECL_INLINE (fndecl) = 1;
+ else
+ abort ();
+ }
+ }
+ else /* pass == 2 */
+ {
+ fndecl = get_next_decl ();
+ if (DECL_NAME (fndecl) != label)
+ abort (); /* outta sync - got wrong decl */
+ func_type = TREE_TYPE (fndecl);
+ if (TYPE_RAISES_EXCEPTIONS (func_type) != NULL_TREE)
+ {
+ /* In this case we have to add 2 parameters.
+ See build_chill_function_type (pass == 1). */
+ tree arg;
+
+ arg = make_node (PARM_DECL);
+ DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_FILE);
+ DECL_IGNORED_P (arg) = 1;
+ parms = chainon (parms, arg);
+
+ arg = make_node (PARM_DECL);
+ DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_LINE);
+ DECL_IGNORED_P (arg) = 1;
+ parms = chainon (parms, arg);
+ }
+ }
+
+ current_function_decl = fndecl;
+ result_type = TREE_TYPE (func_type);
+ if (CH_TYPE_NONVALUE_P (result_type))
+ error ("non-value mode may only returned by LOC");
+
+ pushlevel (1); /* Push parameters. */
+
+ if (pass == 2)
+ {
+ DECL_ARGUMENTS (fndecl) = parms;
+ for (decl = DECL_ARGUMENTS (fndecl), type = TYPE_ARG_TYPES (func_type);
+ decl != NULL_TREE;
+ decl = TREE_CHAIN (decl), type = TREE_CHAIN (type))
+ {
+ /* check here that modes with the non-value property (like
+ BUFFER's, EVENT's, ASSOCIATION's, ACCESS's, or TEXT's) only
+ gets passed by LOC */
+ tree argtype = TREE_VALUE (type);
+ tree argattr = TREE_PURPOSE (type);
+
+ if (TREE_CODE (argtype) == REFERENCE_TYPE)
+ argtype = TREE_TYPE (argtype);
+
+ if (TREE_CODE (argtype) != ERROR_MARK &&
+ TREE_CODE_CLASS (TREE_CODE (argtype)) != 't')
+ {
+ error_with_decl (decl, "mode of `%s' is not a mode");
+ TREE_VALUE (type) = error_mark_node;
+ }
+
+ if (CH_TYPE_NONVALUE_P (argtype) &&
+ argattr != ridpointers[(int) RID_LOC])
+ error_with_decl (decl, "`%s' may only be passed by LOC");
+ TREE_TYPE (decl) = TREE_VALUE (type);
+ DECL_ARG_TYPE (decl) = TREE_TYPE (decl);
+ DECL_CONTEXT (decl) = fndecl;
+ TREE_READONLY (decl) = TYPE_READONLY (argtype);
+ layout_decl (decl, 0);
+ }
+
+ pushdecllist (DECL_ARGUMENTS (fndecl), 0);
+
+ DECL_RESULT (current_function_decl)
+ = build_decl (RESULT_DECL, NULL_TREE, result_type);
+
+#if 0
+ /* Write a record describing this function definition to the prototypes
+ file (if requested). */
+ gen_aux_info_record (fndecl, 1, 0, prototype);
+#endif
+
+ if (fndecl != global_function_decl || seen_action)
+ {
+ /* Initialize the RTL code for the function. */
+ init_function_start (fndecl, input_filename, lineno);
+
+ /* Set up parameters and prepare for return, for the function. */
+ expand_function_start (fndecl, 0);
+ }
+
+ if (!nested)
+ /* Allocate further tree nodes temporarily during compilation
+ of this function only. */
+ temporary_allocation ();
+
+ /* If this fcn was already referenced via a block-scope `extern' decl (or
+ an implicit decl), propagate certain information about the usage. */
+ if (TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (current_function_decl)))
+ TREE_ADDRESSABLE (current_function_decl) = 1;
+ }
+
+ /* Z.200 requires that formal parameter names be defined in
+ the same block as the procedure body.
+ We could do this by keeping boths sets of DECLs in the same
+ scope, but we would have to be careful to not merge the
+ two chains (e.g. DECL_ARGUEMENTS musr not contains locals).
+ Instead, we just make sure they have the same nesting_level. */
+ current_nesting_level--;
+ pushlevel (1); /* Push local variables. */
+
+ if (pass == 2 && (fndecl != global_function_decl || seen_action))
+ {
+ /* generate label for possible 'exit' */
+ expand_start_bindings (1);
+
+ result_never_set = 1;
+ }
+
+ if (TREE_CODE (result_type) == VOID_TYPE)
+ chill_result_decl = NULL_TREE;
+ else
+ {
+ /* We use the same name as the keyword.
+ This makes it easy to print and change the RESULT from gdb. */
+ char *result_str = (ignore_case || ! special_UC) ? "result" : "RESULT";
+ if (pass == 2 && TREE_CODE (result_type) == ERROR_MARK)
+ TREE_TYPE (current_scope->remembered_decls) = result_type;
+ chill_result_decl = do_decl (get_identifier (result_str),
+ result_type, 0, 0, 0, 0);
+ DECL_CONTEXT (chill_result_decl) = fndecl;
+ }
+
+ return 1;
+}
+\f
+/* For checking purpose added pname as new argument
+ MW Wed Oct 14 14:22:10 1992 */
+void
+finish_chill_function ()
+{
+ register tree fndecl = current_function_decl;
+ tree outer_function = decl_function_context (fndecl);
+ int nested;
+ if (outer_function == NULL_TREE && fndecl != global_function_decl)
+ outer_function = global_function_decl;
+ nested = current_function_decl != global_function_decl;
+ if (pass == 2 && (fndecl != global_function_decl || seen_action))
+ expand_end_bindings (getdecls (), 1, 0);
+
+ /* pop out of function */
+ poplevel (1, 1, 0);
+ current_nesting_level++;
+ /* pop out of its parameters */
+ poplevel (1, 0, 1);
+
+ if (pass == 2)
+ {
+ /* TREE_READONLY (fndecl) = 1;
+ This caused &foo to be of type ptr-to-const-function which
+ then got a warning when stored in a ptr-to-function variable. */
+
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+
+ /* Must mark the RESULT_DECL as being in this function. */
+
+ DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
+
+ if (fndecl != global_function_decl || seen_action)
+ {
+ /* Generate rtl for function exit. */
+ expand_function_end (input_filename, lineno, 0);
+
+ /* So we can tell if jump_optimize sets it to 1. */
+ can_reach_end = 0;
+
+ /* Run the optimizers and output assembler code for this function. */
+ rest_of_compilation (fndecl);
+ }
+
+ if (DECL_SAVED_INSNS (fndecl) == 0 && ! nested)
+ {
+ /* Stop pointing to the local nodes about to be freed. */
+ /* But DECL_INITIAL must remain nonzero so we know this
+ was an actual function definition. */
+ /* For a nested function, this is done in pop_chill_function_context. */
+ DECL_INITIAL (fndecl) = error_mark_node;
+ DECL_ARGUMENTS (fndecl) = 0;
+ }
+ }
+ current_function_decl = outer_function;
+}
+\f
+/* process SEIZE */
+
+/* Points to the head of the _DECLs read from seize files. */
+#if 0
+static tree seized_decls;
+
+static tree processed_seize_files = 0;
+#endif
+
+void
+chill_seize (old_prefix, new_prefix, postfix)
+ tree old_prefix, new_prefix, postfix;
+{
+ if (pass == 1)
+ {
+ tree decl = build_alias_decl (old_prefix, new_prefix, postfix);
+ DECL_SEIZEFILE(decl) = use_seizefile_name;
+ save_decl (decl);
+ }
+ else /* pass == 2 */
+ {
+ /* Do nothing - get_next_decl automatically ignores ALIAS_DECLs */
+ }
+}
+#if 0
+\f
+/*
+ * output a debug dump of a scope structure
+ */
+void
+debug_scope (sp)
+ struct scope *sp;
+{
+ if (sp == (struct scope *)NULL)
+ {
+ fprintf (stderr, "null scope ptr\n");
+ return;
+ }
+ fprintf (stderr, "enclosing 0x%x ", sp->enclosing);
+ fprintf (stderr, "next 0x%x ", sp->next);
+ fprintf (stderr, "remembered_decls 0x%x ", sp->remembered_decls);
+ fprintf (stderr, "decls 0x%x\n", sp->decls);
+ fprintf (stderr, "shadowed 0x%x ", sp->shadowed);
+ fprintf (stderr, "blocks 0x%x ", sp->blocks);
+ fprintf (stderr, "this_block 0x%x ", sp->this_block);
+ fprintf (stderr, "level_chain 0x%x\n", sp->level_chain);
+ fprintf (stderr, "module_flag %c ", sp->module_flag ? 'T' : 'F');
+ fprintf (stderr, "first_child_module 0x%x ", sp->first_child_module);
+ fprintf (stderr, "next_sibling_module 0x%x\n", sp->next_sibling_module);
+ if (sp->remembered_decls != NULL_TREE)
+ {
+ tree temp;
+ fprintf (stderr, "remembered_decl chain:\n");
+ for (temp = sp->remembered_decls; temp; temp = TREE_CHAIN (temp))
+ debug_tree (temp);
+ }
+}
+#endif
+\f
+static void
+save_decl (decl)
+ tree decl;
+{
+ if (current_function_decl != global_function_decl)
+ DECL_CONTEXT (decl) = current_function_decl;
+
+ TREE_CHAIN (decl) = current_scope->remembered_decls;
+ current_scope->remembered_decls = decl;
+#if 0
+ fprintf (stderr, "\n\nsave_decl 0x%x\n", decl);
+ debug_scope (current_scope); /* ************* */
+#endif
+ set_nesting_level (decl, current_nesting_level);
+}
+
+static tree
+get_next_decl ()
+{
+ tree decl;
+ do
+ {
+ decl = current_scope->remembered_decls;
+ current_scope->remembered_decls = TREE_CHAIN (decl);
+ /* We ignore ALIAS_DECLs, because push_scope_decls
+ can convert a single ALIAS_DECL representing 'SEIZE ALL'
+ into one ALIAS_DECL for each seizeable name.
+ This means we lose the nice one-to-one mapping
+ between pass 1 decls and pass 2 decls.
+ (Perhaps ALIAS_DECLs should not be on the remembered_decls list.) */
+ } while (decl && TREE_CODE (decl) == ALIAS_DECL);
+ return decl;
+}
+
+/* At the end of pass 1, we reverse the chronological chain of scopes. */
+
+void
+switch_to_pass_2 ()
+{
+ extern int errorcount, sorrycount;
+ if (current_scope != &builtin_scope)
+ abort ();
+ last_scope = &builtin_scope;
+ builtin_scope.remembered_decls = nreverse (builtin_scope.remembered_decls);
+ write_grant_file ();
+
+#if 0
+ if (errorcount || sorrycount)
+ exit (FATAL_EXIT_CODE);
+ else
+#endif
+ if (grant_only_flag)
+ exit (SUCCESS_EXIT_CODE);
+
+ pass = 2;
+ module_number = 0;
+ next_module = &first_module;
+}
+\f
+/*
+ * Called during pass 2, when we're processing actions, to
+ * generate a temporary variable. These don't need satisfying
+ * because they're compiler-generated and always declared
+ * before they're used.
+ */
+tree
+decl_temp1 (name, type, opt_static, opt_init,
+ opt_external, opt_public)
+ tree name, type;
+ int opt_static;
+ tree opt_init;
+ int opt_external, opt_public;
+{
+ int orig_pass = pass; /* be cautious */
+ tree mydecl;
+
+ pass = 1;
+ mydecl = do_decl (name, type, opt_static, opt_static,
+ opt_init, opt_external);
+
+ if (opt_public)
+ TREE_PUBLIC (mydecl) = 1;
+ pass = 2;
+ do_decl (name, type, opt_static, opt_static, opt_init, opt_external);
+
+ pass = orig_pass;
+ return mydecl;
+}
+\f
+/* True if we're reading a seizefile, but we haven't seen a SPEC MODULE yet.
+ For backwards compatibility, we treat declarations in such a context
+ as implicity granted. */
+
+tree
+set_module_name (name)
+ tree name;
+{
+ module_number++;
+ if (name == NULL_TREE)
+ {
+ /* NOTE: build_prefix_clause assumes a generated
+ module starts with a '_'. */
+ char buf[20];
+ sprintf (buf, "_MODULE_%d", module_number);
+ name = get_identifier (buf);
+ }
+ return name;
+}
+
+tree
+push_module (name, is_spec_module)
+ tree name;
+ int is_spec_module;
+{
+ struct module *new_module;
+ if (pass == 1)
+ {
+ new_module = (struct module*) permalloc (sizeof (struct module));
+ new_module->prev_module = current_module;
+
+ *next_module = new_module;
+ }
+ else
+ {
+ new_module = *next_module;
+ }
+ next_module = &new_module->next_module;
+
+ new_module->procedure_seen = 0;
+ new_module->is_spec_module = is_spec_module;
+ new_module->name = name;
+ if (current_module)
+ new_module->prefix_name
+ = get_identifier3 (IDENTIFIER_POINTER (current_module->prefix_name),
+ "__", IDENTIFIER_POINTER (name));
+ else
+ new_module->prefix_name = name;
+
+ new_module->granted_decls = NULL_TREE;
+ new_module->nesting_level = current_nesting_level + 1;
+
+ current_module = new_module;
+ current_module_nesting_level = new_module->nesting_level;
+ in_pseudo_module = name ? 0 : 1;
+
+ pushlevel (1);
+
+ current_scope->module_flag = 1;
+
+ *current_scope->enclosing->tail_child_module = current_scope;
+ current_scope->enclosing->tail_child_module
+ = ¤t_scope->next_sibling_module;
+
+ /* Rename the global function to have the same name as
+ the first named non-spec module. */
+ if (!is_spec_module
+ && IDENTIFIER_POINTER (name)[0] != '_'
+ && IDENTIFIER_POINTER (DECL_NAME (global_function_decl))[0] == '_')
+ {
+ tree fname = get_identifier3 ("", IDENTIFIER_POINTER (name), "_");
+ DECL_NAME (global_function_decl) = fname;
+ DECL_ASSEMBLER_NAME (global_function_decl) = fname;
+ }
+
+ return name; /* may have generated a name */
+}
+/* Make a copy of the identifier NAME, replacing each '!' by '__'. */
+tree
+fix_identifier (name)
+ tree name;
+{
+ char *buf = (char*)alloca (2 * IDENTIFIER_LENGTH (name) + 1);
+ int fixed = 0;
+ register char *dptr = buf;
+ register char *sptr = IDENTIFIER_POINTER (name);
+ for (; *sptr; sptr++)
+ {
+ if (*sptr == '!')
+ {
+ *dptr++ = '_';
+ *dptr++ = '_';
+ fixed++;
+ }
+ else
+ *dptr++ = *sptr;
+ }
+ *dptr = '\0';
+ return fixed ? get_identifier (buf) : name;
+}
+\f
+void
+find_granted_decls ()
+{
+ if (pass == 1)
+ {
+ /* Match each granted name to a granted decl. */
+
+ tree alias = current_module->granted_decls;
+ tree next_alias, decl;
+ /* This is an O(M*N) algorithm. FIXME! */
+ for (; alias; alias = next_alias)
+ {
+ int found = 0;
+ next_alias = TREE_CHAIN (alias);
+ for (decl = current_scope->remembered_decls;
+ decl; decl = TREE_CHAIN (decl))
+ {
+ tree new_name = (! DECL_NAME (decl)) ? NULL_TREE :
+ decl_check_rename (alias,
+ DECL_NAME (decl));
+
+ if (!new_name)
+ continue;
+ /* A Seized declaration is not grantable. */
+ if (TREE_CODE (decl) == ALIAS_DECL && !CH_DECL_GRANTED (decl))
+ continue;
+ found = 1;
+ if (global_bindings_p ())
+ TREE_PUBLIC (decl) = 1;
+ if (DECL_ASSEMBLER_NAME (decl) == NULL_TREE)
+ DECL_ASSEMBLER_NAME (decl) = fix_identifier (new_name);
+ if (DECL_POSTFIX_ALL (alias))
+ {
+ tree new_alias
+ = build_alias_decl (NULL_TREE, NULL_TREE, new_name);
+ TREE_CHAIN (new_alias) = TREE_CHAIN (alias);
+ TREE_CHAIN (alias) = new_alias;
+ DECL_ABSTRACT_ORIGIN (new_alias) = decl;
+ DECL_SOURCE_LINE (new_alias) = 0;
+ DECL_SEIZEFILE (new_alias) = DECL_SEIZEFILE (alias);
+ }
+ else
+ {
+ DECL_ABSTRACT_ORIGIN (alias) = decl;
+ break;
+ }
+ }
+ if (!found)
+ {
+ error_with_decl (alias, "Nothing named `%s' to grant.");
+ DECL_ABSTRACT_ORIGIN (alias) = error_mark_node;
+ }
+ }
+ }
+}
+
+void
+pop_module ()
+{
+ tree decl;
+ struct scope *module_scope = current_scope;
+
+ poplevel (0, 0, 0);
+
+ if (pass == 1)
+ {
+ /* Write out the grant file. */
+ if (!current_module->is_spec_module)
+ {
+ /* After reversal, TREE_CHAIN (last_old_decl) is the oldest
+ decl of the current module. */
+ write_spec_module (module_scope->remembered_decls,
+ current_module->granted_decls);
+ }
+
+ /* Move the granted decls into the enclosing scope. */
+ if (current_scope == global_scope)
+ {
+ tree next_decl;
+ for (decl = current_module->granted_decls; decl; decl = next_decl)
+ {
+ tree name = DECL_NAME (decl);
+ next_decl = TREE_CHAIN (decl);
+ if (name != NULL_TREE)
+ {
+ tree old_decl = IDENTIFIER_OUTER_VALUE (name);
+ set_nesting_level (decl, current_nesting_level);
+ if (old_decl != NULL_TREE)
+ {
+ pedwarn_with_decl (decl, "duplicate grant for `%s'");
+ pedwarn_with_decl (old_decl, "previous grant for `%s'");
+ TREE_CHAIN (decl) = TREE_CHAIN (old_decl);
+ TREE_CHAIN (old_decl) = decl;
+ }
+ else
+ {
+ TREE_CHAIN (decl) = outer_decls;
+ outer_decls = decl;
+ IDENTIFIER_OUTER_VALUE (name) = decl;
+ }
+ }
+ }
+ }
+ else
+ current_scope->granted_decls = chainon (current_module->granted_decls,
+ current_scope->granted_decls);
+ }
+
+ chill_check_no_handlers (); /* Sanity test */
+ current_module = current_module->prev_module;
+ current_module_nesting_level = current_module ?
+ current_module->nesting_level : 0;
+ in_pseudo_module = 0;
+}
+\f
+/* Nonzero if we are currently in the global binding level. */
+
+int
+global_bindings_p ()
+{
+ /* We return -1 here for the sake of variable_size() in ../stor-layout.c. */
+ return (current_function_decl == NULL_TREE
+ || current_function_decl == global_function_decl) ? -1 : 0;
+}
+
+/* Nonzero if the current level needs to have a BLOCK made. */
+
+int
+kept_level_p ()
+{
+ return current_scope->decls != 0;
+}
+
+/* Make DECL visible.
+ Save any existing definition.
+ Check redefinitions at the same level.
+ Suppress error messages if QUIET is true. */
+
+void
+proclaim_decl (decl, quiet)
+ tree decl;
+ int quiet;
+{
+ tree name = DECL_NAME (decl);
+ if (name)
+ {
+ tree old_decl = IDENTIFIER_LOCAL_VALUE (name);
+ if (old_decl == NULL) ; /* No duplication */
+ else if (DECL_NESTING_LEVEL (old_decl) != current_nesting_level)
+ {
+ /* Record for restoration when this binding level ends. */
+ current_scope->shadowed
+ = tree_cons (name, old_decl, current_scope->shadowed);
+ }
+ else if (DECL_WEAK_NAME (decl))
+ return;
+ else if (!DECL_WEAK_NAME (old_decl))
+ {
+ tree base_decl = decl, base_old_decl = old_decl;
+ while (TREE_CODE (base_decl) == ALIAS_DECL)
+ base_decl = DECL_ABSTRACT_ORIGIN (base_decl);
+ while (TREE_CODE (base_old_decl) == ALIAS_DECL)
+ base_old_decl = DECL_ABSTRACT_ORIGIN (base_old_decl);
+ /* Note that duplicate definitions are allowed for set elements
+ of similar set modes. See Z200 (1988) 12.2.2.
+ However, if the types are identical, we are defining the
+ same name multiple times in the same SET, which is naughty. */
+ if (!quiet && base_decl != base_old_decl)
+ {
+ if (TREE_CODE (base_decl) != CONST_DECL
+ || TREE_CODE (base_old_decl) != CONST_DECL
+ || !CH_DECL_ENUM (base_decl)
+ || !CH_DECL_ENUM (base_old_decl)
+ || TREE_TYPE (base_decl) == TREE_TYPE (base_old_decl)
+ || !CH_SIMILAR (TREE_TYPE (base_decl),
+ TREE_TYPE(base_old_decl)))
+ {
+ error_with_decl (decl, "duplicate definition `%s'");
+ error_with_decl (old_decl, "previous definition of `%s'");
+ }
+ }
+ }
+ IDENTIFIER_LOCAL_VALUE (name) = decl;
+ }
+ /* Should be redundant most of the time ... */
+ set_nesting_level (decl, current_nesting_level);
+}
+
+/* Return tree_cons (NULL_TREE, ELEMENT, LIST) unless ELEMENT
+ is already in LIST, in which case return LIST. */
+
+static tree
+maybe_acons (element, list)
+ tree element, list;
+{
+ tree pair;
+ for (pair = list; pair; pair = TREE_CHAIN (pair))
+ if (element == TREE_VALUE (pair))
+ return list;
+ return tree_cons (NULL_TREE, element, list);
+}
+
+struct path
+{
+ struct path *prev;
+ tree node;
+};
+\f
+/* Look for implied types (enumeral types) implied by TYPE (a decl or type).
+ Add these to list.
+ Use old_path to guard against cycles. */
+
+tree
+find_implied_types (type, old_path, list)
+ tree type;
+ struct path *old_path;
+ tree list;
+{
+ struct path path[1], *link;
+ if (type == NULL_TREE)
+ return list;
+ path[0].prev = old_path;
+ path[0].node = type;
+
+ /* Check for a cycle. Something more clever might be appropriate. FIXME? */
+ for (link = old_path; link; link = link->prev)
+ if (link->node == type)
+ return list;
+
+ switch (TREE_CODE (type))
+ {
+ case ENUMERAL_TYPE:
+ return maybe_acons (type, list);
+ case LANG_TYPE:
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ case INTEGER_TYPE:
+ return find_implied_types (TREE_TYPE (type), path, list);
+ case SET_TYPE:
+ return find_implied_types (TYPE_DOMAIN (type), path, list);
+ case FUNCTION_TYPE:
+#if 0
+ case PROCESS_TYPE:
+#endif
+ { tree t;
+ list = find_implied_types (TREE_TYPE (type), path, list);
+ for (t = TYPE_ARG_TYPES (type); t != NULL_TREE; t = TREE_CHAIN (t))
+ list = find_implied_types (TREE_VALUE (t), path, list);
+ return list;
+ }
+ case ARRAY_TYPE:
+ list = find_implied_types (TYPE_DOMAIN (type), path, list);
+ return find_implied_types (TREE_TYPE (type), path, list);
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ { tree fields;
+ for (fields = TYPE_FIELDS (type); fields != NULL_TREE;
+ fields = TREE_CHAIN (fields))
+ list = find_implied_types (TREE_TYPE (fields), path, list);
+ return list;
+ }
+
+ case IDENTIFIER_NODE:
+ return find_implied_types (lookup_name (type), path, list);
+ break;
+ case ALIAS_DECL:
+ return find_implied_types (DECL_ABSTRACT_ORIGIN (type), path, list);
+ case VAR_DECL:
+ case FUNCTION_DECL:
+ case TYPE_DECL:
+ return find_implied_types (TREE_TYPE (type), path, list);
+ default:
+ return list;
+ }
+}
+\f
+/* Make declarations in current scope visible.
+ Also, expand SEIZEs, and make correspondong ALIAS_DECLs visible. */
+
+static void
+push_scope_decls (quiet)
+ int quiet; /* If 1, we're pre-scanning, so suppress errors. */
+{
+ tree decl;
+
+ /* First make everything except 'SEIZE ALL' names visible, before
+ handling 'SEIZE ALL'. (This makes it easier to check 'seizable'). */
+ for (decl = current_scope->remembered_decls; decl; decl = TREE_CHAIN (decl))
+ {
+ if (TREE_CODE (decl) == ALIAS_DECL)
+ {
+ if (DECL_POSTFIX_ALL (decl))
+ continue;
+ if (DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE)
+ {
+ tree val = lookup_name_for_seizing (decl);
+ if (val == NULL_TREE)
+ {
+ error_with_file_and_line
+ (DECL_SOURCE_FILE (decl), DECL_SOURCE_LINE (decl),
+ "cannot SEIZE `%s'",
+ IDENTIFIER_POINTER (DECL_OLD_NAME (decl)));
+ val = error_mark_node;
+ }
+ DECL_ABSTRACT_ORIGIN (decl) = val;
+ }
+ }
+ proclaim_decl (decl, quiet);
+ }
+
+ pushdecllist (current_scope->granted_decls, quiet);
+
+ /* Now handle SEIZE ALLs. */
+ for (decl = current_scope->remembered_decls; decl; )
+ {
+ tree next_decl = TREE_CHAIN (decl);
+ if (TREE_CODE (decl) == ALIAS_DECL
+ && DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE
+ && DECL_POSTFIX_ALL (decl))
+ {
+ /* We saw a "SEIZE ALL". Replace it be a SEIZE for each
+ declaration visible in the surrounding scope.
+ Note that this complicates get_next_decl(). */
+ tree candidate;
+ tree last_new_alias = decl;
+ DECL_ABSTRACT_ORIGIN (decl) = error_mark_node;
+ if (current_scope->enclosing == global_scope)
+ candidate = outer_decls;
+ else
+ candidate = current_scope->enclosing->decls;
+ for ( ; candidate; candidate = TREE_CHAIN (candidate))
+ {
+ tree seizename = DECL_NAME (candidate);
+ tree new_name;
+ tree new_alias;
+ if (!seizename)
+ continue;
+ new_name = decl_check_rename (decl, seizename);
+ if (!new_name)
+ continue;
+
+ /* Check if candidate is seizable. */
+ if (lookup_name (new_name) != NULL_TREE)
+ continue;
+
+ new_alias = build_alias_decl (NULL_TREE,NULL_TREE, new_name);
+ TREE_CHAIN (new_alias) = TREE_CHAIN (last_new_alias);
+ TREE_CHAIN (last_new_alias) = new_alias;
+ last_new_alias = new_alias;
+ DECL_ABSTRACT_ORIGIN (new_alias) = candidate;
+ DECL_SOURCE_LINE (new_alias) = 0;
+
+ proclaim_decl (new_alias, quiet);
+ }
+ }
+ decl = next_decl;
+ }
+
+ /* Link current_scope->remembered_decls at the head of the
+ current_scope->decls list (just like pushdecllist, but
+ without calling proclaim_decl, since we've already done that). */
+ if ((decl = current_scope->remembered_decls) != NULL_TREE)
+ {
+ while (TREE_CHAIN (decl) != NULL_TREE)
+ decl = TREE_CHAIN (decl);
+ TREE_CHAIN (decl) = current_scope->decls;
+ current_scope->decls = current_scope->remembered_decls;
+ }
+}
+
+static void
+pop_scope_decls (decls_limit, shadowed_limit)
+ tree decls_limit, shadowed_limit;
+{
+ /* Remove the temporary bindings we made. */
+ tree link = current_scope->shadowed;
+ tree decl = current_scope->decls;
+ if (decl != decls_limit)
+ {
+ while (decl != decls_limit)
+ {
+ tree next = TREE_CHAIN (decl);
+ if (DECL_NAME (decl))
+ {
+ /* If the ident. was used or addressed via a local extern decl,
+ don't forget that fact. */
+ if (DECL_EXTERNAL (decl))
+ {
+ if (TREE_USED (decl))
+ TREE_USED (DECL_NAME (decl)) = 1;
+ if (TREE_ADDRESSABLE (decl))
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (decl)) = 1;
+ }
+ IDENTIFIER_LOCAL_VALUE (DECL_NAME (decl)) = 0;
+ }
+ if (next == decls_limit)
+ {
+ TREE_CHAIN (decl) = NULL_TREE;
+ break;
+ }
+ decl = next;
+ }
+ current_scope->decls = decls_limit;
+ }
+
+ /* Restore all name-meanings of the outer levels
+ that were shadowed by this level. */
+ for ( ; link != shadowed_limit; link = TREE_CHAIN (link))
+ IDENTIFIER_LOCAL_VALUE (TREE_PURPOSE (link)) = TREE_VALUE (link);
+ current_scope->shadowed = shadowed_limit;
+}
+
+/* Return list of weak names (as ALIAS_DECLs) implied by IMPLIED_TYPES. */
+
+static tree
+build_implied_names (implied_types)
+ tree implied_types;
+{
+ tree aliases = NULL_TREE;
+
+ for ( ; implied_types; implied_types = TREE_CHAIN (implied_types))
+ {
+ tree enum_type = TREE_VALUE (implied_types);
+ tree link = TYPE_VALUES (enum_type);
+ if (TREE_CODE (enum_type) != ENUMERAL_TYPE)
+ abort ();
+
+ for ( ; link; link = TREE_CHAIN (link))
+ {
+ /* We don't handle renaming/prefixes (Blue Book p 163) FIXME */
+ /* Note that before enum_type is laid out, TREE_VALUE (link)
+ is a CONST_DECL, while after it is laid out,
+ TREE_VALUE (link) is an INTEGER_CST. Either works. */
+ tree alias
+ = build_alias_decl (NULL_TREE, NULL_TREE, TREE_PURPOSE (link));
+ DECL_ABSTRACT_ORIGIN (alias) = TREE_VALUE (link);
+ DECL_WEAK_NAME (alias) = 1;
+ TREE_CHAIN (alias) = aliases;
+ aliases = alias;
+ /* Strictlt speaking, we should have a pointer from the alias
+ to the decl, so we can make sure that the alias is only
+ visible when the decl is. FIXME */
+ }
+ }
+ return aliases;
+}
+
+static void
+bind_sub_modules (do_weak)
+ int do_weak;
+{
+ tree decl;
+ int save_module_nesting_level = current_module_nesting_level;
+ struct scope *saved_scope = current_scope;
+ struct scope *nested_module = current_scope->first_child_module;
+
+ while (nested_module != NULL)
+ {
+ tree saved_shadowed = nested_module->shadowed;
+ tree saved_decls = nested_module->decls;
+ current_nesting_level++;
+ current_scope = nested_module;
+ current_module_nesting_level = current_nesting_level;
+ if (do_weak == 0)
+ push_scope_decls (1);
+ else
+ {
+ tree implied_types = NULL_TREE;
+ /* Push weak names implied by decls in current_scope. */
+ for (decl = current_scope->remembered_decls;
+ decl; decl = TREE_CHAIN (decl))
+ if (TREE_CODE (decl) == ALIAS_DECL)
+ implied_types = find_implied_types (decl, NULL, implied_types);
+ for (decl = current_scope->granted_decls;
+ decl; decl = TREE_CHAIN (decl))
+ implied_types = find_implied_types (decl, NULL, implied_types);
+ current_scope->weak_decls = build_implied_names (implied_types);
+ pushdecllist (current_scope->weak_decls, 1);
+ }
+
+ bind_sub_modules (do_weak);
+ for (decl = current_scope->remembered_decls;
+ decl; decl = TREE_CHAIN (decl))
+ satisfy_decl (decl, 1);
+ pop_scope_decls (saved_decls, saved_shadowed);
+ current_nesting_level--;
+ nested_module = nested_module->next_sibling_module;
+ }
+
+ current_scope = saved_scope;
+ current_module_nesting_level = save_module_nesting_level;
+}
+\f
+/* Enter a new binding level.
+ If two_pass==0, assume we are called from non-Chill-specific parts
+ of the compiler. These parts assume a single pass.
+ If two_pass==1, we're called from Chill parts of the compiler.
+*/
+
+void
+pushlevel (two_pass)
+ int two_pass;
+{
+ register struct scope *newlevel;
+
+ current_nesting_level++;
+ if (!two_pass)
+ {
+ newlevel = (struct scope *)xmalloc (sizeof(struct scope));
+ *newlevel = clear_scope;
+ newlevel->enclosing = current_scope;
+ current_scope = newlevel;
+ }
+ else if (pass < 2)
+ {
+ newlevel = (struct scope *)permalloc (sizeof(struct scope));
+ *newlevel = clear_scope;
+ newlevel->tail_child_module = &newlevel->first_child_module;
+ newlevel->enclosing = current_scope;
+ current_scope = newlevel;
+ last_scope->next = newlevel;
+ last_scope = newlevel;
+ }
+ else /* pass == 2 */
+ {
+ tree decl;
+ newlevel = current_scope = last_scope = last_scope->next;
+
+ push_scope_decls (0);
+ pushdecllist (current_scope->weak_decls, 0);
+
+ /* If this is not a module scope, scan ahead for locally nested
+ modules. (If this is a module, that's already done.) */
+ if (!current_scope->module_flag)
+ {
+ bind_sub_modules (0);
+ bind_sub_modules (1);
+ }
+
+ for (decl = current_scope->remembered_decls;
+ decl; decl = TREE_CHAIN (decl))
+ satisfy_decl (decl, 0);
+ }
+
+ /* Add this level to the front of the chain (stack) of levels that
+ are active. */
+
+ newlevel->level_chain = current_scope;
+ current_scope = newlevel;
+
+ newlevel->two_pass = two_pass;
+}
+\f
+/* Exit a binding level.
+ Pop the level off, and restore the state of the identifier-decl mappings
+ that were in effect when this level was entered.
+
+ If KEEP is nonzero, this level had explicit declarations, so
+ and create a "block" (a BLOCK node) for the level
+ to record its declarations and subblocks for symbol table output.
+
+ If FUNCTIONBODY is nonzero, this level is the body of a function,
+ so create a block as if KEEP were set and also clear out all
+ label names.
+
+ If REVERSE is nonzero, reverse the order of decls before putting
+ them into the BLOCK. */
+
+tree
+poplevel (keep, reverse, functionbody)
+ int keep;
+ int reverse;
+ int functionbody;
+{
+ register tree link;
+ /* The chain of decls was accumulated in reverse order.
+ Put it into forward order, just for cleanliness. */
+ tree decls;
+ tree subblocks;
+ tree block = 0;
+ tree decl;
+ int block_previously_created;
+
+ if (current_scope == NULL)
+ return error_mark_node;
+
+ subblocks = current_scope->blocks;
+
+ /* Get the decls in the order they were written.
+ Usually current_scope->decls is in reverse order.
+ But parameter decls were previously put in forward order. */
+
+ if (reverse)
+ current_scope->decls
+ = decls = nreverse (current_scope->decls);
+ else
+ decls = current_scope->decls;
+
+ if (pass == 2)
+ {
+ /* Output any nested inline functions within this block
+ if they weren't already output. */
+
+ for (decl = decls; decl; decl = TREE_CHAIN (decl))
+ if (TREE_CODE (decl) == FUNCTION_DECL
+ && ! TREE_ASM_WRITTEN (decl)
+ && DECL_INITIAL (decl) != 0
+ && TREE_ADDRESSABLE (decl))
+ {
+ /* If this decl was copied from a file-scope decl
+ on account of a block-scope extern decl,
+ propagate TREE_ADDRESSABLE to the file-scope decl. */
+ if (DECL_ABSTRACT_ORIGIN (decl) != 0)
+ TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
+ else
+ {
+ push_function_context ();
+ output_inline_function (decl);
+ pop_function_context ();
+ }
+ }
+
+ /* Clear out the meanings of the local variables of this level. */
+ pop_scope_decls (NULL_TREE, NULL_TREE);
+
+ /* If there were any declarations or structure tags in that level,
+ or if this level is a function body,
+ create a BLOCK to record them for the life of this function. */
+
+ block = 0;
+ block_previously_created = (current_scope->this_block != 0);
+ if (block_previously_created)
+ block = current_scope->this_block;
+ else if (keep || functionbody)
+ block = make_node (BLOCK);
+ if (block != 0)
+ {
+ tree *ptr;
+ BLOCK_VARS (block) = decls;
+
+ /* Splice out ALIAS_DECL and LABEL_DECLs,
+ since instantiate_decls can't handle them. */
+ for (ptr = &BLOCK_VARS (block); *ptr; )
+ {
+ decl = *ptr;
+ if (TREE_CODE (decl) == ALIAS_DECL
+ || TREE_CODE (decl) == LABEL_DECL)
+ *ptr = TREE_CHAIN (decl);
+ else
+ ptr = &TREE_CHAIN(*ptr);
+ }
+
+ BLOCK_SUBBLOCKS (block) = subblocks;
+ remember_end_note (block);
+ }
+
+ /* In each subblock, record that this is its superior. */
+
+ for (link = subblocks; link; link = TREE_CHAIN (link))
+ BLOCK_SUPERCONTEXT (link) = block;
+
+ }
+
+ /* If the level being exited is the top level of a function,
+ check over all the labels, and clear out the current
+ (function local) meanings of their names. */
+
+ if (pass == 2 && functionbody)
+ {
+ /* If this is the top level block of a function,
+ the vars are the function's parameters.
+ Don't leave them in the BLOCK because they are
+ found in the FUNCTION_DECL instead. */
+
+ BLOCK_VARS (block) = 0;
+
+#if 0
+ /* Clear out the definitions of all label names,
+ since their scopes end here,
+ and add them to BLOCK_VARS. */
+
+ for (link = named_labels; link; link = TREE_CHAIN (link))
+ {
+ register tree label = TREE_VALUE (link);
+
+ if (DECL_INITIAL (label) == 0)
+ {
+ error_with_decl (label, "label `%s' used but not defined");
+ /* Avoid crashing later. */
+ define_label (input_filename, lineno,
+ DECL_NAME (label));
+ }
+ else if (warn_unused && !TREE_USED (label))
+ warning_with_decl (label, "label `%s' defined but not used");
+ IDENTIFIER_LABEL_VALUE (DECL_NAME (label)) = 0;
+
+ /* Put the labels into the "variables" of the
+ top-level block, so debugger can see them. */
+ TREE_CHAIN (label) = BLOCK_VARS (block);
+ BLOCK_VARS (block) = label;
+ }
+#endif
+ }
+
+ if (pass < 2)
+ {
+ current_scope->remembered_decls
+ = nreverse (current_scope->remembered_decls);
+ current_scope->granted_decls = nreverse (current_scope->granted_decls);
+ }
+
+ current_scope = current_scope->enclosing;
+ current_nesting_level--;
+
+ if (pass < 2)
+ {
+ return NULL_TREE;
+ }
+
+ /* Dispose of the block that we just made inside some higher level. */
+ if (functionbody)
+ DECL_INITIAL (current_function_decl) = block;
+ else if (block)
+ {
+ if (!block_previously_created)
+ current_scope->blocks
+ = chainon (current_scope->blocks, block);
+ }
+ /* If we did not make a block for the level just exited,
+ any blocks made for inner levels
+ (since they cannot be recorded as subblocks in that level)
+ must be carried forward so they will later become subblocks
+ of something else. */
+ else if (subblocks)
+ current_scope->blocks
+ = chainon (current_scope->blocks, subblocks);
+
+ if (block)
+ TREE_USED (block) = 1;
+ return block;
+}
+\f
+/* Delete the node BLOCK from the current binding level.
+ This is used for the block inside a stmt expr ({...})
+ so that the block can be reinserted where appropriate. */
+
+void
+delete_block (block)
+ tree block;
+{
+ tree t;
+ if (current_scope->blocks == block)
+ current_scope->blocks = TREE_CHAIN (block);
+ for (t = current_scope->blocks; t;)
+ {
+ if (TREE_CHAIN (t) == block)
+ TREE_CHAIN (t) = TREE_CHAIN (block);
+ else
+ t = TREE_CHAIN (t);
+ }
+ TREE_CHAIN (block) = NULL;
+ /* Clear TREE_USED which is always set by poplevel.
+ The flag is set again if insert_block is called. */
+ TREE_USED (block) = 0;
+}
+
+/* Insert BLOCK at the end of the list of subblocks of the
+ current binding level. This is used when a BIND_EXPR is expanded,
+ to handle the BLOCK node inside teh BIND_EXPR. */
+
+void
+insert_block (block)
+ tree block;
+{
+ TREE_USED (block) = 1;
+ current_scope->blocks
+ = chainon (current_scope->blocks, block);
+}
+
+/* Set the BLOCK node for the innermost scope
+ (the one we are currently in). */
+
+void
+set_block (block)
+ register tree block;
+{
+ current_scope->this_block = block;
+}
+\f
+/* Record a decl-node X as belonging to the current lexical scope.
+ Check for errors (such as an incompatible declaration for the same
+ name already seen in the same scope).
+
+ Returns either X or an old decl for the same name.
+ If an old decl is returned, it may have been smashed
+ to agree with what X says. */
+
+tree
+pushdecl (x)
+ tree x;
+{
+ register tree t;
+ register tree name = DECL_NAME (x);
+ register struct scope *b = current_scope;
+
+ DECL_CONTEXT (x) = current_function_decl;
+ /* A local extern declaration for a function doesn't constitute nesting.
+ A local auto declaration does, since it's a forward decl
+ for a nested function coming later. */
+ if (TREE_CODE (x) == FUNCTION_DECL && DECL_INITIAL (x) == 0
+ && DECL_EXTERNAL (x))
+ DECL_CONTEXT (x) = 0;
+
+ if (name)
+ proclaim_decl (x, 0);
+
+ if (TREE_CODE (x) == TYPE_DECL && DECL_SOURCE_LINE (x) == 0
+ && TYPE_NAME (TREE_TYPE (x)) == 0)
+ TYPE_NAME (TREE_TYPE (x)) = x;
+
+ /* Put decls on list in reverse order.
+ We will reverse them later if necessary. */
+ TREE_CHAIN (x) = b->decls;
+ b->decls = x;
+
+ return x;
+}
+\f
+/* Make DECLS (a chain of decls) visible in the current_scope. */
+
+static void
+pushdecllist (decls, quiet)
+ tree decls;
+ int quiet;
+{
+ tree last = NULL_TREE, decl;
+
+ for (decl = decls; decl != NULL_TREE;
+ last = decl, decl = TREE_CHAIN (decl))
+ {
+ proclaim_decl (decl, quiet);
+ }
+
+ if (last)
+ {
+ TREE_CHAIN (last) = current_scope->decls;
+ current_scope->decls = decls;
+ }
+}
+
+/* Like pushdecl, only it places X in GLOBAL_SCOPE, if appropriate. */
+
+tree
+pushdecl_top_level (x)
+ tree x;
+{
+ register tree t;
+ register struct scope *b = current_scope;
+
+ current_scope = global_scope;
+ t = pushdecl (x);
+ current_scope = b;
+ return t;
+}
+\f
+/* Define a label, specifying the location in the source file.
+ Return the LABEL_DECL node for the label, if the definition is valid.
+ Otherwise return 0. */
+
+tree
+define_label (filename, line, name)
+ char *filename;
+ int line;
+ tree name;
+{
+ tree decl;
+
+ if (pass == 1)
+ {
+ decl = build_decl (LABEL_DECL, name, void_type_node);
+
+ /* A label not explicitly declared must be local to where it's ref'd. */
+ DECL_CONTEXT (decl) = current_function_decl;
+
+ DECL_MODE (decl) = VOIDmode;
+
+ /* Say where one reference is to the label,
+ for the sake of the error if it is not defined. */
+ DECL_SOURCE_LINE (decl) = line;
+ DECL_SOURCE_FILE (decl) = filename;
+
+ /* Mark label as having been defined. */
+ DECL_INITIAL (decl) = error_mark_node;
+
+ DECL_ACTION_NESTING_LEVEL (decl) = action_nesting_level;
+
+ save_decl (decl);
+ }
+ else
+ {
+ decl = get_next_decl ();
+ /* Make sure every label has an rtx. */
+
+ label_rtx (decl);
+ expand_label (decl);
+ }
+ return decl;
+}
+\f
+/* Return the list of declarations of the current level.
+ Note that this list is in reverse order unless/until
+ you nreverse it; and when you do nreverse it, you must
+ store the result back using `storedecls' or you will lose. */
+
+tree
+getdecls ()
+{
+ /* This is a kludge, so that dbxout_init can get the predefined types,
+ which are in the builtin_scope, though when it is called,
+ the current_scope is the global_scope.. */
+ if (current_scope == global_scope)
+ return builtin_scope.decls;
+ return current_scope->decls;
+}
+
+#if 0
+/* Store the list of declarations of the current level.
+ This is done for the parameter declarations of a function being defined,
+ after they are modified in the light of any missing parameters. */
+
+static void
+storedecls (decls)
+ tree decls;
+{
+ current_scope->decls = decls;
+}
+#endif
+\f
+/* Look up NAME in the current binding level and its superiors
+ in the namespace of variables, functions and typedefs.
+ Return a ..._DECL node of some kind representing its definition,
+ or return 0 if it is undefined. */
+
+tree
+lookup_name (name)
+ tree name;
+{
+ register tree val = IDENTIFIER_LOCAL_VALUE (name);
+
+ if (val == NULL_TREE)
+ return NULL_TREE;
+ if (TREE_CODE_CLASS (TREE_CODE (val)) == 'c')
+ return val;
+ if (DECL_NESTING_LEVEL (val) > BUILTIN_NESTING_LEVEL
+ && DECL_NESTING_LEVEL (val) < current_module_nesting_level)
+ {
+ return NULL_TREE;
+ }
+ while (TREE_CODE (val) == ALIAS_DECL)
+ {
+ val = DECL_ABSTRACT_ORIGIN (val);
+ if (TREE_CODE (val) == ERROR_MARK)
+ return NULL_TREE;
+ }
+ if (TREE_CODE (val) == BASED_DECL)
+ {
+ return build_chill_indirect_ref (DECL_ABSTRACT_ORIGIN (val),
+ TREE_TYPE (val), 1);
+ }
+ if (TREE_CODE (val) == WITH_DECL)
+ return build_component_ref (DECL_ABSTRACT_ORIGIN (val), DECL_NAME (val));
+ return val;
+}
+
+/* Similar to `lookup_name' but look only at current binding level. */
+
+tree
+lookup_name_current_level (name)
+ tree name;
+{
+ register tree val = IDENTIFIER_LOCAL_VALUE (name);
+ if (val && DECL_NESTING_LEVEL (val) == current_nesting_level)
+ return val;
+ return NULL_TREE;
+}
+
+tree
+lookup_name_for_seizing (seize_decl)
+ tree seize_decl;
+{
+ tree name = DECL_OLD_NAME (seize_decl);
+ register tree val;
+ val = IDENTIFIER_LOCAL_VALUE (name);
+ if (val == NULL_TREE || DECL_NESTING_LEVEL (val) == BUILTIN_NESTING_LEVEL)
+ {
+ val = IDENTIFIER_OUTER_VALUE (name);
+ if (val == NULL_TREE)
+ return NULL_TREE;
+ if (TREE_CHAIN (val) && DECL_NAME (TREE_CHAIN (val)) == name)
+ { /* More than one decl with the same name has been granted
+ into the same global scope. Pick the one (we hope) that
+ came from a seizefile the matches the most recent
+ seizefile (as given by DECL_SEIZEFILE (seize_decl).) */
+ tree d, best = NULL_TREE;
+ for (d = val; d != NULL_TREE && DECL_NAME (d) == name;
+ d = TREE_CHAIN (d))
+ if (DECL_SEIZEFILE (d) == DECL_SEIZEFILE (seize_decl))
+ {
+ if (best)
+ {
+ error_with_decl (seize_decl,
+ "ambiguous choice for seize `%s' -");
+ error_with_decl (best, " - can seize this `%s' -");
+ error_with_decl (d, " - or this granted decl `%s'");
+ return NULL_TREE;
+ }
+ best = d;
+ }
+ if (best == NULL_TREE)
+ {
+ error_with_decl (seize_decl,
+ "ambiguous choice for seize `%s' -");
+ error_with_decl (val, " - can seize this `%s' -");
+ error_with_decl (TREE_CHAIN (val),
+ " - or this granted decl `%s'");
+ return NULL_TREE;
+ }
+ val = best;
+ }
+ }
+#if 0
+ /* We don't need to handle this, as long as we
+ resolve the seize targets before pushing them. */
+ if (DECL_NESTING_LEVEL (val) >= current_module_nesting_level)
+ {
+ /* VAL was declared inside current module. We need something
+ from the scope *enclosing* the current module, so search
+ through the shadowed declarations. */
+ /* TODO - FIXME */
+ }
+#endif
+ if (current_module && current_module->prev_module
+ && DECL_NESTING_LEVEL (val)
+ < current_module->prev_module->nesting_level)
+ {
+
+ /* It's declared in a scope enclosing the module enclosing
+ the current module. Hence it's not visible. */
+ return NULL_TREE;
+ }
+ while (TREE_CODE (val) == ALIAS_DECL)
+ {
+ val = DECL_ABSTRACT_ORIGIN (val);
+ if (TREE_CODE (val) == ERROR_MARK)
+ return NULL_TREE;
+ }
+ return val;
+}
+\f
+/* Create the predefined scalar types of C,
+ and some nodes representing standard constants (0, 1, (void *)0).
+ Initialize the global binding level.
+ Make definitions for built-in primitive functions. */
+
+void
+init_decl_processing ()
+{
+ int wchar_type_size;
+ tree bool_ftype_int_ptr_int;
+ tree bool_ftype_int_ptr_int_int;
+ tree bool_ftype_luns_ptr_luns_long;
+ tree bool_ftype_luns_ptr_luns_long_ptr_int;
+ tree bool_ftype_ptr_int_ptr_int;
+ tree bool_ftype_ptr_int_ptr_int_int;
+ tree find_bit_ftype;
+ tree bool_ftype_ptr_ptr_int;
+ tree bool_ftype_ptr_ptr_luns;
+ tree bool_ftype_ptr_ptr_ptr_luns;
+ tree endlink;
+ tree int_ftype_int;
+ tree int_ftype_int_int;
+ tree int_ftype_int_ptr_int;
+ tree int_ftype_ptr;
+ tree int_ftype_ptr_int;
+ tree int_ftype_ptr_int_int_ptr_int;
+ tree int_ftype_ptr_luns_long_ptr_int;
+ tree int_ftype_ptr_ptr_int;
+ tree int_ftype_ptr_ptr_luns;
+ tree long_ftype_ptr_luns;
+ tree memcpy_ftype;
+ tree memcmp_ftype;
+ tree ptr_ftype_ptr_int_int;
+ tree ptr_ftype_ptr_ptr_int;
+ tree ptr_ftype_ptr_ptr_int_ptr_int;
+ tree real_ftype_real;
+ tree temp;
+ tree void_ftype_cptr_cptr_int;
+ tree void_ftype_long_int_ptr_int_ptr_int;
+ tree void_ftype_ptr;
+ tree void_ftype_ptr_int_int_int_int;
+ tree void_ftype_ptr_int_ptr_int_int_int;
+ tree void_ftype_ptr_int_ptr_int_ptr_int;
+ tree void_ftype_ptr_luns_long_long_bool_ptr_int;
+ tree void_ftype_ptr_luns_ptr_luns_luns_luns;
+ tree void_ftype_ptr_ptr_ptr_int;
+ tree void_ftype_ptr_ptr_ptr_luns;
+ tree void_ftype_refptr_int_ptr_int;
+ tree void_ftype_void;
+ tree void_ftype_ptr_ptr_int;
+ tree void_ftype_ptr_luns_luns_cptr_luns_luns_luns;
+ tree ptr_ftype_luns_ptr_int;
+ tree double_ftype_double;
+
+ extern int set_alignment;
+
+ /* allow 0-255 enums to occupy only a byte */
+ flag_short_enums = 1;
+
+ current_function_decl = NULL;
+
+ set_alignment = BITS_PER_UNIT;
+
+ ALL_POSTFIX = get_identifier ("*");
+ string_index_type_dummy = get_identifier("%string-index%");
+
+ var_length_id = get_identifier (VAR_LENGTH);
+ var_data_id = get_identifier (VAR_DATA);
+
+ /* This is the *C* int type. */
+ integer_type_node = make_signed_type (INT_TYPE_SIZE);
+
+ if (CHILL_INT_IS_SHORT)
+ long_integer_type_node = integer_type_node;
+ else
+ long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
+
+ unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
+ long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
+ long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
+ long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
+
+ /* `unsigned long' is the standard type for sizeof.
+ Note that stddef.h uses `unsigned long',
+ and this must agree, even of long and int are the same size. */
+#ifndef SIZE_TYPE
+ sizetype = long_unsigned_type_node;
+#else
+ {
+ char *size_type_c_name = SIZE_TYPE;
+ if (strncmp (size_type_c_name, "long long ", 10) == 0)
+ sizetype = long_long_unsigned_type_node;
+ else if (strncmp (size_type_c_name, "long ", 5) == 0)
+ sizetype = long_unsigned_type_node;
+ else
+ sizetype = unsigned_type_node;
+ }
+#endif
+
+ TREE_TYPE (TYPE_SIZE (integer_type_node)) = sizetype;
+ TREE_TYPE (TYPE_SIZE (unsigned_type_node)) = sizetype;
+ TREE_TYPE (TYPE_SIZE (long_unsigned_type_node)) = sizetype;
+ TREE_TYPE (TYPE_SIZE (long_integer_type_node)) = sizetype;
+ TREE_TYPE (TYPE_SIZE (long_long_integer_type_node)) = sizetype;
+ TREE_TYPE (TYPE_SIZE (long_long_unsigned_type_node)) = sizetype;
+
+ error_mark_node = make_node (ERROR_MARK);
+ TREE_TYPE (error_mark_node) = error_mark_node;
+
+ short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
+ short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
+ signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
+ unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
+ intQI_type_node = make_signed_type (GET_MODE_BITSIZE (QImode));
+ intHI_type_node = make_signed_type (GET_MODE_BITSIZE (HImode));
+ intSI_type_node = make_signed_type (GET_MODE_BITSIZE (SImode));
+ intDI_type_node = make_signed_type (GET_MODE_BITSIZE (DImode));
+ intTI_type_node = make_signed_type (GET_MODE_BITSIZE (TImode));
+ unsigned_intQI_type_node = make_unsigned_type (GET_MODE_BITSIZE (QImode));
+ unsigned_intHI_type_node = make_unsigned_type (GET_MODE_BITSIZE (HImode));
+ unsigned_intSI_type_node = make_unsigned_type (GET_MODE_BITSIZE (SImode));
+ unsigned_intDI_type_node = make_unsigned_type (GET_MODE_BITSIZE (DImode));
+ unsigned_intTI_type_node = make_unsigned_type (GET_MODE_BITSIZE (TImode));
+
+ float_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int) RID_FLOAT],
+ float_type_node));
+ layout_type (float_type_node);
+
+ double_type_node = make_node (REAL_TYPE);
+ if (flag_short_double)
+ TYPE_PRECISION (double_type_node) = FLOAT_TYPE_SIZE;
+ else
+ TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int) RID_DOUBLE],
+ double_type_node));
+ layout_type (double_type_node);
+
+ long_double_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
+ layout_type (long_double_type_node);
+
+ complex_integer_type_node = make_node (COMPLEX_TYPE);
+ TREE_TYPE (complex_integer_type_node) = integer_type_node;
+ layout_type (complex_integer_type_node);
+
+ complex_float_type_node = make_node (COMPLEX_TYPE);
+ TREE_TYPE (complex_float_type_node) = float_type_node;
+ layout_type (complex_float_type_node);
+
+ complex_double_type_node = make_node (COMPLEX_TYPE);
+ TREE_TYPE (complex_double_type_node) = double_type_node;
+ layout_type (complex_double_type_node);
+
+ complex_long_double_type_node = make_node (COMPLEX_TYPE);
+ TREE_TYPE (complex_long_double_type_node) = long_double_type_node;
+ layout_type (complex_long_double_type_node);
+
+ integer_zero_node = build_int_2 (0, 0);
+ TREE_TYPE (integer_zero_node) = integer_type_node;
+ integer_one_node = build_int_2 (1, 0);
+ TREE_TYPE (integer_one_node) = integer_type_node;
+ integer_minus_one_node = build_int_2 (-1, -1);
+ TREE_TYPE (integer_minus_one_node) = integer_type_node;
+
+ size_zero_node = build_int_2 (0, 0);
+ TREE_TYPE (size_zero_node) = sizetype;
+ size_one_node = build_int_2 (1, 0);
+ TREE_TYPE (size_one_node) = sizetype;
+
+ void_type_node = make_node (VOID_TYPE);
+ pushdecl (build_decl (TYPE_DECL,
+ ridpointers[(int) RID_VOID], void_type_node));
+ layout_type (void_type_node); /* Uses integer_zero_node */
+ /* We are not going to have real types in C with less than byte alignment,
+ so we might as well not have any types that claim to have it. */
+ TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
+
+ null_pointer_node = build_int_2 (0, 0);
+ TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
+ layout_type (TREE_TYPE (null_pointer_node));
+
+ /* This is for wide string constants. */
+ wchar_type_node = short_unsigned_type_node;
+ wchar_type_size = TYPE_PRECISION (wchar_type_node);
+ signed_wchar_type_node = type_for_size (wchar_type_size, 0);
+ unsigned_wchar_type_node = type_for_size (wchar_type_size, 1);
+
+ default_function_type
+ = build_function_type (integer_type_node, NULL_TREE);
+
+ ptr_type_node = build_pointer_type (void_type_node);
+ const_ptr_type_node
+ = build_pointer_type (build_type_variant (void_type_node, 1, 0));
+
+ void_list_node = build_tree_list (NULL_TREE, void_type_node);
+
+ boolean_type_node = make_node (BOOLEAN_TYPE);
+ TYPE_PRECISION (boolean_type_node) = 1;
+ fixup_unsigned_type (boolean_type_node);
+ boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
+ boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_BOOL],
+ boolean_type_node));
+
+ /* TRUE and FALSE have the BOOL derived class */
+ CH_DERIVED_FLAG (boolean_true_node) = 1;
+ CH_DERIVED_FLAG (boolean_false_node) = 1;
+
+ signed_boolean_type_node = make_node (BOOLEAN_TYPE);
+ temp = build_int_2 (-1, -1);
+ TREE_TYPE (temp) = signed_boolean_type_node;
+ TYPE_MIN_VALUE (signed_boolean_type_node) = temp;
+ temp = build_int_2 (0, 0);
+ TREE_TYPE (temp) = signed_boolean_type_node;
+ TYPE_MAX_VALUE (signed_boolean_type_node) = temp;
+ layout_type (signed_boolean_type_node);
+
+
+ bitstring_one_type_node = build_bitstring_type (integer_one_node);
+ bit_zero_node = build (CONSTRUCTOR, bitstring_one_type_node, NULL_TREE,
+ NULL_TREE);
+ bit_one_node = build (CONSTRUCTOR, bitstring_one_type_node, NULL_TREE,
+ build_tree_list (NULL_TREE, integer_zero_node));
+
+ char_type_node = make_node (CHAR_TYPE);
+ TYPE_PRECISION (char_type_node) = CHAR_TYPE_SIZE;
+ fixup_unsigned_type (char_type_node);
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_CHAR],
+ char_type_node));
+
+ if (CHILL_INT_IS_SHORT)
+ {
+ chill_integer_type_node = short_integer_type_node;
+ chill_unsigned_type_node = short_unsigned_type_node;
+ }
+ else
+ {
+ chill_integer_type_node = integer_type_node;
+ chill_unsigned_type_node = unsigned_type_node;
+ }
+
+ string_one_type_node = build_string_type (char_type_node, integer_one_node);
+
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_BYTE],
+ signed_char_type_node));
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_UBYTE],
+ unsigned_char_type_node));
+
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_INT],
+ chill_integer_type_node));
+
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_UINT],
+ chill_unsigned_type_node));
+
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_LONG],
+ long_integer_type_node));
+
+ sizetype = long_integer_type_node;
+#if 0
+ ptrdiff_type_node
+ = TREE_TYPE (IDENTIFIER_LOCAL_VALUE (get_identifier (PTRDIFF_TYPE)));
+#endif
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_ULONG],
+ long_unsigned_type_node));
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_REAL],
+ float_type_node));
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_LONG_REAL],
+ double_type_node));
+ pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_PTR],
+ ptr_type_node));
+
+ IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_TRUE]) =
+ boolean_true_node;
+ IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_FALSE]) =
+ boolean_false_node;
+ IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_NULL]) =
+ null_pointer_node;
+
+ /* The second operand is set to non-NULL to distinguish
+ (ELSE) from (*). Used when writing grant files. */
+ case_else_node = build (RANGE_EXPR,
+ NULL_TREE, NULL_TREE, boolean_false_node);
+
+ pushdecl (temp = build_decl (TYPE_DECL,
+ get_identifier ("__tmp_initializer"),
+ build_init_struct ()));
+ DECL_SOURCE_LINE (temp) = 0;
+ initializer_type = TREE_TYPE (temp);
+
+ bcopy (chill_tree_code_type,
+ tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE,
+ (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
+ * sizeof (char)));
+ bcopy (chill_tree_code_length,
+ tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE,
+ (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
+ * sizeof (int)));
+ bcopy (chill_tree_code_name,
+ tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE,
+ (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
+ * sizeof (char *)));
+ boolean_code_name = (char **) xmalloc (sizeof (char *) * (int) LAST_CHILL_TREE_CODE);
+ bzero (boolean_code_name, sizeof (char *) * (int) LAST_CHILL_TREE_CODE);
+
+ boolean_code_name[EQ_EXPR] = "=";
+ boolean_code_name[NE_EXPR] = "/=";
+ boolean_code_name[LT_EXPR] = "<";
+ boolean_code_name[GT_EXPR] = ">";
+ boolean_code_name[LE_EXPR] = "<=";
+ boolean_code_name[GE_EXPR] = ">=";
+ boolean_code_name[SET_IN_EXPR] = "in";
+ boolean_code_name[TRUTH_ANDIF_EXPR] = "andif";
+ boolean_code_name[TRUTH_ORIF_EXPR] = "orif";
+ boolean_code_name[TRUTH_AND_EXPR] = "and";
+ boolean_code_name[TRUTH_OR_EXPR] = "or";
+ boolean_code_name[BIT_AND_EXPR] = "and";
+ boolean_code_name[BIT_IOR_EXPR] = "or";
+ boolean_code_name[BIT_XOR_EXPR] = "xor";
+
+ endlink = void_list_node;
+
+ chill_predefined_function_type
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink));
+
+ bool_ftype_int_ptr_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ bool_ftype_int_ptr_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))));
+ bool_ftype_int_ptr_int_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))));
+ bool_ftype_luns_ptr_luns_long
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node,
+ endlink)))));
+ bool_ftype_luns_ptr_luns_long_ptr_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))));
+ bool_ftype_ptr_ptr_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ bool_ftype_ptr_ptr_luns
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink))));
+ bool_ftype_ptr_ptr_ptr_luns
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink)))));
+ bool_ftype_ptr_int_ptr_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))));
+ bool_ftype_ptr_int_ptr_int_int
+ = build_function_type (boolean_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))));
+ find_bit_ftype
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ int_ftype_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink));
+ int_ftype_int_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)));
+ int_ftype_int_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ int_ftype_ptr
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ endlink));
+ int_ftype_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)));
+
+ long_ftype_ptr_luns
+ = build_function_type (long_integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink)));
+
+ int_ftype_ptr_int_int_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))));
+
+ int_ftype_ptr_luns_long_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))));
+
+ int_ftype_ptr_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ int_ftype_ptr_ptr_luns
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink))));
+ memcpy_ftype /* memcpy/memmove prototype */
+ = build_function_type (ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node,
+ tree_cons (NULL_TREE, sizetype,
+ endlink))));
+ memcmp_ftype /* memcmp prototype */
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, sizetype,
+ endlink))));
+
+ ptr_ftype_ptr_int_int
+ = build_function_type (ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ ptr_ftype_ptr_ptr_int
+ = build_function_type (ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+ ptr_ftype_ptr_ptr_int_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))));
+ real_ftype_real
+ = build_function_type (float_type_node,
+ tree_cons (NULL_TREE, float_type_node,
+ endlink));
+
+ void_ftype_ptr
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node, endlink));
+
+ void_ftype_cptr_cptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+
+ void_ftype_refptr_int_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, build_reference_type(ptr_type_node),
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))));
+
+ void_ftype_ptr_ptr_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))));
+ void_ftype_ptr_ptr_ptr_luns
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink)))));
+ void_ftype_ptr_int_int_int_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))));
+ void_ftype_ptr_luns_long_long_bool_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node,
+ tree_cons (NULL_TREE, boolean_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))))));
+ void_ftype_ptr_int_ptr_int_int_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))));
+ void_ftype_ptr_luns_ptr_luns_luns_luns
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink)))))));
+ void_ftype_ptr_int_ptr_int_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))));
+ void_ftype_long_int_ptr_int_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))));
+ void_ftype_void
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, void_type_node,
+ endlink));
+
+ void_ftype_ptr_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+
+ void_ftype_ptr_luns_luns_cptr_luns_luns_luns
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ endlink))))))));
+
+ ptr_ftype_luns_ptr_int
+ = build_function_type (ptr_type_node,
+ tree_cons (NULL_TREE, long_unsigned_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+
+ double_ftype_double
+ = build_function_type (double_type_node,
+ tree_cons (NULL_TREE, double_type_node,
+ endlink));
+
+/* These are compiler-internal function calls, not intended
+ to be directly called by user code */
+ builtin_function ("__allocate", ptr_ftype_luns_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("_allocate_global_memory", void_ftype_refptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("_allocate_memory", void_ftype_refptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__andpowerset", bool_ftype_ptr_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__bitsetpowerset", void_ftype_ptr_int_int_int_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__cardpowerset", long_ftype_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__cause_ex1", void_ftype_cptr_cptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__concatstring", ptr_ftype_ptr_ptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__continue", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__diffpowerset", void_ftype_ptr_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__eqpowerset", bool_ftype_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__ffsetclrpowerset", find_bit_ftype,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__flsetclrpowerset", find_bit_ftype,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__flsetpowerset", int_ftype_ptr_luns_long_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__ffsetpowerset", int_ftype_ptr_luns_long_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__inbitstring", bool_ftype_luns_ptr_luns_long_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__inpowerset", bool_ftype_luns_ptr_luns_long,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__lepowerset", bool_ftype_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__ltpowerset", bool_ftype_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ /* Currently under experimentation. */
+ builtin_function ("memmove", memcpy_ftype,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("memcmp", memcmp_ftype,
+ NOT_BUILT_IN, NULL_PTR);
+
+ /* this comes from c-decl.c (init_decl_processing) */
+ builtin_function ("__builtin_alloca",
+ build_function_type (ptr_type_node,
+ tree_cons (NULL_TREE,
+ sizetype,
+ endlink)),
+ BUILT_IN_ALLOCA, "alloca");
+
+ builtin_function ("memset", ptr_ftype_ptr_int_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__notpowerset", bool_ftype_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__orpowerset", bool_ftype_ptr_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__psslice", void_ftype_ptr_int_ptr_int_int_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__pscpy", void_ftype_ptr_luns_luns_cptr_luns_luns_luns,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("_return_memory", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__setbitpowerset", void_ftype_ptr_luns_long_long_bool_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__terminate", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__unhandled_ex", void_ftype_cptr_cptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__xorpowerset", bool_ftype_ptr_ptr_ptr_luns,
+ NOT_BUILT_IN, NULL_PTR);
+
+ /* declare floating point functions */
+ builtin_function ("__sin", double_ftype_double, NOT_BUILT_IN, "sin");
+ builtin_function ("__cos", double_ftype_double, NOT_BUILT_IN, "cos");
+ builtin_function ("__tan", double_ftype_double, NOT_BUILT_IN, "tan");
+ builtin_function ("__asin", double_ftype_double, NOT_BUILT_IN, "asin");
+ builtin_function ("__acos", double_ftype_double, NOT_BUILT_IN, "acos");
+ builtin_function ("__atan", double_ftype_double, NOT_BUILT_IN, "atan");
+ builtin_function ("__exp", double_ftype_double, NOT_BUILT_IN, "exp");
+ builtin_function ("__log", double_ftype_double, NOT_BUILT_IN, "log");
+ builtin_function ("__log10", double_ftype_double, NOT_BUILT_IN, "log10");
+ builtin_function ("__sqrt", double_ftype_double, NOT_BUILT_IN, "sqrt");
+
+ tasking_init ();
+ timing_init ();
+ inout_init ();
+
+ /* These are predefined value builtin routine calls, built
+ by the compiler, but over-ridable by user procedures of
+ the same names. Note the lack of a leading underscore. */
+ builtin_function ((ignore_case || ! special_UC) ? "abs" : "ABS",
+ chill_predefined_function_type,
+ BUILT_IN_CH_ABS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "abstime" : "ABSTIME",
+ chill_predefined_function_type,
+ BUILT_IN_ABSTIME, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "allocate" : "ALLOCATE",
+ chill_predefined_function_type,
+ BUILT_IN_ALLOCATE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "allocate_memory" : "ALLOCATE_MEMORY",
+ chill_predefined_function_type,
+ BUILT_IN_ALLOCATE_MEMORY, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "addr" : "ADDR",
+ chill_predefined_function_type,
+ BUILT_IN_ADDR, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "allocate_global_memory" : "ALLOCATE_GLOBAL_MEMORY",
+ chill_predefined_function_type,
+ BUILT_IN_ALLOCATE_GLOBAL_MEMORY, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "arccos" : "ARCCOS",
+ chill_predefined_function_type,
+ BUILT_IN_ARCCOS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "arcsin" : "ARCSIN",
+ chill_predefined_function_type,
+ BUILT_IN_ARCSIN, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "arctan" : "ARCTAN",
+ chill_predefined_function_type,
+ BUILT_IN_ARCTAN, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "card" : "CARD",
+ chill_predefined_function_type,
+ BUILT_IN_CARD, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "cos" : "COS",
+ chill_predefined_function_type,
+ BUILT_IN_CH_COS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "days" : "DAYS",
+ chill_predefined_function_type,
+ BUILT_IN_DAYS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "descr" : "DESCR",
+ chill_predefined_function_type,
+ BUILT_IN_DESCR, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "getstack" : "GETSTACK",
+ chill_predefined_function_type,
+ BUILT_IN_GETSTACK, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "exp" : "EXP",
+ chill_predefined_function_type,
+ BUILT_IN_EXP, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "hours" : "HOURS",
+ chill_predefined_function_type,
+ BUILT_IN_HOURS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "inttime" : "INTTIME",
+ chill_predefined_function_type,
+ BUILT_IN_INTTIME, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "length" : "LENGTH",
+ chill_predefined_function_type,
+ BUILT_IN_LENGTH, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "log" : "LOG",
+ chill_predefined_function_type,
+ BUILT_IN_LOG, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "lower" : "LOWER",
+ chill_predefined_function_type,
+ BUILT_IN_LOWER, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "ln" : "LN",
+ chill_predefined_function_type,
+ BUILT_IN_LN, NULL_PTR);
+ /* Note: these are *not* the C integer MAX and MIN. They're
+ for powerset arguments. */
+ builtin_function ((ignore_case || ! special_UC) ? "max" : "MAX",
+ chill_predefined_function_type,
+ BUILT_IN_MAX, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "millisecs" : "MILLISECS",
+ chill_predefined_function_type,
+ BUILT_IN_MILLISECS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "min" : "MIN",
+ chill_predefined_function_type,
+ BUILT_IN_MIN, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "minutes" : "MINUTES",
+ chill_predefined_function_type,
+ BUILT_IN_MINUTES, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "num" : "NUM",
+ chill_predefined_function_type,
+ BUILT_IN_NUM, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "pred" : "PRED",
+ chill_predefined_function_type,
+ BUILT_IN_PRED, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "return_memory" : "RETURN_MEMORY",
+ chill_predefined_function_type,
+ BUILT_IN_RETURN_MEMORY, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "secs" : "SECS",
+ chill_predefined_function_type,
+ BUILT_IN_SECS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "sin" : "SIN",
+ chill_predefined_function_type,
+ BUILT_IN_CH_SIN, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "size" : "SIZE",
+ chill_predefined_function_type,
+ BUILT_IN_SIZE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "sqrt" : "SQRT",
+ chill_predefined_function_type,
+ BUILT_IN_SQRT, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "succ" : "SUCC",
+ chill_predefined_function_type,
+ BUILT_IN_SUCC, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "tan" : "TAN",
+ chill_predefined_function_type,
+ BUILT_IN_TAN, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "terminate" : "TERMINATE",
+ chill_predefined_function_type,
+ BUILT_IN_TERMINATE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "upper" : "UPPER",
+ chill_predefined_function_type,
+ BUILT_IN_UPPER, NULL_PTR);
+
+ build_chill_descr_type ();
+ build_chill_inttime_type ();
+
+ endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+
+ start_identifier_warnings ();
+
+ pass = 1;
+}
+\f
+/* Return a definition for a builtin function named NAME and whose data type
+ is TYPE. TYPE should be a function type with argument types.
+ FUNCTION_CODE tells later passes how to compile calls to this function.
+ See tree.h for its possible values.
+
+ If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
+ the name to be called if we can't opencode the function. */
+
+tree
+builtin_function (name, type, function_code, library_name)
+ char *name;
+ tree type;
+ enum built_in_function function_code;
+ char *library_name;
+{
+ tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ /* If -traditional, permit redefining a builtin function any way you like.
+ (Though really, if the program redefines these functions,
+ it probably won't work right unless compiled with -fno-builtin.) */
+ if (flag_traditional && name[0] != '_')
+ DECL_BUILT_IN_NONANSI (decl) = 1;
+ if (library_name)
+ DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
+ make_decl_rtl (decl, NULL_PTR, 1);
+ pushdecl (decl);
+ if (function_code != NOT_BUILT_IN)
+ {
+ DECL_BUILT_IN (decl) = 1;
+ DECL_SET_FUNCTION_CODE (decl, function_code);
+ }
+
+ return decl;
+}
+\f
+/* Print a warning if a constant expression had overflow in folding.
+ Invoke this function on every expression that the language
+ requires to be a constant expression. */
+
+void
+constant_expression_warning (value)
+ tree value;
+{
+ if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
+ || TREE_CODE (value) == COMPLEX_CST)
+ && TREE_CONSTANT_OVERFLOW (value) && pedantic)
+ pedwarn ("overflow in constant expression");
+}
+
+\f
+/* Finish processing of a declaration;
+ If the length of an array type is not known before,
+ it must be determined now, from the initial value, or it is an error. */
+
+void
+finish_decl (decl)
+ tree decl;
+{
+ register tree type = TREE_TYPE (decl);
+ int was_incomplete = (DECL_SIZE (decl) == 0);
+ int temporary = allocation_temporary_p ();
+
+ /* Pop back to the obstack that is current for this binding level.
+ This is because MAXINDEX, rtl, etc. to be made below
+ must go in the permanent obstack. But don't discard the
+ temporary data yet. */
+ pop_obstacks ();
+#if 0 /* pop_obstacks was near the end; this is what was here. */
+ if (current_scope == global_scope && temporary)
+ end_temporary_allocation ();
+#endif
+
+ if (TREE_CODE (decl) == VAR_DECL)
+ {
+ if (DECL_SIZE (decl) == 0
+ && TYPE_SIZE (TREE_TYPE (decl)) != 0)
+ layout_decl (decl, 0);
+
+ if (DECL_SIZE (decl) == 0 && TREE_CODE (TREE_TYPE (decl)) != ERROR_MARK)
+ {
+ error_with_decl (decl, "storage size of `%s' isn't known");
+ TREE_TYPE (decl) = error_mark_node;
+ }
+
+ if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
+ && DECL_SIZE (decl) != 0)
+ {
+ if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST)
+ constant_expression_warning (DECL_SIZE (decl));
+ }
+ }
+
+ /* Output the assembler code and/or RTL code for variables and functions,
+ unless the type is an undefined structure or union.
+ If not, it will get done when the type is completed. */
+
+ if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
+ {
+ /* The last argument (at_end) is set to 1 as a kludge to force
+ assemble_variable to be called. */
+ if (TREE_CODE (TREE_TYPE (decl)) != ERROR_MARK)
+ rest_of_decl_compilation (decl, (char*) 0, global_bindings_p (), 1);
+
+ /* Compute the RTL of a decl if not yet set.
+ (For normal user variables, satisfy_decl sets it.) */
+ if (! TREE_STATIC (decl) && ! DECL_EXTERNAL (decl))
+ {
+ if (was_incomplete)
+ {
+ /* If we used it already as memory, it must stay in memory. */
+ TREE_ADDRESSABLE (decl) = TREE_USED (decl);
+ /* If it's still incomplete now, no init will save it. */
+ if (DECL_SIZE (decl) == 0)
+ DECL_INITIAL (decl) = 0;
+ expand_decl (decl);
+ }
+ }
+ }
+
+ if (TREE_CODE (decl) == TYPE_DECL)
+ {
+ rest_of_decl_compilation (decl, NULL_PTR,
+ global_bindings_p (), 0);
+ }
+
+ /* ??? After 2.3, test (init != 0) instead of TREE_CODE. */
+ if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
+ && temporary && TREE_PERMANENT (decl))
+ {
+ /* We need to remember that this array HAD an initialization,
+ but discard the actual temporary nodes,
+ since we can't have a permanent node keep pointing to them. */
+ /* We make an exception for inline functions, since it's
+ normal for a local extern redeclaration of an inline function
+ to have a copy of the top-level decl's DECL_INLINE. */
+ if (DECL_INITIAL (decl) != 0)
+ DECL_INITIAL (decl) = error_mark_node;
+ }
+
+#if 0
+ /* Resume permanent allocation, if not within a function. */
+ /* The corresponding push_obstacks_nochange is in start_decl,
+ and in push_parm_decl and in grokfield. */
+ pop_obstacks ();
+#endif
+
+ /* If we have gone back from temporary to permanent allocation,
+ actually free the temporary space that we no longer need. */
+ if (temporary && !allocation_temporary_p ())
+ permanent_allocation (0);
+
+ /* At the end of a declaration, throw away any variable type sizes
+ of types defined inside that declaration. There is no use
+ computing them in the following function definition. */
+ if (current_scope == global_scope)
+ get_pending_sizes ();
+}
+
+/* If DECL has a cleanup, build and return that cleanup here.
+ This is a callback called by expand_expr. */
+
+tree
+maybe_build_cleanup (decl)
+ tree decl;
+{
+ /* There are no cleanups in C. */
+ return NULL_TREE;
+}
+\f
+/* Make TYPE a complete type based on INITIAL_VALUE.
+ Return 0 if successful, 1 if INITIAL_VALUE can't be deciphered,
+ 2 if there was no information (in which case assume 1 if DO_DEFAULT). */
+
+int
+complete_array_type (type, initial_value, do_default)
+ tree type, initial_value;
+ int do_default;
+{
+ /* Only needed so we can link with ../c-typeck.c. */
+ abort ();
+}
+\f
+/* Make sure that the tag NAME is defined *in the current binding level*
+ at least as a forward reference.
+ CODE says which kind of tag NAME ought to be.
+
+ We also do a push_obstacks_nochange
+ whose matching pop is in finish_struct. */
+
+tree
+start_struct (code, name)
+ enum chill_tree_code code;
+ tree name;
+{
+ /* If there is already a tag defined at this binding level
+ (as a forward reference), just return it. */
+
+ register tree ref = 0;
+
+ push_obstacks_nochange ();
+ if (current_scope == global_scope)
+ end_temporary_allocation ();
+
+ /* Otherwise create a forward-reference just so the tag is in scope. */
+
+ ref = make_node (code);
+/* pushtag (name, ref); */
+ return ref;
+}
+\f
+#if 0
+/* Function to help qsort sort FIELD_DECLs by name order. */
+
+static int
+field_decl_cmp (x, y)
+ tree *x, *y;
+{
+ return (long)DECL_NAME (*x) - (long)DECL_NAME (*y);
+}
+#endif
+/* Fill in the fields of a RECORD_TYPE or UNION_TYPE node, T.
+ FIELDLIST is a chain of FIELD_DECL nodes for the fields.
+
+ We also do a pop_obstacks to match the push in start_struct. */
+
+tree
+finish_struct (t, fieldlist)
+ register tree t, fieldlist;
+{
+ register tree x;
+
+ /* Install struct as DECL_CONTEXT of each field decl.
+ Also process specified field sizes.
+ Set DECL_FIELD_SIZE to the specified size, or 0 if none specified.
+ The specified size is found in the DECL_INITIAL.
+ Store 0 there, except for ": 0" fields (so we can find them
+ and delete them, below). */
+
+ for (x = fieldlist; x; x = TREE_CHAIN (x))
+ {
+ DECL_CONTEXT (x) = t;
+ DECL_FIELD_SIZE (x) = 0;
+ }
+
+ TYPE_FIELDS (t) = fieldlist;
+
+ if (pass != 1)
+ t = layout_chill_struct_type (t);
+
+ /* The matching push is in start_struct. */
+ pop_obstacks ();
+
+ return t;
+}
+
+/* Lay out the type T, and its element type, and so on. */
+
+static void
+layout_array_type (t)
+ tree t;
+{
+ if (TYPE_SIZE (t) != 0)
+ return;
+ if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
+ layout_array_type (TREE_TYPE (t));
+ layout_type (t);
+}
+\f
+/* Begin compiling the definition of an enumeration type.
+ NAME is its name (or null if anonymous).
+ Returns the type object, as yet incomplete.
+ Also records info about it so that build_enumerator
+ may be used to declare the individual values as they are read. */
+
+tree
+start_enum (name)
+ tree name;
+{
+ register tree enumtype;
+
+ /* If this is the real definition for a previous forward reference,
+ fill in the contents in the same object that used to be the
+ forward reference. */
+
+#if 0
+ /* The corresponding pop_obstacks is in finish_enum. */
+ push_obstacks_nochange ();
+ /* If these symbols and types are global, make them permanent. */
+ if (current_scope == global_scope)
+ end_temporary_allocation ();
+#endif
+
+ enumtype = make_node (ENUMERAL_TYPE);
+/* pushtag (name, enumtype); */
+ return enumtype;
+}
+\f
+/* Determine the precision this type needs. */
+unsigned
+get_type_precision (minnode, maxnode)
+ tree minnode, maxnode;
+{
+ unsigned precision = 0;
+
+ if (TREE_INT_CST_HIGH (minnode) >= 0
+ ? tree_int_cst_lt (TYPE_MAX_VALUE (unsigned_type_node), maxnode)
+ : (tree_int_cst_lt (minnode, TYPE_MIN_VALUE (integer_type_node))
+ || tree_int_cst_lt (TYPE_MAX_VALUE (integer_type_node), maxnode)))
+ precision = TYPE_PRECISION (long_long_integer_type_node);
+ else
+ {
+ HOST_WIDE_INT maxvalue = TREE_INT_CST_LOW (maxnode);
+ HOST_WIDE_INT minvalue = TREE_INT_CST_LOW (minnode);
+
+ if (maxvalue > 0)
+ precision = floor_log2 (maxvalue) + 1;
+ if (minvalue < 0)
+ {
+ /* Compute number of bits to represent magnitude of a negative value.
+ Add one to MINVALUE since range of negative numbers
+ includes the power of two. */
+ unsigned negprecision = floor_log2 (-minvalue - 1) + 1;
+ if (negprecision > precision)
+ precision = negprecision;
+ precision += 1; /* room for sign bit */
+ }
+
+ if (!precision)
+ precision = 1;
+ }
+ return precision;
+}
+\f
+void
+layout_enum (enumtype)
+ tree enumtype;
+{
+ register tree pair, tem;
+ tree minnode = 0, maxnode = 0;
+ unsigned precision = 0;
+
+ /* Do arithmetic using double integers, but don't use fold/build. */
+ union tree_node enum_next_node;
+ /* This is 1 plus the last enumerator constant value. */
+ tree enum_next_value = &enum_next_node;
+
+ /* Nonzero means that there was overflow computing enum_next_value. */
+ int enum_overflow = 0;
+
+ tree values = TYPE_VALUES (enumtype);
+
+ if (TYPE_SIZE (enumtype) != NULL_TREE)
+ return;
+
+ /* Initialize enum_next_value to zero. */
+ TREE_TYPE (enum_next_value) = integer_type_node;
+ TREE_INT_CST_LOW (enum_next_value) = TREE_INT_CST_LOW (integer_zero_node);
+ TREE_INT_CST_HIGH (enum_next_value) = TREE_INT_CST_HIGH (integer_zero_node);
+
+ /* After processing and defining all the values of an enumeration type,
+ install their decls in the enumeration type and finish it off.
+
+ TYPE_VALUES currently contains a list of (purpose: NAME, value: DECL).
+ This gets converted to a list of (purpose: NAME, value: VALUE). */
+
+
+ /* For each enumerator, calculate values, if defaulted.
+ Convert to correct type (the enumtype).
+ Also, calculate the minimum and maximum values. */
+
+ for (pair = values; pair; pair = TREE_CHAIN (pair))
+ {
+ tree decl = TREE_VALUE (pair);
+ tree value = DECL_INITIAL (decl);
+
+ /* Remove no-op casts from the value. */
+ if (value != NULL_TREE)
+ STRIP_TYPE_NOPS (value);
+
+ if (value != NULL_TREE)
+ {
+ if (TREE_CODE (value) == INTEGER_CST)
+ {
+ constant_expression_warning (value);
+ if (tree_int_cst_lt (value, integer_zero_node))
+ {
+ error ("enumerator value for `%s' is less then 0",
+ IDENTIFIER_POINTER (DECL_NAME (decl)));
+ value = error_mark_node;
+ }
+ }
+ else
+ {
+ error ("enumerator value for `%s' not integer constant",
+ IDENTIFIER_POINTER (DECL_NAME (decl)));
+ value = error_mark_node;
+ }
+ }
+
+ if (value != error_mark_node)
+ {
+ if (value == NULL_TREE) /* Default based on previous value. */
+ {
+ value = enum_next_value;
+ if (enum_overflow)
+ error ("overflow in enumeration values");
+ }
+ value = build_int_2 (TREE_INT_CST_LOW (value),
+ TREE_INT_CST_HIGH (value));
+ TREE_TYPE (value) = enumtype;
+ DECL_INITIAL (decl) = value;
+ CH_DERIVED_FLAG (value) = 1;
+
+ if (pair == values)
+ minnode = maxnode = value;
+ else
+ {
+ if (tree_int_cst_lt (maxnode, value))
+ maxnode = value;
+ if (tree_int_cst_lt (value, minnode))
+ minnode = value;
+ }
+
+ /* Set basis for default for next value. */
+ add_double (TREE_INT_CST_LOW (value), TREE_INT_CST_HIGH (value), 1, 0,
+ &TREE_INT_CST_LOW (enum_next_value),
+ &TREE_INT_CST_HIGH (enum_next_value));
+ enum_overflow = tree_int_cst_lt (enum_next_value, value);
+ }
+ else
+ DECL_INITIAL (decl) = value; /* error_mark_node */
+ }
+
+ /* Fix all error_mark_nodes in enum. Increment maxnode and assign value.
+ This is neccessary to make a duplicate value check in the enum */
+ for (pair = values; pair; pair = TREE_CHAIN (pair))
+ {
+ tree decl = TREE_VALUE (pair);
+ if (DECL_INITIAL (decl) == error_mark_node)
+ {
+ tree value;
+ add_double (TREE_INT_CST_LOW (maxnode), TREE_INT_CST_HIGH (maxnode), 1, 0,
+ &TREE_INT_CST_LOW (enum_next_value),
+ &TREE_INT_CST_HIGH (enum_next_value));
+ value = build_int_2 (TREE_INT_CST_LOW (enum_next_value),
+ TREE_INT_CST_HIGH (enum_next_value));
+ TREE_TYPE (value) = enumtype;
+ CH_DERIVED_FLAG (value) = 1;
+ DECL_INITIAL (decl) = value;
+
+ maxnode = value;
+ }
+ }
+
+ /* Now check if we have duplicate values within the enum */
+ for (pair = values; pair; pair = TREE_CHAIN (pair))
+ {
+ tree succ;
+ tree decl1 = TREE_VALUE (pair);
+ tree val1 = DECL_INITIAL (decl1);
+
+ for (succ = TREE_CHAIN (pair); succ; succ = TREE_CHAIN (succ))
+ {
+ if (pair != succ)
+ {
+ tree decl2 = TREE_VALUE (succ);
+ tree val2 = DECL_INITIAL (decl2);
+ if (tree_int_cst_equal (val1, val2))
+ error ("enumerators `%s' and `%s' have equal values",
+ IDENTIFIER_POINTER (DECL_NAME (decl1)),
+ IDENTIFIER_POINTER (DECL_NAME (decl2)));
+ }
+ }
+ }
+
+ TYPE_MIN_VALUE (enumtype) = minnode;
+ TYPE_MAX_VALUE (enumtype) = maxnode;
+
+ precision = get_type_precision (minnode, maxnode);
+
+ if (flag_short_enums || precision > TYPE_PRECISION (integer_type_node))
+ /* Use the width of the narrowest normal C type which is wide enough. */
+ TYPE_PRECISION (enumtype) = TYPE_PRECISION (type_for_size (precision, 1));
+ else
+ TYPE_PRECISION (enumtype) = TYPE_PRECISION (integer_type_node);
+
+ layout_type (enumtype);
+
+#if 0
+ /* An enum can have some negative values; then it is signed. */
+ TREE_UNSIGNED (enumtype) = ! tree_int_cst_lt (minnode, integer_zero_node);
+#else
+ /* Z200/1988 page 19 says:
+ For each pair of integer literal expression e1, e2 in the set list NUM (e1)
+ and NUM (e2) must deliver different non-negative results */
+ TREE_UNSIGNED (enumtype) = 1;
+#endif
+
+ for (pair = values; pair; pair = TREE_CHAIN (pair))
+ {
+ tree decl = TREE_VALUE (pair);
+ DECL_SIZE (decl) = TYPE_SIZE (enumtype);
+ DECL_ALIGN (decl) = TYPE_ALIGN (enumtype);
+
+ /* Set the TREE_VALUE to the name, rather than the decl,
+ since that is what the rest of the compiler expects. */
+ TREE_VALUE (pair) = DECL_INITIAL (decl);
+ }
+
+ /* Fix up all variant types of this enum type. */
+ for (tem = TYPE_MAIN_VARIANT (enumtype); tem; tem = TYPE_NEXT_VARIANT (tem))
+ {
+ TYPE_VALUES (tem) = TYPE_VALUES (enumtype);
+ TYPE_MIN_VALUE (tem) = TYPE_MIN_VALUE (enumtype);
+ TYPE_MAX_VALUE (tem) = TYPE_MAX_VALUE (enumtype);
+ TYPE_SIZE (tem) = TYPE_SIZE (enumtype);
+ TYPE_MODE (tem) = TYPE_MODE (enumtype);
+ TYPE_PRECISION (tem) = TYPE_PRECISION (enumtype);
+ TYPE_ALIGN (tem) = TYPE_ALIGN (enumtype);
+ TREE_UNSIGNED (tem) = TREE_UNSIGNED (enumtype);
+ }
+
+#if 0
+ /* This matches a push in start_enum. */
+ pop_obstacks ();
+#endif
+}
+\f
+tree
+finish_enum (enumtype, values)
+ register tree enumtype, values;
+{
+ TYPE_VALUES (enumtype) = values = nreverse (values);
+
+ /* If satisfy_decl is called on one of the enum CONST_DECLs,
+ this will make sure that the enumtype gets laid out then. */
+ for ( ; values; values = TREE_CHAIN (values))
+ TREE_TYPE (TREE_VALUE (values)) = enumtype;
+
+ return enumtype;
+}
+
+
+/* Build and install a CONST_DECL for one value of the
+ current enumeration type (one that was begun with start_enum).
+ Return a tree-list containing the CONST_DECL and its value.
+ Assignment of sequential values by default is handled here. */
+
+tree
+build_enumerator (name, value)
+ tree name, value;
+{
+ register tree decl;
+ int named = name != NULL_TREE;
+
+ if (pass == 2)
+ {
+ if (name)
+ (void) get_next_decl ();
+ return NULL_TREE;
+ }
+
+ if (name == NULL_TREE)
+ {
+ static int unnamed_value_warned = 0;
+ static int next_dummy_enum_value = 0;
+ char buf[20];
+ if (!unnamed_value_warned)
+ {
+ unnamed_value_warned = 1;
+ warning ("undefined value in SET mode is obsolete and deprecated.");
+ }
+ sprintf (buf, "__star_%d", next_dummy_enum_value++);
+ name = get_identifier (buf);
+ }
+
+ decl = build_decl (CONST_DECL, name, integer_type_node);
+ CH_DECL_ENUM (decl) = 1;
+ DECL_INITIAL (decl) = value;
+ if (named)
+ {
+ if (pass == 0)
+ {
+ push_obstacks_nochange ();
+ pushdecl (decl);
+ finish_decl (decl);
+ }
+ else
+ save_decl (decl);
+ }
+ return build_tree_list (name, decl);
+
+#if 0
+ tree old_value = lookup_name_current_level (name);
+
+ if (old_value != NULL_TREE
+ && TREE_CODE (old_value)=!= CONST_DECL
+ && (value == NULL_TREE || operand_equal_p (value, old_value, 1)))
+ {
+ if (value == NULL_TREE)
+ {
+ if (TREE_CODE (old_value) == CONST_DECL)
+ value = DECL_INITIAL (old_value);
+ else
+ abort ();
+ }
+ return saveable_tree_cons (old_value, value, NULL_TREE);
+ }
+#endif
+}
+\f
+/* Record that this function is going to be a varargs function.
+ This is called before store_parm_decls, which is too early
+ to call mark_varargs directly. */
+
+void
+c_mark_varargs ()
+{
+ c_function_varargs = 1;
+}
+\f
+/* Function needed for CHILL interface. */
+tree
+get_parm_decls ()
+{
+ return current_function_parms;
+}
+\f
+/* Save and restore the variables in this file and elsewhere
+ that keep track of the progress of compilation of the current function.
+ Used for nested functions. */
+
+struct c_function
+{
+ struct c_function *next;
+ struct scope *scope;
+ tree chill_result_decl;
+ int result_never_set;
+};
+
+struct c_function *c_function_chain;
+
+/* Save and reinitialize the variables
+ used during compilation of a C function. */
+
+void
+push_chill_function_context ()
+{
+ struct c_function *p
+ = (struct c_function *) xmalloc (sizeof (struct c_function));
+
+ push_function_context ();
+
+ p->next = c_function_chain;
+ c_function_chain = p;
+
+ p->scope = current_scope;
+ p->chill_result_decl = chill_result_decl;
+ p->result_never_set = result_never_set;
+}
+
+/* Restore the variables used during compilation of a C function. */
+
+void
+pop_chill_function_context ()
+{
+ struct c_function *p = c_function_chain;
+#if 0
+ tree link;
+ /* Bring back all the labels that were shadowed. */
+ for (link = shadowed_labels; link; link = TREE_CHAIN (link))
+ if (DECL_NAME (TREE_VALUE (link)) != 0)
+ IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
+ = TREE_VALUE (link);
+#endif
+
+ pop_function_context ();
+
+ c_function_chain = p->next;
+
+ current_scope = p->scope;
+ chill_result_decl = p->chill_result_decl;
+ result_never_set = p->result_never_set;
+
+ free (p);
+}
+\f
+/* Following from Jukka Virtanen's GNU Pascal */
+/* To implement WITH statement:
+
+ 1) Call shadow_record_fields for each record_type element in the WITH
+ element list. Each call creates a new binding level.
+
+ 2) construct a component_ref for EACH field in the record,
+ and store it to the IDENTIFIER_LOCAL_VALUE after adding
+ the old value to the shadow list
+
+ 3) let lookup_name do the rest
+
+ 4) pop all of the binding levels after the WITH statement ends.
+ (restoring old local values) You have to keep track of the number
+ of times you called it.
+*/
+\f
+/*
+ * Save an arbitrary tree-expression as the IDENTIFIER_LOCAL_VALUE
+ * of a name. Save the name's previous value. Check for name
+ * collisions with another value under the same name at the same
+ * nesting level. This is used to implement the DO WITH construct
+ * and the temporary for the location iteration loop.
+ */
+void
+save_expr_under_name (name, expr)
+ tree name, expr;
+{
+ tree alias = build_alias_decl (NULL_TREE, NULL_TREE, name);
+
+ DECL_ABSTRACT_ORIGIN (alias) = expr;
+ TREE_CHAIN (alias) = NULL_TREE;
+ pushdecllist (alias, 0);
+}
+
+void
+do_based_decl (name, mode, base_var)
+ tree name, mode, base_var;
+{
+ tree decl;
+ if (pass == 1)
+ {
+ push_obstacks (&permanent_obstack, &permanent_obstack);
+ decl = make_node (BASED_DECL);
+ DECL_NAME (decl) = name;
+ TREE_TYPE (decl) = mode;
+ DECL_ABSTRACT_ORIGIN (decl) = base_var;
+ save_decl (decl);
+ pop_obstacks ();
+ }
+ else
+ {
+ tree base_decl;
+ decl = get_next_decl ();
+ if (name != DECL_NAME (decl))
+ abort();
+ /* FIXME: This isn't a complete test */
+ base_decl = lookup_name (base_var);
+ if (base_decl == NULL_TREE)
+ error ("BASE variable never declared");
+ else if (TREE_CODE (base_decl) == FUNCTION_DECL)
+ error ("cannot BASE a variable on a PROC/PROCESS name");
+ }
+}
+
+void
+do_based_decls (names, mode, base_var)
+ tree names, mode, base_var;
+{
+ if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
+ {
+ for (; names != NULL_TREE; names = TREE_CHAIN (names))
+ do_based_decl (names, mode, base_var);
+ }
+ else if (TREE_CODE (names) != ERROR_MARK)
+ do_based_decl (names, mode, base_var);
+}
+
+/*
+ * Declare the fields so that lookup_name() will find them as
+ * component refs for Pascal WITH or CHILL DO WITH.
+ *
+ * Proceeds to the inner layers of Pascal/CHILL variant record
+ *
+ * Internal routine of shadow_record_fields ()
+ */
+static void
+handle_one_level (parent, fields)
+ tree parent, fields;
+{
+ tree field, name;
+
+ switch (TREE_CODE (TREE_TYPE (parent)))
+ {
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ for (field = fields; field; field = TREE_CHAIN (field)) {
+ name = DECL_NAME (field);
+ if (name == NULL_TREE || name == ELSE_VARIANT_NAME)
+ /* proceed through variant part */
+ handle_one_level (parent, TYPE_FIELDS (TREE_TYPE (field)));
+ else
+ {
+ tree field_alias = make_node (WITH_DECL);
+ DECL_NAME (field_alias) = name;
+ TREE_TYPE (field_alias) = TREE_TYPE (field);
+ DECL_ABSTRACT_ORIGIN (field_alias) = parent;
+ TREE_CHAIN (field_alias) = NULL_TREE;
+ pushdecllist (field_alias, 0);
+ }
+ }
+ break;
+ default:
+ error ("INTERNAL ERROR: handle_one_level is broken");
+ }
+}
+\f
+/*
+ * For each FIELD_DECL node in a RECORD_TYPE, we have to declare
+ * a name so that lookup_name will find a COMPONENT_REF node
+ * when the name is referenced. This happens in Pascal WITH statement.
+ */
+void
+shadow_record_fields (struct_val)
+ tree struct_val;
+{
+ tree type, parent;
+
+ if (pass == 1 || struct_val == NULL_TREE)
+ return;
+
+ handle_one_level (struct_val, TYPE_FIELDS (TREE_TYPE (struct_val)));
+}
+\f
+static char exception_prefix [] = "__Ex_";
+
+tree
+build_chill_exception_decl (name)
+ char *name;
+{
+ tree decl, ex_name, ex_init, ex_type;
+ int name_len = strlen (name);
+ char *ex_string = (char *)
+ alloca (strlen (exception_prefix) + name_len + 1);
+
+ sprintf(ex_string, "%s%s", exception_prefix, name);
+ ex_name = get_identifier (ex_string);
+ decl = IDENTIFIER_LOCAL_VALUE (ex_name);
+ if (decl)
+ return decl;
+
+ /* finish_decl is too eager about switching back to the
+ ambient context. This decl's rtl must live in the permanent_obstack. */
+ push_obstacks (&permanent_obstack, &permanent_obstack);
+ push_obstacks_nochange ();
+ ex_type = build_array_type (char_type_node,
+ build_index_2_type (integer_zero_node,
+ build_int_2 (name_len, 0)));
+ decl = build_lang_decl (VAR_DECL, ex_name, ex_type);
+ ex_init = build_string (name_len, name);
+ TREE_TYPE (ex_init) = ex_type;
+ DECL_INITIAL (decl) = ex_init;
+ TREE_READONLY (decl) = 1;
+ TREE_STATIC (decl) = 1;
+ pushdecl_top_level (decl);
+ finish_decl (decl);
+ pop_obstacks (); /* Return to the ambient context. */
+ return decl;
+}
+
+extern tree module_init_list;
+
+/*
+ * This function is called from the parser to preface the entire
+ * compilation. It contains module-level actions and reach-bound
+ * initialization.
+ */
+void
+start_outer_function ()
+{
+ start_chill_function (pass < 2 ? get_identifier ("_GLOBAL_")
+ : DECL_NAME (global_function_decl),
+ void_type_node, NULL_TREE, NULL_TREE, NULL_TREE);
+ global_function_decl = current_function_decl;
+ global_scope = current_scope;
+ chill_at_module_level = 1;
+}
+\f
+/* This function finishes the global_function_decl, and if it is non-empty
+ * (as indiacted by seen_action), adds it to module_init_list.
+ */
+void
+finish_outer_function ()
+{
+ /* If there was module-level code in this module (not just function
+ declarations), we allocate space for this module's init list entry,
+ and fill in the module's function's address. */
+
+ extern tree initializer_type;
+ char *fname_str = IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
+ char *init_entry_name = (char *)xmalloc ((unsigned)(strlen (fname_str) + 20));
+ tree init_entry_id;
+ tree init_entry_decl;
+ tree initializer;
+
+ finish_chill_function ();
+
+ chill_at_module_level = 0;
+
+
+ if (!seen_action)
+ return;
+
+ sprintf (init_entry_name, "__tmp_%s_init_entry", fname_str);
+ init_entry_id = get_identifier (init_entry_name);
+
+ init_entry_decl = build1 (ADDR_EXPR,
+ TREE_TYPE (TYPE_FIELDS (initializer_type)),
+ global_function_decl);
+ TREE_CONSTANT (init_entry_decl) = 1;
+ initializer = build (CONSTRUCTOR, initializer_type, NULL_TREE,
+ tree_cons (NULL_TREE, init_entry_decl,
+ build_tree_list (NULL_TREE,
+ null_pointer_node)));
+ TREE_CONSTANT (initializer) = 1;
+ init_entry_decl
+ = do_decl (init_entry_id, initializer_type, 1, 1, initializer, 0);
+ DECL_SOURCE_LINE (init_entry_decl) = 0;
+ if (pass == 1)
+ /* tell chill_finish_compile that there's
+ module-level code to be processed. */
+ module_init_list = integer_one_node;
+ else if (build_constructor)
+ module_init_list = tree_cons (global_function_decl,
+ init_entry_decl,
+ module_init_list);
+
+ make_decl_rtl (global_function_decl, NULL, 0);
+}
--- /dev/null
+/* Convert language-specific tree expression to rtl instructions,
+ for GNU CHILL compiler.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+#include "config.h"
+#include <stdio.h>
+#include "rtl.h"
+#include "tree.h"
+#include "flags.h"
+#include "expr.h"
+#include "ch-tree.h"
+#include "assert.h"
+#include "lex.h"
+#include "convert.h"
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+extern char **boolean_code_name;
+extern int flag_old_strings;
+extern tree long_unsigned_type_node;
+extern int ignore_case;
+extern int special_UC;
+
+extern void check_for_full_enumeration_handling PROTO((tree));
+extern void chill_handle_case_default PROTO((void));
+extern void error PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern void fatal PROTO((char *, ...));
+extern void sorry PROTO((char *, ...));
+extern tree stabilize_reference PROTO((tree));
+extern void warning PROTO((char *, ...));
+
+/* definitions for duration built-ins */
+#define MILLISECS_MULTIPLIER 1
+#define SECS_MULTIPLIER MILLISECS_MULTIPLIER * 1000
+#define MINUTES_MULTIPLIER SECS_MULTIPLIER * 60
+#define HOURS_MULTIPLIER MINUTES_MULTIPLIER * 60
+#define DAYS_MULTIPLIER HOURS_MULTIPLIER * 24
+
+/* the maximum value for each of the calls */
+#define MILLISECS_MAX 0xffffffff
+#define SECS_MAX 4294967
+#define MINUTES_MAX 71582
+#define HOURS_MAX 1193
+#define DAYS_MAX 49
+
+/* forward declaration */
+rtx chill_expand_expr PROTO((tree, rtx, enum machine_mode,
+ enum expand_modifier));
+
+/* variable to hold the type the DESCR built-in returns */
+static tree descr_type = NULL_TREE;
+
+\f
+/* called from ch-lex.l */
+void
+init_chill_expand ()
+{
+ lang_expand_expr = chill_expand_expr;
+}
+
+/* Take the address of something that needs to be passed by reference. */
+tree
+force_addr_of (value)
+ tree value;
+{
+ /* FIXME. Move to memory, if needed. */
+ if (TREE_CODE (value) == INDIRECT_REF)
+ return convert_to_pointer (ptr_type_node, TREE_OPERAND (value, 0));
+ mark_addressable (value);
+ return build1 (ADDR_EXPR, ptr_type_node, value);
+}
+
+/* Check that EXP has a known type. */
+
+tree
+check_have_mode (exp, context)
+ tree exp;
+ char *context;
+{
+ if (TREE_CODE (exp) != ERROR_MARK && TREE_TYPE (exp) == NULL_TREE)
+ {
+ if (TREE_CODE (exp) == CONSTRUCTOR)
+ error ("tuple without specified mode not allowed in %s", context);
+ else if (TREE_CODE (exp) == COND_EXPR || TREE_CODE (exp) == CASE_EXPR)
+ error ("conditional expression not allowed in %s", context);
+ else
+ error ("internal error: unknown expression mode in %s", context);
+
+ return error_mark_node;
+ }
+ return exp;
+}
+
+/* Check that EXP is discrete. Handle conversion if flag_old_strings. */
+
+tree
+check_case_selector (exp)
+ tree exp;
+{
+ if (exp != NULL_TREE && TREE_TYPE (exp) != NULL_TREE)
+ exp = convert_to_discrete (exp);
+ if (exp)
+ return exp;
+ error ("CASE selector is not a discrete expression");
+ return error_mark_node;
+}
+
+tree
+check_case_selector_list (list)
+ tree list;
+{
+ tree selector, exp, return_list = NULL_TREE;
+
+ for (selector = list; selector != NULL_TREE; selector = TREE_CHAIN (selector))
+ {
+ exp = check_case_selector (TREE_VALUE (selector));
+ if (exp == error_mark_node)
+ {
+ return_list = error_mark_node;
+ break;
+ }
+ return_list = tree_cons (TREE_PURPOSE (selector), exp, return_list);
+ }
+
+ return nreverse(return_list);
+}
+
+tree
+chill_expand_case_expr (expr)
+ tree expr;
+{
+ tree selector_list = TREE_OPERAND (expr, 0), selector;
+ tree alternatives = TREE_OPERAND (expr, 1);
+ tree type = TREE_TYPE (expr);
+ int else_seen = 0;
+ tree result;
+
+ if (TREE_CODE (selector_list) != TREE_LIST
+ || TREE_CODE (alternatives) != TREE_LIST)
+ abort();
+ if (TREE_CHAIN (selector_list) != NULL_TREE)
+ abort ();
+
+ /* make a temp for the case result */
+ result = decl_temp1 (get_unique_identifier ("CASE_EXPR"),
+ type, 0, NULL_TREE, 0, 0);
+
+ selector = check_case_selector (TREE_VALUE (selector_list));
+
+ expand_start_case (1, selector, TREE_TYPE (selector), "CASE expression");
+
+ alternatives = nreverse (alternatives);
+ for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
+ {
+ tree labels = TREE_PURPOSE (alternatives), t;
+
+ if (labels == NULL_TREE)
+ {
+ chill_handle_case_default ();
+ else_seen++;
+ }
+ else
+ {
+ tree label;
+ if (labels != NULL_TREE)
+ {
+ for (label = TREE_VALUE (labels);
+ label != NULL_TREE; label = TREE_CHAIN (label))
+ chill_handle_case_label (TREE_VALUE (label), selector);
+ labels = TREE_CHAIN (labels);
+ if (labels != NULL_TREE)
+ error ("The number of CASE selectors does not match the number "
+ "of CASE label lists");
+
+ }
+ }
+
+ t = build (MODIFY_EXPR, type, result,
+ convert (type, TREE_VALUE (alternatives)));
+ TREE_SIDE_EFFECTS (t) = 1;
+ expand_expr_stmt (t);
+ expand_exit_something ();
+ }
+
+ if (!else_seen)
+ {
+ chill_handle_case_default ();
+ expand_exit_something ();
+#if 0
+ expand_raise ();
+#endif
+
+ check_missing_cases (TREE_TYPE (selector));
+ }
+
+ expand_end_case (selector);
+ return result;
+}
+\f
+/* Hook used by expand_expr to expand CHILL-specific tree codes. */
+
+rtx
+chill_expand_expr (exp, target, tmode, modifier)
+ tree exp;
+ rtx target;
+ enum machine_mode tmode;
+ enum expand_modifier modifier;
+{
+ tree type = TREE_TYPE (exp);
+ register enum machine_mode mode = TYPE_MODE (type);
+ register enum tree_code code = TREE_CODE (exp);
+ rtx original_target = target;
+ rtx op0, op1;
+ int ignore = target == const0_rtx;
+ char *lib_func; /* name of library routine */
+
+ if (ignore)
+ target = 0, original_target = 0;
+
+ /* No sense saving up arithmetic to be done
+ if it's all in the wrong mode to form part of an address.
+ And force_operand won't know whether to sign-extend or zero-extend. */
+
+ if (mode != Pmode && modifier == EXPAND_SUM)
+ modifier = EXPAND_NORMAL;
+
+ switch (code)
+ {
+ case STRING_EQ_EXPR:
+ case STRING_LT_EXPR:
+ {
+ rtx func = gen_rtx (SYMBOL_REF, Pmode,
+ code == STRING_EQ_EXPR ? "__eqstring"
+ : "__ltstring");
+ tree exp0 = TREE_OPERAND (exp, 0);
+ tree exp1 = TREE_OPERAND (exp, 1);
+ tree size0, size1;
+ rtx op0, op1, siz0, siz1;
+ if (chill_varying_type_p (TREE_TYPE (exp0)))
+ {
+ exp0 = save_if_needed (exp0);
+ size0 = convert (integer_type_node,
+ build_component_ref (exp0, var_length_id));
+ exp0 = build_component_ref (exp0, var_data_id);
+ }
+ else
+ size0 = size_in_bytes (TREE_TYPE (exp0));
+ if (chill_varying_type_p (TREE_TYPE (exp1)))
+ {
+ exp1 = save_if_needed (exp1);
+ size1 = convert (integer_type_node,
+ build_component_ref (exp1, var_length_id));
+ exp1 = build_component_ref (exp1, var_data_id);
+ }
+ else
+ size1 = size_in_bytes (TREE_TYPE (exp1));
+
+ op0 = expand_expr (force_addr_of (exp0),
+ NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
+ op1 = expand_expr (force_addr_of (exp1),
+ NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
+ siz0 = expand_expr (size0, NULL_RTX, VOIDmode, 0);
+ siz1 = expand_expr (size1, NULL_RTX, VOIDmode, 0);
+ return emit_library_call_value (func, target,
+ 0, QImode, 4,
+ op0, GET_MODE (op0),
+ siz0, TYPE_MODE (sizetype),
+ op1, GET_MODE (op1),
+ siz1, TYPE_MODE (sizetype));
+ }
+
+ case CASE_EXPR:
+ return expand_expr (chill_expand_case_expr (exp),
+ NULL_RTX, VOIDmode, 0);
+ break;
+
+ case SLICE_EXPR:
+ {
+ tree func_call;
+ tree array = TREE_OPERAND (exp, 0);
+ tree min_value = TREE_OPERAND (exp, 1);
+ tree length = TREE_OPERAND (exp, 2);
+ tree new_type = TREE_TYPE (exp);
+ tree temp = decl_temp1 (get_unique_identifier ("BITSTRING"),
+ new_type, 0, NULL_TREE, 0, 0);
+ if (! CH_REFERABLE (array) && TYPE_MODE (TREE_TYPE (array)) != BLKmode)
+ array = decl_temp1 (get_unique_identifier ("BSTRINGVAL"),
+ TREE_TYPE (array), 0, array, 0, 0);
+ func_call = build_chill_function_call (
+ lookup_name (get_identifier ("__psslice")),
+ tree_cons (NULL_TREE,
+ build_chill_addr_expr (temp, (char *)0),
+ tree_cons (NULL_TREE, length,
+ tree_cons (NULL_TREE,
+ force_addr_of (array),
+ tree_cons (NULL_TREE, powersetlen (array),
+ tree_cons (NULL_TREE, convert (integer_type_node, min_value),
+ tree_cons (NULL_TREE, length, NULL_TREE)))))));
+ expand_expr (func_call, const0_rtx, VOIDmode, 0);
+ emit_queue ();
+ return expand_expr (temp, ignore ? const0_rtx : target,
+ VOIDmode, 0);
+ }
+
+ /* void __concatstring (char *out, char *left, unsigned left_len,
+ char *right, unsigned right_len) */
+ case CONCAT_EXPR:
+ {
+ tree exp0 = TREE_OPERAND (exp, 0);
+ tree exp1 = TREE_OPERAND (exp, 1);
+ rtx size0, size1;
+ rtx targetx;
+
+ if (TREE_CODE (exp1) == UNDEFINED_EXPR)
+ {
+ if (TYPE_MODE (TREE_TYPE (exp0)) == BLKmode
+ && TYPE_MODE (TREE_TYPE (exp)) == BLKmode)
+ {
+ rtx temp = expand_expr (exp0, target, tmode, modifier);
+ if (temp == target || target == NULL_RTX)
+ return temp;
+ emit_block_move (target, temp, expr_size (exp0),
+ TYPE_ALIGN (TREE_TYPE(exp0)) / BITS_PER_UNIT);
+ return target;
+ }
+ else
+ {
+ exp0 = force_addr_of (exp0);
+ exp0 = convert (build_pointer_type (TREE_TYPE (exp)), exp0);
+ exp0 = build1 (INDIRECT_REF, TREE_TYPE (exp), exp0);
+ return expand_expr (exp0,
+ NULL_RTX, Pmode, EXPAND_CONST_ADDRESS);
+ }
+ }
+
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ {
+ /* No need to handle scalars or varying strings here, since that
+ was done in convert or build_concat_expr. */
+ size0 = expand_expr (size_in_bytes (TREE_TYPE (exp0)),
+ NULL_RTX, Pmode, EXPAND_CONST_ADDRESS);
+
+ size1 = expand_expr (size_in_bytes (TREE_TYPE (exp1)),
+ NULL_RTX, Pmode, EXPAND_CONST_ADDRESS);
+
+ /* build a temp for the result, target is its address */
+ if (target == NULL_RTX)
+ {
+ tree type0 = TREE_TYPE (exp0);
+ tree type1 = TREE_TYPE (exp1);
+ int len0 = int_size_in_bytes (type0);
+ int len1 = int_size_in_bytes (type1);
+
+ if (len0 < 0 && TYPE_ARRAY_MAX_SIZE (type0)
+ && TREE_CODE (TYPE_ARRAY_MAX_SIZE (type0)) == INTEGER_CST)
+ len0 = TREE_INT_CST_LOW (TYPE_ARRAY_MAX_SIZE (type0));
+
+ if (len1 < 0 && TYPE_ARRAY_MAX_SIZE (type1)
+ && TREE_CODE (TYPE_ARRAY_MAX_SIZE (type1)) == INTEGER_CST)
+ len1 = TREE_INT_CST_LOW (TYPE_ARRAY_MAX_SIZE (type1));
+
+ if (len0 < 0 || len1 < 0)
+ fatal ("internal error - don't know how much space is needed for concatenation");
+ target = assign_stack_temp (mode, len0 + len1, 0);
+ preserve_temp_slots (target);
+ }
+ }
+ else if (TREE_CODE (type) == SET_TYPE)
+ {
+ if (target == NULL_RTX)
+ {
+ target = assign_stack_temp (mode, int_size_in_bytes (type), 0);
+ preserve_temp_slots (target);
+ }
+ }
+ else
+ abort ();
+
+ if (GET_CODE (target) == MEM)
+ targetx = target;
+ else
+ targetx = assign_stack_temp (mode, GET_MODE_SIZE (mode), 0);
+
+ /* expand 1st operand to a pointer to the array */
+ op0 = expand_expr (force_addr_of (exp0),
+ NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
+
+ /* expand 2nd operand to a pointer to the array */
+ op1 = expand_expr (force_addr_of (exp1),
+ NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
+
+ if (TREE_CODE (type) == SET_TYPE)
+ {
+ size0 = expand_expr (powersetlen (exp0),
+ NULL_RTX, VOIDmode, 0);
+ size1 = expand_expr (powersetlen (exp1),
+ NULL_RTX, VOIDmode, 0);
+
+ emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__concatps"),
+ 0, Pmode, 5, XEXP (targetx, 0), Pmode,
+ op0, GET_MODE (op0),
+ convert_to_mode (TYPE_MODE (sizetype),
+ size0, TREE_UNSIGNED (sizetype)),
+ TYPE_MODE (sizetype),
+ op1, GET_MODE (op1),
+ convert_to_mode (TYPE_MODE (sizetype),
+ size1, TREE_UNSIGNED (sizetype)),
+ TYPE_MODE (sizetype));
+ }
+ else
+ {
+ /* copy left, then right array to target */
+ emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__concatstring"),
+ 0, Pmode, 5, XEXP (targetx, 0), Pmode,
+ op0, GET_MODE (op0),
+ convert_to_mode (TYPE_MODE (sizetype),
+ size0, TREE_UNSIGNED (sizetype)),
+ TYPE_MODE (sizetype),
+ op1, GET_MODE (op1),
+ convert_to_mode (TYPE_MODE (sizetype),
+ size1, TREE_UNSIGNED (sizetype)),
+ TYPE_MODE (sizetype));
+ }
+ if (targetx != target)
+ emit_move_insn (target, targetx);
+ return target;
+ }
+\f
+ /* FIXME: the set_length computed below is a compile-time constant;
+ you'll need to re-write that part for VARYING bit arrays, and
+ possibly the set pointer will need to be adjusted to point past
+ the word containing its dynamic length. */
+
+ /* void __notpowerset (char *out, char *src,
+ unsigned long bitlength) */
+ case SET_NOT_EXPR:
+ {
+
+ tree expr = TREE_OPERAND (exp, 0);
+ tree tsize = powersetlen (expr);
+ rtx targetx;
+
+ if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE)
+ tsize = fold (build (MULT_EXPR, sizetype, tsize,
+ size_int (BITS_PER_UNIT)));
+
+ /* expand 1st operand to a pointer to the set */
+ op0 = expand_expr (force_addr_of (expr),
+ NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
+
+ /* build a temp for the result, target is its address */
+ if (target == NULL_RTX)
+ {
+ target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)),
+ int_size_in_bytes (TREE_TYPE (exp)),
+ 0);
+ preserve_temp_slots (target);
+ }
+ if (GET_CODE (target) == MEM)
+ targetx = target;
+ else
+ targetx = assign_stack_temp (GET_MODE (target),
+ GET_MODE_SIZE (GET_MODE (target)),
+ 0);
+ emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__notpowerset"),
+ 0, VOIDmode, 3, XEXP (targetx, 0), Pmode,
+ op0, GET_MODE (op0),
+ expand_expr (tsize, NULL_RTX, MEM,
+ EXPAND_CONST_ADDRESS),
+ TYPE_MODE (long_unsigned_type_node));
+ if (targetx != target)
+ emit_move_insn (target, targetx);
+ return target;
+ }
+
+ case SET_DIFF_EXPR:
+ lib_func = "__diffpowerset";
+ goto format_2;
+
+ case SET_IOR_EXPR:
+ lib_func = "__orpowerset";
+ goto format_2;
+
+ case SET_XOR_EXPR:
+ lib_func = "__xorpowerset";
+ goto format_2;
+
+ /* void __diffpowerset (char *out, char *left, char *right,
+ unsigned bitlength) */
+ case SET_AND_EXPR:
+ lib_func = "__andpowerset";
+ format_2:
+ {
+ tree expr = TREE_OPERAND (exp, 0);
+ tree tsize = powersetlen (expr);
+ rtx targetx;
+
+ if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE)
+ tsize = fold (build (MULT_EXPR, long_unsigned_type_node,
+ tsize,
+ size_int (BITS_PER_UNIT)));
+
+ /* expand 1st operand to a pointer to the set */
+ op0 = expand_expr (force_addr_of (expr),
+ NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
+
+ /* expand 2nd operand to a pointer to the set */
+ op1 = expand_expr (force_addr_of (TREE_OPERAND (exp, 1)),
+ NULL_RTX, MEM,
+ EXPAND_CONST_ADDRESS);
+
+/* FIXME: re-examine this code - the unary operator code above has recently
+ (93/03/12) been changed a lot. Should this code also change? */
+ /* build a temp for the result, target is its address */
+ if (target == NULL_RTX)
+ {
+ target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)),
+ int_size_in_bytes (TREE_TYPE (exp)),
+ 0);
+ preserve_temp_slots (target);
+ }
+ if (GET_CODE (target) == MEM)
+ targetx = target;
+ else
+ targetx = assign_stack_temp (GET_MODE (target),
+ GET_MODE_SIZE (GET_MODE (target)), 0);
+ emit_library_call (gen_rtx(SYMBOL_REF, Pmode, lib_func),
+ 0, VOIDmode, 4, XEXP (targetx, 0), Pmode,
+ op0, GET_MODE (op0), op1, GET_MODE (op1),
+ expand_expr (tsize, NULL_RTX, MEM,
+ EXPAND_CONST_ADDRESS),
+ TYPE_MODE (long_unsigned_type_node));
+ if (target != targetx)
+ emit_move_insn (target, targetx);
+ return target;
+ }
+
+ case SET_IN_EXPR:
+ {
+ extern tree lookup_name PROTO((tree));
+ tree set = TREE_OPERAND (exp, 1);
+ tree pos = convert (long_unsigned_type_node, TREE_OPERAND (exp, 0));
+ tree set_type = TREE_TYPE (set);
+ tree set_length = discrete_count (TYPE_DOMAIN (set_type));
+ tree min_val = convert (long_integer_type_node,
+ TYPE_MIN_VALUE (TYPE_DOMAIN (set_type)));
+ tree fcall;
+
+ /* FIXME: Function-call not needed if pos and width are constant! */
+ if (! mark_addressable (set))
+ {
+ error ("powerset is not addressable");
+ return const0_rtx;
+ }
+ /* we use different functions for bitstrings and powersets */
+ if (CH_BOOLS_TYPE_P (set_type))
+ fcall =
+ build_chill_function_call (
+ lookup_name (get_identifier ("__inbitstring")),
+ tree_cons (NULL_TREE,
+ convert (long_unsigned_type_node, pos),
+ tree_cons (NULL_TREE,
+ build1 (ADDR_EXPR, build_pointer_type (set_type), set),
+ tree_cons (NULL_TREE,
+ convert (long_unsigned_type_node, set_length),
+ tree_cons (NULL_TREE, min_val,
+ tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
+ build_tree_list (NULL_TREE, get_chill_linenumber ())))))));
+ else
+ fcall =
+ build_chill_function_call (
+ lookup_name (get_identifier ("__inpowerset")),
+ tree_cons (NULL_TREE,
+ convert (long_unsigned_type_node, pos),
+ tree_cons (NULL_TREE,
+ build1 (ADDR_EXPR, build_pointer_type (set_type), set),
+ tree_cons (NULL_TREE,
+ convert (long_unsigned_type_node, set_length),
+ build_tree_list (NULL_TREE, min_val)))));
+ return expand_expr (fcall, NULL_RTX, VOIDmode, 0);
+ }
+
+ case PACKED_ARRAY_REF:
+ {
+ extern tree lookup_name PROTO((tree));
+ tree array = TREE_OPERAND (exp, 0);
+ tree pos = save_expr (TREE_OPERAND (exp, 1));
+ tree array_type = TREE_TYPE (array);
+ tree array_length = discrete_count (TYPE_DOMAIN (array_type));
+ tree min_val = convert (long_integer_type_node,
+ TYPE_MIN_VALUE (TYPE_DOMAIN (array_type)));
+ tree fcall;
+
+ /* FIXME: Function-call not needed if pos and width are constant! */
+ /* TODO: make sure this makes sense. */
+ if (! mark_addressable (array))
+ {
+ error ("array is not addressable");
+ return const0_rtx;
+ }
+ fcall =
+ build_chill_function_call (
+ lookup_name (get_identifier ("__inpowerset")),
+ tree_cons (NULL_TREE,
+ convert (long_unsigned_type_node, pos),
+ tree_cons (NULL_TREE,
+ build1 (ADDR_EXPR, build_pointer_type (array_type), array),
+ tree_cons (NULL_TREE,
+ convert (long_unsigned_type_node, array_length),
+ build_tree_list (NULL_TREE, min_val)))));
+ return expand_expr (fcall, NULL_RTX, VOIDmode, 0);
+ }
+
+ case UNDEFINED_EXPR:
+ if (target == 0)
+ {
+ target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)),
+ int_size_in_bytes (TREE_TYPE (exp)), 0);
+ preserve_temp_slots (target);
+ }
+ /* We don't actually need to *do* anything ... */
+ return target;
+
+ default:
+ break;
+ }
+
+ /* NOTREACHED */
+ return NULL;
+}
+\f
+/* Check that the argument list has a length in [min_length .. max_length].
+ (max_length == -1 means "infinite".)
+ If so return the actual length.
+ Otherwise, return an error message and return -1. */
+
+static int
+check_arglist_length (args, min_length, max_length, name)
+ tree args;
+ int min_length;
+ int max_length;
+ tree name;
+{
+ int length = list_length (args);
+ if (length < min_length)
+ error ("Too few arguments in call to `%s'", IDENTIFIER_POINTER (name));
+ else if (max_length != -1 && length > max_length)
+ error ("Too many arguments in call to `%s'", IDENTIFIER_POINTER (name));
+ else
+ return length;
+ return -1;
+}
+\f
+/*
+ * This is the code from c-typeck.c, with the C-specific cruft
+ * removed (possibly I just didn't understand it, but it was
+ * apparently simply discarding part of my LIST).
+ */
+static tree
+internal_build_compound_expr (list, first_p)
+ tree list;
+ int first_p;
+{
+ register tree rest;
+
+ if (TREE_CHAIN (list) == 0)
+ return TREE_VALUE (list);
+
+ rest = internal_build_compound_expr (TREE_CHAIN (list), FALSE);
+
+ if (! TREE_SIDE_EFFECTS (TREE_VALUE (list)))
+ return rest;
+
+ return build (COMPOUND_EXPR, TREE_TYPE (rest), TREE_VALUE (list), rest);
+}
+
+
+/* Given a list of expressions, return a compound expression
+ that performs them all and returns the value of the last of them. */
+/* FIXME: this should be merged with the C version */
+tree
+build_chill_compound_expr (list)
+ tree list;
+{
+ return internal_build_compound_expr (list, TRUE);
+}
+\f
+/* Given an expression PTR for a pointer, return an expression
+ for the value pointed to.
+ do_empty_check is 0, don't perform a NULL pointer check,
+ else do it. */
+
+tree
+build_chill_indirect_ref (ptr, mode, do_empty_check)
+ tree ptr;
+ tree mode;
+ int do_empty_check;
+{
+ register tree type;
+
+ if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK)
+ return ptr;
+ if (mode != NULL_TREE && TREE_CODE (mode) == ERROR_MARK)
+ return error_mark_node;
+
+ type = TREE_TYPE (ptr);
+
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ {
+ type = TREE_TYPE (type);
+ ptr = convert (type, ptr);
+ }
+
+ /* check for ptr is really a POINTER */
+ if (TREE_CODE (type) != POINTER_TYPE)
+ {
+ error ("cannot dereference, not a pointer.");
+ return error_mark_node;
+ }
+
+ if (mode && TREE_CODE (mode) == IDENTIFIER_NODE)
+ {
+ tree decl = lookup_name (mode);
+ if (decl == NULL_TREE || TREE_CODE (decl) != TYPE_DECL)
+ {
+ if (pass == 2)
+ error ("missing '.' operator or undefined mode name `%s'.",
+ IDENTIFIER_POINTER (mode));
+#if 0
+ error ("You have forgotten the '.' operator which must");
+ error (" precede a STRUCT field reference, or `%s' is an undefined mode",
+ IDENTIFIER_POINTER (mode));
+#endif
+ return error_mark_node;
+ }
+ }
+
+ if (mode)
+ {
+ mode = get_type_of (mode);
+ ptr = convert (build_pointer_type (mode), ptr);
+ }
+ else if (type == ptr_type_node)
+ {
+ error ("Can't dereference PTR value using unary `->'.");
+ return error_mark_node;
+ }
+
+ if (do_empty_check)
+ ptr = check_non_null (ptr);
+
+ type = TREE_TYPE (ptr);
+
+ if (TREE_CODE (type) == POINTER_TYPE)
+ {
+ if (TREE_CODE (ptr) == ADDR_EXPR
+ && !flag_volatile
+ && (TREE_TYPE (TREE_OPERAND (ptr, 0))
+ == TREE_TYPE (type)))
+ return TREE_OPERAND (ptr, 0);
+ else
+ {
+ tree t = TREE_TYPE (type);
+ register tree ref = build1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (t), ptr);
+
+ if (TYPE_SIZE (t) == 0 && TREE_CODE (t) != ARRAY_TYPE)
+ {
+ error ("dereferencing pointer to incomplete type");
+ return error_mark_node;
+ }
+ if (TREE_CODE (t) == VOID_TYPE)
+ warning ("dereferencing `void *' pointer");
+
+ /* We *must* set TREE_READONLY when dereferencing a pointer to const,
+ so that we get the proper error message if the result is used
+ to assign to. Also, &* is supposed to be a no-op.
+ And ANSI C seems to specify that the type of the result
+ should be the const type. */
+ /* A de-reference of a pointer to const is not a const. It is valid
+ to change it via some other pointer. */
+ TREE_READONLY (ref) = TYPE_READONLY (t);
+ TREE_SIDE_EFFECTS (ref)
+ = TYPE_VOLATILE (t) || TREE_SIDE_EFFECTS (ptr) || flag_volatile;
+ TREE_THIS_VOLATILE (ref) = TYPE_VOLATILE (t) || flag_volatile;
+ return ref;
+ }
+ }
+ else if (TREE_CODE (ptr) != ERROR_MARK)
+ error ("invalid type argument of `->'");
+ return error_mark_node;
+}
+
+/* NODE is a COMPONENT_REF whose mode is an IDENTIFIER,
+ which is replaced by the proper FIELD_DECL.
+ Also do the right thing for variant records. */
+
+tree
+resolve_component_ref (node)
+ tree node;
+{
+ tree datum = TREE_OPERAND (node, 0);
+ tree field_name = TREE_OPERAND (node, 1);
+ tree type = TREE_TYPE (datum);
+ tree field;
+ if (TREE_CODE (datum) == ERROR_MARK)
+ return error_mark_node;
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ {
+ type = TREE_TYPE (type);
+ TREE_OPERAND (node, 0) = datum = convert (type, datum);
+ }
+ if (TREE_CODE (type) != RECORD_TYPE)
+ {
+ error ("operand of '.' is not a STRUCT");
+ return error_mark_node;
+ }
+
+ TREE_READONLY (node) = TREE_READONLY (datum);
+ TREE_SIDE_EFFECTS (node) = TREE_SIDE_EFFECTS (datum);
+
+ for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (TREE_TYPE (field)) == UNION_TYPE)
+ {
+ tree variant;
+ for (variant = TYPE_FIELDS (TREE_TYPE (field));
+ variant; variant = TREE_CHAIN (variant))
+ {
+ tree vfield;
+ for (vfield = TYPE_FIELDS (TREE_TYPE (variant));
+ vfield; vfield = TREE_CHAIN (vfield))
+ {
+ if (DECL_NAME (vfield) == field_name)
+ { /* Found a variant field */
+ datum = build (COMPONENT_REF, TREE_TYPE (field),
+ datum, field);
+ datum = build (COMPONENT_REF, TREE_TYPE (variant),
+ datum, variant);
+ TREE_OPERAND (node, 0) = datum;
+ TREE_OPERAND (node, 1) = vfield;
+ TREE_TYPE (node) = TREE_TYPE (vfield);
+ TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node));
+#if 0
+ if (flag_testing_tags)
+ {
+ tree tagtest = NOT IMPLEMENTED;
+ tree tagf = ridpointers[(int) RID_RANGEFAIL];
+ node = check_expression (node, tagtest,
+ tagf);
+ }
+#endif
+ return node;
+ }
+ }
+ }
+ }
+
+ if (DECL_NAME (field) == field_name)
+ { /* Found a fixed field */
+ TREE_OPERAND (node, 1) = field;
+ TREE_TYPE (node) = TREE_TYPE (field);
+ TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node));
+ return fold (node);
+ }
+ }
+
+ error ("No field named `%s'", IDENTIFIER_POINTER (field_name));
+ return error_mark_node;
+}
+
+tree
+build_component_ref (datum, field_name)
+ tree datum, field_name;
+{
+ tree node = build_nt (COMPONENT_REF, datum, field_name);
+ if (pass != 1)
+ node = resolve_component_ref (node);
+ return node;
+}
+
+/*
+ function checks (for build_chill_component_ref) if a given
+ type is really an instance type. CH_IS_INSTANCE_MODE is not
+ strict enough in this case, i.e. SYNMODE foo = STRUCT (a, b UINT)
+ is compatible to INSTANCE. */
+
+static int
+is_really_instance (type)
+ tree type;
+{
+ tree decl = TYPE_NAME (type);
+
+ if (decl == NULL_TREE)
+ /* this is not an instance */
+ return 0;
+
+ if (DECL_NAME (decl) == ridpointers[(int)RID_INSTANCE])
+ /* this is an instance */
+ return 1;
+
+ if (TYPE_FIELDS (type) == TYPE_FIELDS (instance_type_node))
+ /* we have a NEWMODE'd instance */
+ return 1;
+
+ return 0;
+}
+
+/* This function is called by the parse.
+ Here we check if the user tries to access a field in a type which is
+ layouted as a structure but isn't like INSTANCE, BUFFER, EVENT, ASSOCIATION,
+ ACCESS, TEXT, or VARYING array or character string.
+ We don't do this in build_component_ref cause this function gets
+ called from the compiler to access fields in one of the above mentioned
+ modes. */
+tree
+build_chill_component_ref (datum, field_name)
+ tree datum, field_name;
+{
+ tree type = TREE_TYPE (datum);
+ if ((type != NULL_TREE && TREE_CODE (type) == RECORD_TYPE) &&
+ ((CH_IS_INSTANCE_MODE (type) && is_really_instance (type)) ||
+ CH_IS_BUFFER_MODE (type) ||
+ CH_IS_EVENT_MODE (type) || CH_IS_ASSOCIATION_MODE (type) ||
+ CH_IS_ACCESS_MODE (type) || CH_IS_TEXT_MODE (type) ||
+ chill_varying_type_p (type)))
+ {
+ error ("operand of '.' is not a STRUCT");
+ return error_mark_node;
+ }
+ return build_component_ref (datum, field_name);
+}
+\f
+/*
+ * Check for invalid binary operands & unary operands
+ * RIGHT is 1 if checking right operand or unary operand;
+ * it is 0 if checking left operand.
+ *
+ * return 1 if the given operand is NOT compatible as the
+ * operand of the given operator
+ *
+ * return 0 if they might be compatible
+ */
+static int
+invalid_operand (code, type, right)
+ enum chill_tree_code code;
+ tree type;
+ int right; /* 1 if right operand */
+{
+ switch ((int)code)
+ {
+ case ADDR_EXPR:
+ break;
+ case BIT_AND_EXPR:
+ case BIT_IOR_EXPR:
+ case BIT_NOT_EXPR:
+ case BIT_XOR_EXPR:
+ goto relationals;
+ case CASE_EXPR:
+ break;
+ case CEIL_MOD_EXPR:
+ goto numerics;
+ case CONCAT_EXPR: /* must be static or varying char array */
+ if (TREE_CODE (type) == CHAR_TYPE)
+ return 0;
+ if (TREE_CODE (type) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
+ return 0;
+ if (!chill_varying_type_p (type))
+ return 1;
+ if (TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type)))
+ == CHAR_TYPE)
+ return 0;
+ else
+ return 1;
+ /* note: CHILL conditional expressions (COND_EXPR) won't come
+ * through here; they're routed straight to C-specific code */
+ case EQ_EXPR:
+ return 0; /* ANYTHING can be compared equal */
+ case FLOOR_MOD_EXPR:
+ if (TREE_CODE (type) == REAL_TYPE)
+ return 1;
+ goto numerics;
+ case GE_EXPR:
+ case GT_EXPR:
+ goto relatables;
+ case SET_IN_EXPR:
+ if (TREE_CODE (type) == SET_TYPE)
+ return 0;
+ else
+ return 1;
+ case PACKED_ARRAY_REF:
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ return 0;
+ else
+ return 1;
+ case LE_EXPR:
+ case LT_EXPR:
+ relatables:
+ switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */
+ {
+ case ARRAY_TYPE:
+ if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
+ return 0;
+ else
+ return 1;
+ case BOOLEAN_TYPE:
+ case CHAR_TYPE:
+ case COMPLEX_TYPE:
+ case ENUMERAL_TYPE:
+ case INTEGER_TYPE:
+ case OFFSET_TYPE:
+ case POINTER_TYPE:
+ case REAL_TYPE:
+ case SET_TYPE:
+ return 0;
+ case FILE_TYPE:
+ case FUNCTION_TYPE:
+ case GRANT_TYPE:
+ case LANG_TYPE:
+ case METHOD_TYPE:
+ return 1;
+ case RECORD_TYPE:
+ if (chill_varying_type_p (type)
+ && TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type))) == CHAR_TYPE)
+ return 0;
+ else
+ return 1;
+ case REFERENCE_TYPE:
+ case SEIZE_TYPE:
+ case UNION_TYPE:
+ case VOID_TYPE:
+ return 1;
+ }
+ break;
+ case MINUS_EXPR:
+ case MULT_EXPR:
+ goto numerics;
+ case NEGATE_EXPR:
+ if (TREE_CODE (type) == BOOLEAN_TYPE)
+ return 0;
+ else
+ goto numerics;
+ case NE_EXPR:
+ return 0; /* ANYTHING can be compared unequal */
+ case NOP_EXPR:
+ return 0; /* ANYTHING can be converted */
+ case PLUS_EXPR:
+ numerics:
+ switch ((int)TREE_CODE(type)) /* left operand must be discrete type */
+ {
+ case ARRAY_TYPE:
+ if (right || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE)
+ return 1;
+ else
+ return 0;
+ case CHAR_TYPE:
+ return right;
+ case BOOLEAN_TYPE:
+ case COMPLEX_TYPE:
+ case FILE_TYPE:
+ case FUNCTION_TYPE:
+ case GRANT_TYPE:
+ case LANG_TYPE:
+ case METHOD_TYPE:
+ case RECORD_TYPE:
+ case REFERENCE_TYPE:
+ case SEIZE_TYPE:
+ case UNION_TYPE:
+ case VOID_TYPE:
+ return 1;
+ case ENUMERAL_TYPE:
+ case INTEGER_TYPE:
+ case OFFSET_TYPE:
+ case POINTER_TYPE:
+ case REAL_TYPE:
+ case SET_TYPE:
+ return 0;
+ }
+ break;
+ case RANGE_EXPR:
+ break;
+
+ case REPLICATE_EXPR:
+ switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */
+ {
+ case COMPLEX_TYPE:
+ case FILE_TYPE:
+ case FUNCTION_TYPE:
+ case GRANT_TYPE:
+ case LANG_TYPE:
+ case METHOD_TYPE:
+ case OFFSET_TYPE:
+ case POINTER_TYPE:
+ case RECORD_TYPE:
+ case REAL_TYPE:
+ case SEIZE_TYPE:
+ case UNION_TYPE:
+ case VOID_TYPE:
+ return 1;
+ case ARRAY_TYPE:
+ case BOOLEAN_TYPE:
+ case CHAR_TYPE:
+ case ENUMERAL_TYPE:
+ case INTEGER_TYPE:
+ case REFERENCE_TYPE:
+ case SET_TYPE:
+ return 0;
+ }
+
+ case TRUNC_DIV_EXPR:
+ goto numerics;
+ case TRUNC_MOD_EXPR:
+ if (TREE_CODE (type) == REAL_TYPE)
+ return 1;
+ goto numerics;
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_NOT_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_OR_EXPR:
+ relationals:
+ switch ((int)TREE_CODE(type)) /* left operand must be discrete type */
+ {
+ case ARRAY_TYPE:
+ case CHAR_TYPE:
+ case COMPLEX_TYPE:
+ case ENUMERAL_TYPE:
+ case FILE_TYPE:
+ case FUNCTION_TYPE:
+ case GRANT_TYPE:
+ case INTEGER_TYPE:
+ case LANG_TYPE:
+ case METHOD_TYPE:
+ case OFFSET_TYPE:
+ case POINTER_TYPE:
+ case REAL_TYPE:
+ case RECORD_TYPE:
+ case REFERENCE_TYPE:
+ case SEIZE_TYPE:
+ case UNION_TYPE:
+ case VOID_TYPE:
+ return 1;
+ case BOOLEAN_TYPE:
+ case SET_TYPE:
+ return 0;
+ }
+ break;
+
+ default:
+ return 1; /* perhaps you forgot to add a new DEFTREECODE? */
+ }
+ return 1;
+}
+
+
+static int
+invalid_right_operand (code, type)
+ enum chill_tree_code code;
+ tree type;
+{
+ return invalid_operand (code, type, 1);
+}
+\f
+tree
+build_chill_abs (expr)
+ tree expr;
+{
+ tree temp;
+
+ if (TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE
+ || discrete_type_p (TREE_TYPE (expr)))
+ temp = fold (build1 (ABS_EXPR, TREE_TYPE (expr), expr));
+ else
+ {
+ error("ABS argument must be discrete or real mode");
+ return error_mark_node;
+ }
+ /* FIXME: should call
+ * cond_type_range_exception (temp);
+ */
+ return temp;
+}
+
+tree
+build_chill_abstime (exprlist)
+ tree exprlist;
+{
+ int mask = 0, i, numargs;
+ tree args = NULL_TREE;
+ tree filename, lineno;
+ int had_errors = 0;
+ tree tmp;
+
+ if (exprlist != NULL_TREE && TREE_CODE (exprlist) == ERROR_MARK)
+ return error_mark_node;
+
+ /* check for integer expressions */
+ i = 1;
+ tmp = exprlist;
+ while (tmp != NULL_TREE)
+ {
+ tree exp = TREE_VALUE (tmp);
+
+ if (exp == NULL_TREE || TREE_CODE (exp) == ERROR_MARK)
+ had_errors = 1;
+ else if (TREE_CODE (TREE_TYPE (exp)) != INTEGER_TYPE)
+ {
+ error ("argument %d to ABSTIME must be of integer type.", i);
+ had_errors = 1;
+ }
+ tmp = TREE_CHAIN (tmp);
+ i++;
+ }
+ if (had_errors)
+ return error_mark_node;
+
+ numargs = list_length (exprlist);
+ for (i = 0; i < numargs; i++)
+ mask |= (1 << i);
+
+ /* make it all arguments */
+ for (i = numargs; i < 6; i++)
+ exprlist = tree_cons (NULL_TREE, integer_zero_node, exprlist);
+
+ args = tree_cons (NULL_TREE, build_int_2 (mask, 0), exprlist);
+
+ filename = force_addr_of (get_chill_filename ());
+ lineno = get_chill_linenumber ();
+ args = chainon (args, tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, lineno, NULL_TREE)));
+
+ return build_chill_function_call (
+ lookup_name (get_identifier ("_abstime")), args);
+}
+
+
+tree
+build_allocate_memory_call (ptr, size)
+ tree ptr, size;
+{
+ int err = 0;
+
+ /* check for ptr is referable */
+ if (! CH_REFERABLE (ptr))
+ {
+ error ("parameter 1 must be referable.");
+ err++;
+ }
+ /* check for pointer */
+ else if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE)
+ {
+ error ("mode mismatch in parameter 1.");
+ err++;
+ }
+
+ /* check for size > 0 if it is a constant */
+ if (TREE_CODE (size) == INTEGER_CST && TREE_INT_CST_LOW (size) <= 0)
+ {
+ error ("parameter 2 must be a positive integer.");
+ err++;
+ }
+ if (err)
+ return error_mark_node;
+
+ if (TREE_TYPE (ptr) != ptr_type_node)
+ ptr = build_chill_cast (ptr_type_node, ptr);
+
+ return build_chill_function_call (
+ lookup_name (get_identifier ("_allocate_memory")),
+ tree_cons (NULL_TREE, ptr,
+ tree_cons (NULL_TREE, size,
+ tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
+ tree_cons (NULL_TREE, get_chill_linenumber (),
+ NULL_TREE)))));
+}
+
+
+tree
+build_allocate_global_memory_call (ptr, size)
+ tree ptr, size;
+{
+ int err = 0;
+
+ /* check for ptr is referable */
+ if (! CH_REFERABLE (ptr))
+ {
+ error ("parameter 1 must be referable.");
+ err++;
+ }
+ /* check for pointer */
+ else if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE)
+ {
+ error ("mode mismatch in parameter 1.");
+ err++;
+ }
+
+ /* check for size > 0 if it is a constant */
+ if (TREE_CODE (size) == INTEGER_CST && TREE_INT_CST_LOW (size) <= 0)
+ {
+ error ("parameter 2 must be a positive integer.");
+ err++;
+ }
+ if (err)
+ return error_mark_node;
+
+ if (TREE_TYPE (ptr) != ptr_type_node)
+ ptr = build_chill_cast (ptr_type_node, ptr);
+
+ return build_chill_function_call (
+ lookup_name (get_identifier ("_allocate_global_memory")),
+ tree_cons (NULL_TREE, ptr,
+ tree_cons (NULL_TREE, size,
+ tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
+ tree_cons (NULL_TREE, get_chill_linenumber (),
+ NULL_TREE)))));
+}
+
+
+tree
+build_return_memory (ptr)
+ tree ptr;
+{
+ /* check input */
+ if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK)
+ return error_mark_node;
+
+ /* check for pointer */
+ if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE)
+ {
+ error ("mode mismatch in parameter 1.");
+ return error_mark_node;
+ }
+
+ if (TREE_TYPE (ptr) != ptr_type_node)
+ ptr = build_chill_cast (ptr_type_node, ptr);
+
+ return build_chill_function_call (
+ lookup_name (get_identifier ("_return_memory")),
+ tree_cons (NULL_TREE, ptr,
+ tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
+ tree_cons (NULL_TREE, get_chill_linenumber (),
+ NULL_TREE))));
+}
+
+
+/* Compute the number of runtime members of the
+ * given powerset.
+ */
+tree
+build_chill_card (powerset)
+ tree powerset;
+{
+ if (pass == 2)
+ {
+ tree temp;
+ tree card_func = lookup_name (get_identifier ("__cardpowerset"));
+
+ if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (powerset) == IDENTIFIER_NODE)
+ powerset = lookup_name (powerset);
+
+ if (TREE_CODE (TREE_TYPE(powerset)) == SET_TYPE)
+ { int size;
+
+ /* Do constant folding, if possible. */
+ if (TREE_CODE (powerset) == CONSTRUCTOR & TREE_CONSTANT (powerset)
+ && (size = int_size_in_bytes (TREE_TYPE (powerset))) >= 0)
+ {
+ int bit_size = size * BITS_PER_UNIT;
+ char* buffer = (char*) alloca (bit_size);
+ temp = get_set_constructor_bits (powerset, buffer, bit_size);
+ if (!temp)
+ { int i;
+ int count = 0;
+ for (i = 0; i < bit_size; i++)
+ if (buffer[i])
+ count++;
+ temp = build_int_2 (count, 0);
+ TREE_TYPE (temp) = TREE_TYPE (TREE_TYPE (card_func));
+ return temp;
+ }
+ }
+ temp = build_chill_function_call (card_func,
+ tree_cons (NULL_TREE, force_addr_of (powerset),
+ tree_cons (NULL_TREE, powersetlen (powerset), NULL_TREE)));
+ /* FIXME: should call
+ * cond_type_range_exception (op0);
+ */
+ return temp;
+ }
+ error("CARD argument must be powerset mode");
+ return error_mark_node;
+ }
+ return NULL_TREE;
+}
+
+/* function to build the type needed for the DESCR-built-in
+ */
+
+void build_chill_descr_type ()
+{
+ tree decl1, decl2;
+
+ if (descr_type != NULL_TREE)
+ /* already done */
+ return;
+
+ decl1 = build_decl (FIELD_DECL, get_identifier ("datap"), ptr_type_node);
+ decl2 = build_decl (FIELD_DECL, get_identifier ("len"),
+ TREE_TYPE (lookup_name (
+ get_identifier ((ignore_case || ! special_UC) ? "ulong" : "ULONG"))));
+ TREE_CHAIN (decl1) = decl2;
+ TREE_CHAIN (decl2) = NULL_TREE;
+ decl2 = build_chill_struct_type (decl1);
+ descr_type = build_decl (TYPE_DECL, get_identifier ("__tmp_DESCR_type"), decl2);
+ pushdecl (descr_type);
+ DECL_SOURCE_LINE (descr_type) = 0;
+ satisfy_decl (descr_type, 0);
+}
+
+/* build a pointer to a descriptor.
+ * descriptor = STRUCT (datap PTR,
+ * len ULONG);
+ * This descriptor is build in variable descr_type.
+ */
+
+tree
+build_chill_descr (expr)
+ tree expr;
+{
+ if (pass == 2)
+ {
+ tree tuple, decl, descr_var, datap, len, tmp;
+ int is_static;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ /* check for expression is referable */
+ if (! CH_REFERABLE (expr))
+ {
+ error ("expression for DESCR-builtin must be referable.");
+ return error_mark_node;
+ }
+
+ mark_addressable (expr);
+#if 0
+ datap = build1 (ADDR_EXPR, build_chill_pointer_type (descr_type), expr);
+#else
+ datap = build_chill_arrow_expr (expr, 1);
+#endif
+ len = size_in_bytes (TREE_TYPE (expr));
+
+ descr_var = get_unique_identifier ("DESCR");
+ tuple = build_nt (CONSTRUCTOR, NULL_TREE,
+ tree_cons (NULL_TREE, datap,
+ tree_cons (NULL_TREE, len, NULL_TREE)));
+
+ is_static = (current_function_decl == global_function_decl) && TREE_STATIC (expr);
+ decl = decl_temp1 (descr_var, TREE_TYPE (descr_type), is_static,
+ tuple, 0, 0);
+#if 0
+ tmp = force_addr_of (decl);
+#else
+ tmp = build_chill_arrow_expr (decl, 1);
+#endif
+ return tmp;
+ }
+ return NULL_TREE;
+}
+
+/* this function process the builtin's
+ MILLISECS, SECS, MINUTES, HOURS and DAYS.
+ The built duration value is in milliseconds. */
+
+tree
+build_chill_duration (expr, multiplier, fnname, maxvalue)
+ tree expr;
+ unsigned long multiplier;
+ tree fnname;
+ unsigned long maxvalue;
+{
+ tree temp;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE)
+ {
+ error ("argument to `%s' must be of integer type.", IDENTIFIER_POINTER (fnname));
+ return error_mark_node;
+ }
+
+ temp = convert (duration_timing_type_node, expr);
+ temp = fold (build (MULT_EXPR, duration_timing_type_node,
+ temp, build_int_2 (multiplier, 0)));
+
+ if (range_checking)
+ temp = check_range (temp, expr, integer_zero_node, build_int_2 (maxvalue, 0));
+
+ return temp;
+}
+
+/* build function call to one of the floating point functions */
+static tree
+build_chill_floatcall (expr, chillname, funcname)
+ tree expr;
+ char *chillname;
+ char *funcname;
+{
+ tree result;
+ tree type;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ /* look if expr is a REAL_TYPE */
+ type = TREE_TYPE (expr);
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+ if (TREE_CODE (type) != REAL_TYPE)
+ {
+ error ("argument 1 to `%s' must be of floating point mode", chillname);
+ return error_mark_node;
+ }
+ result = build_chill_function_call (
+ lookup_name (get_identifier (funcname)),
+ tree_cons (NULL_TREE, expr, NULL_TREE));
+ return result;
+}
+
+/* common function for ALLOCATE and GETSTACK */
+static tree
+build_allocate_getstack (mode, value, chill_name, fnname, filename, linenumber)
+ tree mode;
+ tree value;
+ char *chill_name;
+ char *fnname;
+ tree filename;
+ tree linenumber;
+{
+ tree type, result;
+ tree expr = NULL_TREE;
+ tree args, tmpvar, fncall, ptr, init, outlist = NULL_TREE;
+
+ if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (mode) == TYPE_DECL)
+ type = TREE_TYPE (mode);
+ else
+ type = mode;
+
+ /* check if we have a mode */
+ if (TREE_CODE_CLASS (TREE_CODE (type)) != 't')
+ {
+ error ("First argument to `%s' must be a mode", chill_name);
+ return error_mark_node;
+ }
+
+ /* check if we have a value if type is READonly */
+ if (TYPE_READONLY_PROPERTY (type) && value == NULL_TREE)
+ {
+ error ("READonly modes for %s must have a value", chill_name);
+ return error_mark_node;
+ }
+
+ if (value != NULL_TREE)
+ {
+ if (TREE_CODE (value) == ERROR_MARK)
+ return error_mark_node;
+ expr = chill_convert_for_assignment (type, value, "assignment");
+ }
+
+ /* build function arguments */
+ if (filename == NULL_TREE)
+ args = tree_cons (NULL_TREE, size_in_bytes (type), NULL_TREE);
+ else
+ args = tree_cons (NULL_TREE, size_in_bytes (type),
+ tree_cons (NULL_TREE, force_addr_of (filename),
+ tree_cons (NULL_TREE, linenumber, NULL_TREE)));
+
+ ptr = build_chill_pointer_type (type);
+ tmpvar = decl_temp1 (get_unique_identifier (chill_name),
+ ptr, 0, NULL_TREE, 0, 0);
+ fncall = build_chill_function_call (
+ lookup_name (get_identifier (fnname)), args);
+ outlist = tree_cons (NULL_TREE,
+ build_chill_modify_expr (tmpvar, fncall), outlist);
+ if (expr == NULL_TREE)
+ {
+ /* set allocated memory to 0 */
+ fncall = build_chill_function_call (
+ lookup_name (get_identifier ("memset")),
+ tree_cons (NULL_TREE, convert (ptr_type_node, tmpvar),
+ tree_cons (NULL_TREE, integer_zero_node,
+ tree_cons (NULL_TREE, size_in_bytes (type), NULL_TREE))));
+ outlist = tree_cons (NULL_TREE, fncall, outlist);
+ }
+ else
+ {
+ /* write the init value to allocated memory */
+ outlist = tree_cons (NULL_TREE,
+ build_chill_modify_expr (build_chill_indirect_ref (tmpvar, NULL_TREE, 0),
+ expr),
+ outlist);
+ }
+ outlist = tree_cons (NULL_TREE, tmpvar, outlist);
+ result = build_chill_compound_expr (nreverse (outlist));
+ return result;
+}
+
+/* process the ALLOCATE built-in */
+tree
+build_chill_allocate (mode, value)
+ tree mode;
+ tree value;
+{
+ return build_allocate_getstack (mode, value, "ALLOCATE", "__allocate",
+ get_chill_filename (), get_chill_linenumber ());
+}
+
+/* process the GETSTACK built-in */
+tree
+build_chill_getstack (mode, value)
+ tree mode;
+ tree value;
+{
+ return build_allocate_getstack (mode, value, "GETSTACK", "__builtin_alloca",
+ NULL_TREE, NULL_TREE);
+}
+
+/* process the TERMINATE built-in */
+tree
+build_chill_terminate (ptr)
+ tree ptr;
+{
+ tree result;
+ tree type;
+
+ if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK)
+ return error_mark_node;
+
+ type = TREE_TYPE (ptr);
+ if (type == NULL_TREE || TREE_CODE (type) != POINTER_TYPE)
+ {
+ error ("argument to TERMINATE must be a reference primitive value");
+ return error_mark_node;
+ }
+ result = build_chill_function_call (
+ lookup_name (get_identifier ("__terminate")),
+ tree_cons (NULL_TREE, convert (ptr_type_node, ptr),
+ tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
+ tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
+ return result;
+}
+
+/* build the type passed to _inttime function */
+void
+build_chill_inttime_type ()
+{
+ tree idxlist;
+ tree arrtype;
+ tree decl;
+
+ idxlist = build_tree_list (NULL_TREE,
+ build_chill_range_type (NULL_TREE,
+ integer_zero_node,
+ build_int_2 (5, 0)));
+ arrtype = build_chill_array_type (ptr_type_node, idxlist, 0, NULL_TREE);
+
+ decl = build_decl (TYPE_DECL, get_identifier ("__tmp_INTTIME_type"), arrtype);
+ pushdecl (decl);
+ DECL_SOURCE_LINE (decl) = 0;
+ satisfy_decl (decl, 0);
+}
+
+tree
+build_chill_inttime (t, loclist)
+ tree t, loclist;
+{
+ int had_errors = 0, cnt;
+ tree tmp;
+ tree init = NULL_TREE;
+ int numargs;
+ tree tuple, var;
+
+ if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK)
+ return error_mark_node;
+ if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK)
+ return error_mark_node;
+
+ /* check first argument to be NEWMODE TIME */
+ if (TREE_TYPE (t) != abs_timing_type_node)
+ {
+ error ("argument 1 to INTTIME must be of mode TIME.");
+ had_errors = 1;
+ }
+
+ cnt = 2;
+ tmp = loclist;
+ while (tmp != NULL_TREE)
+ {
+ tree loc = TREE_VALUE (tmp);
+ char errmsg[200];
+ char *p, *p1;
+ int write_error = 0;
+
+ sprintf (errmsg, "argument %d to INTTIME must be ", cnt);
+ p = errmsg + strlen (errmsg);
+ p1 = p;
+
+ if (loc == NULL_TREE || TREE_CODE (loc) == ERROR_MARK)
+ had_errors = 1;
+ else
+ {
+ if (! CH_REFERABLE (loc))
+ {
+ strcpy (p, "referable");
+ p += strlen (p);
+ write_error = 1;
+ had_errors = 1;
+ }
+ if (TREE_CODE (TREE_TYPE (loc)) != INTEGER_TYPE)
+ {
+ if (p != p1)
+ {
+ strcpy (p, " and ");
+ p += strlen (p);
+ }
+ strcpy (p, "of integer type");
+ write_error = 1;
+ had_errors = 1;
+ }
+ /* FIXME: what's about ranges can't hold the result ?? */
+ if (write_error)
+ error ("%s.", errmsg);
+ }
+ /* next location */
+ tmp = TREE_CHAIN (tmp);
+ cnt++;
+ }
+
+ if (had_errors)
+ return error_mark_node;
+
+ /* make it always 6 arguments */
+ numargs = list_length (loclist);
+ for (cnt = numargs; cnt < 6; cnt++)
+ init = tree_cons (NULL_TREE, null_pointer_node, init);
+
+ /* append the given one's */
+ tmp = loclist;
+ while (tmp != NULL_TREE)
+ {
+ init = chainon (init,
+ build_tree_list (NULL_TREE,
+ build_chill_descr (TREE_VALUE (tmp))));
+ tmp = TREE_CHAIN (tmp);
+ }
+
+ tuple = build_nt (CONSTRUCTOR, NULL_TREE, init);
+ var = decl_temp1 (get_unique_identifier ("INTTIME"),
+ TREE_TYPE (lookup_name (get_identifier ("__tmp_INTTIME_type"))),
+ 0, tuple, 0, 0);
+
+ return build_chill_function_call (
+ lookup_name (get_identifier ("_inttime")),
+ tree_cons (NULL_TREE, t,
+ tree_cons (NULL_TREE, force_addr_of (var),
+ NULL_TREE)));
+}
+
+
+/* Compute the runtime length of the given string variable
+ * or expression.
+ */
+tree
+build_chill_length (expr)
+ tree expr;
+{
+ if (pass == 2)
+ {
+ tree type;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (expr) == IDENTIFIER_NODE)
+ expr = lookup_name (expr);
+
+ type = TREE_TYPE (expr);
+
+ if (TREE_CODE(type) == ERROR_MARK)
+ return type;
+ if (chill_varying_type_p (type))
+ {
+ tree temp = convert (integer_type_node,
+ build_component_ref (expr, var_length_id));
+ /* FIXME: should call
+ * cond_type_range_exception (temp);
+ */
+ return temp;
+ }
+
+ if ((TREE_CODE (type) == ARRAY_TYPE ||
+ /* should work for a bitstring too */
+ (TREE_CODE (type) == SET_TYPE && TREE_CODE (TREE_TYPE (type)) == BOOLEAN_TYPE)) &&
+ integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
+ {
+ tree temp = fold (build (PLUS_EXPR, chill_integer_type_node,
+ integer_one_node,
+ TYPE_MAX_VALUE (TYPE_DOMAIN (type))));
+ return convert (chill_integer_type_node, temp);
+ }
+
+ if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
+ {
+ tree len = max_queue_size (type);
+
+ if (len == NULL_TREE)
+ len = integer_minus_one_node;
+ return len;
+ }
+
+ if (CH_IS_TEXT_MODE (type))
+ {
+ if (TREE_CODE (expr) == TYPE_DECL)
+ {
+ /* text mode name */
+ return text_length (type);
+ }
+ else
+ {
+ /* text location */
+ tree temp = build_component_ref (
+ build_component_ref (expr, get_identifier ("tloc")),
+ var_length_id);
+ return convert (integer_type_node, temp);
+ }
+ }
+
+ error("LENGTH argument must be string, buffer, event mode, text location or mode");
+ return error_mark_node;
+ }
+ return NULL_TREE;
+}
+
+/* Compute the declared minimum/maximum value of the variable,
+ * expression or declared type
+ */
+static tree
+build_chill_lower_or_upper (what, is_upper)
+ tree what;
+ int is_upper; /* o -> LOWER; 1 -> UPPER */
+{
+ if (pass == 2)
+ {
+ tree type;
+ struct ch_class class;
+
+ if (what == NULL_TREE || TREE_CODE (what) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE_CLASS (TREE_CODE (what)) == 't')
+ type = what;
+ else
+ type = TREE_TYPE (what);
+ if (type == NULL_TREE)
+ {
+ if (is_upper)
+ error ("UPPER argument must have a mode, or be a mode");
+ else
+ error ("LOWER argument must have a mode, or be a mode");
+ return error_mark_node;
+ }
+ while (TREE_CODE (type) == REFERENCE_TYPE)
+ type = TREE_TYPE (type);
+ if (chill_varying_type_p (type))
+ type = CH_VARYING_ARRAY_TYPE (type);
+
+ if (discrete_type_p (type))
+ {
+ tree val = is_upper ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type);
+ class.kind = CH_VALUE_CLASS;
+ class.mode = type;
+ return convert_to_class (class, val);
+ }
+ else if (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == SET_TYPE)
+ {
+ if (TYPE_STRING_FLAG (type))
+ {
+ class.kind = CH_DERIVED_CLASS;
+ class.mode = integer_type_node;
+ }
+ else
+ {
+ class.kind = CH_VALUE_CLASS;
+ class.mode = TYPE_DOMAIN (type);
+ }
+ type = TYPE_DOMAIN (type);
+ return convert_to_class (class,
+ is_upper
+ ? TYPE_MAX_VALUE (type)
+ : TYPE_MIN_VALUE (type));
+ }
+ if (is_upper)
+ error("UPPER argument must be string, array, mode or integer");
+ else
+ error("LOWER argument must be string, array, mode or integer");
+ return error_mark_node;
+ }
+ return NULL_TREE;
+}
+
+tree
+build_chill_lower (what)
+ tree what;
+{
+ return build_chill_lower_or_upper (what, 0);
+}
+
+static tree
+build_max_min (expr, max_min)
+ tree expr;
+ int max_min; /* 0: calculate MIN; 1: calculate MAX */
+{
+ if (pass == 2)
+ {
+ tree type, temp, setminval;
+ tree set_base_type;
+ int size_in_bytes;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (expr) == IDENTIFIER_NODE)
+ expr = lookup_name (expr);
+
+ type = TREE_TYPE (expr);
+ set_base_type = TYPE_DOMAIN (type);
+ setminval = TYPE_MIN_VALUE (set_base_type);
+
+ if (TREE_CODE (type) != SET_TYPE)
+ {
+ error("%s argument must be POWERSET mode",
+ max_min ? "MAX" : "MIN");
+ return error_mark_node;
+ }
+
+ /* find max/min of constant powerset at compile time */
+ if (TREE_CODE (expr) == CONSTRUCTOR && TREE_CONSTANT (expr)
+ && (size_in_bytes = int_size_in_bytes (type)) >= 0)
+ {
+ HOST_WIDE_INT min_val = -1, max_val = -1;
+ HOST_WIDE_INT i, i_hi = 0;
+ HOST_WIDE_INT size_in_bits = size_in_bytes * BITS_PER_UNIT;
+ char *buffer = (char*) alloca (size_in_bits);
+ if (buffer == NULL
+ || get_set_constructor_bits (expr, buffer, size_in_bits))
+ abort ();
+ for (i = 0; i < size_in_bits; i++)
+ {
+ if (buffer[i])
+ {
+ if (min_val < 0)
+ min_val = i;
+ max_val = i;
+ }
+ }
+ if (min_val < 0)
+ error ("%s called for empty POWERSET", max_min ? "MAX" : "MIN");
+ i = max_min ? max_val : min_val;
+ temp = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (expr)));
+ add_double (i, i_hi,
+ TREE_INT_CST_LOW (temp), TREE_INT_CST_HIGH (temp),
+ &i, &i_hi);
+ temp = build_int_2 (i, i_hi);
+ TREE_TYPE (temp) = set_base_type;
+ return temp;
+ }
+ else
+ {
+ tree parmlist, filename, lineno;
+ char *funcname;
+
+ /* set up to call appropriate runtime function */
+ if (max_min)
+ funcname = "__flsetpowerset";
+ else
+ funcname = "__ffsetpowerset";
+
+ setminval = convert (long_integer_type_node, setminval);
+ filename = force_addr_of (get_chill_filename());
+ lineno = get_chill_linenumber();
+ parmlist = tree_cons (NULL_TREE, force_addr_of (expr),
+ tree_cons (NULL_TREE, powersetlen (expr),
+ tree_cons (NULL_TREE, setminval,
+ tree_cons (NULL_TREE, filename,
+ build_tree_list (NULL_TREE, lineno)))));
+ temp = lookup_name (get_identifier (funcname));
+ temp = build_chill_function_call (temp, parmlist);
+ TREE_TYPE (temp) = set_base_type;
+ return temp;
+ }
+ }
+ return NULL_TREE;
+}
+
+
+/* Compute the current runtime maximum value of the powerset
+ */
+tree
+build_chill_max (expr)
+ tree expr;
+{
+ return build_max_min (expr, 1);
+}
+
+
+/* Compute the current runtime minimum value of the powerset
+ */
+tree
+build_chill_min (expr)
+ tree expr;
+{
+ return build_max_min (expr, 0);
+}
+
+
+/* Build a conversion from the given expression to an INT,
+ * but only when the expression's type is the same size as
+ * an INT.
+ */
+tree
+build_chill_num (expr)
+ tree expr;
+{
+ if (pass == 2)
+ {
+ tree temp;
+ int need_unsigned;
+
+ if (expr == NULL_TREE || TREE_CODE(expr) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (expr) == IDENTIFIER_NODE)
+ expr = lookup_name (expr);
+
+ expr = convert_to_discrete (expr);
+ if (expr == NULL_TREE)
+ {
+ error ("argument to NUM is not discrete");
+ return error_mark_node;
+ }
+
+ /* enumeral types and string slices of length 1 must be kept unsigned */
+ need_unsigned = (TREE_CODE (TREE_TYPE (expr)) == ENUMERAL_TYPE)
+ || TREE_UNSIGNED (TREE_TYPE (expr));
+
+ temp = type_for_size (TYPE_PRECISION (TREE_TYPE (expr)),
+ need_unsigned);
+ if (temp == NULL_TREE)
+ {
+ error ("No integer mode which matches expression's mode");
+ return integer_zero_node;
+ }
+ temp = convert (temp, expr);
+
+ if (TREE_CONSTANT (temp))
+ {
+ if (tree_int_cst_lt (temp,
+ TYPE_MIN_VALUE (TREE_TYPE (temp))))
+ error ("NUM's parameter is below its mode range");
+ if (tree_int_cst_lt (TYPE_MAX_VALUE (TREE_TYPE (temp)),
+ temp))
+ error ("NUM's parameter is above its mode range");
+ }
+#if 0
+ else
+ {
+ if (range_checking)
+ cond_overflow_exception (temp,
+ TYPE_MIN_VALUE (TREE_TYPE (temp)),
+ TYPE_MAX_VALUE (TREE_TYPE (temp)));
+ }
+#endif
+
+ /* NUM delivers the INT derived class */
+ CH_DERIVED_FLAG (temp) = 1;
+
+ return temp;
+ }
+ return NULL_TREE;
+}
+
+
+static tree
+build_chill_pred_or_succ (expr, op)
+ tree expr;
+ enum tree_code op; /* PLUS_EXPR for SUCC; MINUS_EXPR for PRED. */
+{
+ struct ch_class class;
+ tree etype, cond;
+ tree limit;
+
+ if (pass == 1)
+ return NULL_TREE;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ /* disallow numbered SETs */
+ if (TREE_CODE (TREE_TYPE (expr)) == ENUMERAL_TYPE
+ && CH_ENUM_IS_NUMBERED (TREE_TYPE (expr)))
+ {
+ error ("Cannot take SUCC or PRED of a numbered SET");
+ return error_mark_node;
+ }
+
+ if (TREE_CODE (TREE_TYPE (expr)) == POINTER_TYPE)
+ {
+ if (TREE_TYPE (TREE_TYPE (expr)) == void_type_node)
+ {
+ error ("SUCC or PRED must not be done on a PTR.");
+ return error_mark_node;
+ }
+ pedwarn ("SUCC or PRED for a reference type is not standard.");
+ return fold (build (op, TREE_TYPE (expr),
+ expr,
+ size_in_bytes (TREE_TYPE (TREE_TYPE (expr)))));
+ }
+
+ expr = convert_to_discrete (expr);
+
+ if (expr == NULL_TREE)
+ {
+ error ("SUCC or PRED argument must be a discrete mode");
+ return error_mark_node;
+ }
+
+ class = chill_expr_class (expr);
+ if (class.mode)
+ class.mode = CH_ROOT_MODE (class.mode);
+ etype = class.mode;
+ expr = convert (etype, expr);
+
+ /* Exception if expression is already at the
+ min (PRED)/max(SUCC) valid value for its type. */
+ cond = fold (build (op == PLUS_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node,
+ expr,
+ convert (etype,
+ op == PLUS_EXPR ? TYPE_MAX_VALUE (etype)
+ : TYPE_MIN_VALUE (etype))));
+ if (TREE_CODE (cond) == INTEGER_CST
+ && tree_int_cst_equal (cond, integer_one_node))
+ {
+ error ("Taking the %s of a value already at its %s value",
+ op == PLUS_EXPR ? "SUCC" : "PRED",
+ op == PLUS_EXPR ? "maximum" : "minimum");
+ return error_mark_node;
+ }
+
+ if (range_checking)
+ expr = check_expression (expr, cond,
+ ridpointers[(int) RID_OVERFLOW]);
+
+ expr = fold (build (op, etype, expr,
+ convert (etype, integer_one_node)));
+ return convert_to_class (class, expr);
+}
+\f
+/* Compute the value of the CHILL `size' operator just
+ * like the C 'sizeof' operator (code stolen from c-typeck.c)
+ * TYPE may be a location or mode tree. In pass 1, we build
+ * a function-call syntax tree; in pass 2, we evaluate it.
+ */
+tree
+build_chill_sizeof (type)
+ tree type;
+{
+ if (pass == 2)
+ {
+ tree temp;
+ struct ch_class class;
+ enum tree_code code;
+ tree signame = NULL_TREE;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (type) == IDENTIFIER_NODE)
+ type = lookup_name (type);
+
+ code = TREE_CODE (type);
+ if (code == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE_CLASS (TREE_CODE (type)) != 't')
+ {
+ if (TREE_CODE (type) == TYPE_DECL && CH_DECL_SIGNAL (type))
+ signame = DECL_NAME (type);
+ type = TREE_TYPE (type);
+ }
+
+ if (code == FUNCTION_TYPE)
+ {
+ if (pedantic || warn_pointer_arith)
+ pedwarn ("size applied to a function mode");
+ return error_mark_node;
+ }
+ if (code == VOID_TYPE)
+ {
+ if (pedantic || warn_pointer_arith)
+ pedwarn ("sizeof applied to a void mode");
+ return error_mark_node;
+ }
+ if (TYPE_SIZE (type) == 0)
+ {
+ error ("sizeof applied to an incomplete mode");
+ return error_mark_node;
+ }
+
+ temp = size_binop (CEIL_DIV_EXPR, TYPE_SIZE (type),
+ size_int (TYPE_PRECISION (char_type_node)));
+ if (signame != NULL_TREE)
+ {
+ /* we have a signal definition. This signal may have no
+ data items specified. The definition however says that
+ there are data, cause we cannot build a structure without
+ fields. In this case return 0. */
+ if (IDENTIFIER_SIGNAL_DATA (signame) == 0)
+ temp = integer_zero_node;
+ }
+
+ /* FIXME: should call
+ * cond_type_range_exception (temp);
+ */
+ class.kind = CH_DERIVED_CLASS;
+ class.mode = integer_type_node;
+ return convert_to_class (class, temp);
+ }
+ return NULL_TREE;
+}
+\f
+/* Compute the declared maximum value of the variable,
+ * expression or declared type
+ */
+tree
+build_chill_upper (what)
+ tree what;
+{
+ return build_chill_lower_or_upper (what, 1);
+}
+\f
+/*
+ * Here at the site of a function/procedure call.. We need to build
+ * temps for the INOUT and OUT parameters, and copy the actual parameters
+ * into the temps. After the call, we 'copy back' the values from the
+ * temps to the actual parameter variables. This somewhat verbose pol-
+ * icy meets the requirement that the actual parameters are undisturbed
+ * if the function/procedure causes an exception. They are updated only
+ * upon a normal return from the function.
+ *
+ * Note: the expr_list, which collects all of the above assignments, etc,
+ * is built in REVERSE execution order. The list is corrected by nreverse
+ * inside the build_chill_compound_expr call.
+ */
+tree
+build_chill_function_call (function, expr)
+ tree function, expr;
+{
+ register tree typetail, valtail, typelist;
+ register tree temp, actual_args = NULL_TREE;
+ tree name = NULL_TREE;
+ tree function_call;
+ tree fntype;
+ int parmno = 1; /* parameter number for error message */
+ int callee_raise_exception = 0;
+
+ /* list of assignments to run after the actual call,
+ copying from the temps back to the user's variables. */
+ tree copy_back = NULL_TREE;
+
+ /* list of expressions to run before the call, copying from
+ the user's variable to the temps that are passed to the function */
+ tree expr_list = NULL_TREE;
+
+ if (function == NULL_TREE || TREE_CODE (function) == ERROR_MARK)
+ return error_mark_node;
+
+ if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ if (pass < 2)
+ return error_mark_node;
+
+ fntype = TREE_TYPE (function);
+ if (TREE_CODE (function) == FUNCTION_DECL)
+ {
+ callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE;
+
+ /* Differs from default_conversion by not setting TREE_ADDRESSABLE
+ (because calling an inline function does not mean the function
+ needs to be separately compiled). */
+ fntype = build_type_variant (fntype,
+ TREE_READONLY (function),
+ TREE_THIS_VOLATILE (function));
+ name = DECL_NAME (function);
+
+ /* check that function is not a PROCESS */
+ if (CH_DECL_PROCESS (function))
+ {
+ error ("cannot call a PROCESS, you START a PROCESS");
+ return error_mark_node;
+ }
+
+ function = build1 (ADDR_EXPR, build_pointer_type (fntype), function);
+ }
+ else if (TREE_CODE (fntype) == POINTER_TYPE)
+ {
+ fntype = TREE_TYPE (fntype);
+ callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE;
+
+ /* Z.200 6.7 Call Action:
+ "A procedure call causes the EMPTY exception if the
+ procedure primitive value delivers NULL. */
+ if (TREE_CODE (function) != ADDR_EXPR
+ || TREE_CODE (TREE_OPERAND (function, 0)) != FUNCTION_DECL)
+ function = check_non_null (function);
+ }
+
+ typelist = TYPE_ARG_TYPES (fntype);
+ if (callee_raise_exception)
+ {
+ /* remove last two arguments from list for subsequent checking.
+ They will get added automatically after checking */
+ int len = list_length (typelist);
+ int i;
+ tree newtypelist = NULL_TREE;
+ tree wrk = typelist;
+
+ for (i = 0; i < len - 3; i++)
+ {
+ newtypelist = tree_cons (TREE_PURPOSE (wrk), TREE_VALUE (wrk), newtypelist);
+ wrk = TREE_CHAIN (wrk);
+ }
+ /* add the void_type_node */
+ newtypelist = tree_cons (NULL_TREE, void_type_node, newtypelist);
+ typelist = nreverse (newtypelist);
+ }
+
+ /* Scan the given expressions and types, producing individual
+ converted arguments and pushing them on ACTUAL_ARGS in
+ reverse order. */
+ for (valtail = expr, typetail = typelist;
+ valtail != NULL_TREE && typetail != NULL_TREE; parmno++,
+ valtail = TREE_CHAIN (valtail), typetail = TREE_CHAIN (typetail))
+ {
+ register tree actual = TREE_VALUE (valtail);
+ register tree attr = TREE_PURPOSE (typetail)
+ ? TREE_PURPOSE (typetail) : ridpointers[(int) RID_IN];
+ register tree type = TREE_VALUE (typetail);
+ char place[30];
+ sprintf (place, "parameter %d", parmno);
+
+ /* if we have reached void_type_node in typelist we are at the
+ end of formal parameters and then we have too many actual
+ parameters */
+ if (type == void_type_node)
+ break;
+
+ /* check if actual is a TYPE_DECL. FIXME: what else ? */
+ if (TREE_CODE (actual) == TYPE_DECL)
+ {
+ error ("invalid %s", place);
+ actual = error_mark_node;
+ }
+ /* INOUT or OUT param to handle? */
+ else if (attr == ridpointers[(int) RID_OUT]
+ || attr == ridpointers[(int)RID_INOUT])
+ {
+ char temp_name[20];
+ tree parmtmp;
+ tree in_actual = NULL_TREE, out_actual;
+
+ /* actual parameter must be a location so we can
+ build a reference to it */
+ if (!CH_LOCATION_P (actual))
+ {
+ error ("%s parameter %d must be a location",
+ (attr == ridpointers[(int) RID_OUT]) ?
+ "OUT" : "INOUT", parmno);
+ continue;
+ }
+ if (TYPE_READONLY_PROPERTY (TREE_TYPE (actual))
+ || TREE_READONLY (actual))
+ {
+ error ("%s parameter %d is READ-only",
+ (attr == ridpointers[(int) RID_OUT]) ?
+ "OUT" : "INOUT", parmno);
+ continue;
+ }
+
+ sprintf (temp_name, "PARM_%d_%s", parmno,
+ (attr == ridpointers[(int)RID_OUT]) ?
+ "OUT" : "INOUT");
+ parmtmp = decl_temp1 (get_unique_identifier (temp_name),
+ TREE_TYPE (type), 0, NULL_TREE, 0, 0);
+ /* this temp *must not* be optimized into a register */
+ mark_addressable (parmtmp);
+
+ if (attr == ridpointers[(int)RID_INOUT])
+ {
+ tree in_actual = chill_convert_for_assignment (TREE_TYPE (type),
+ actual, place);
+ tree tmp = build_chill_modify_expr (parmtmp, in_actual);
+ expr_list = tree_cons (NULL_TREE, tmp, expr_list);
+ }
+ if (in_actual != error_mark_node)
+ {
+ /* list of copy back assignments to perform, from the temp
+ back to the actual parameter */
+ out_actual = chill_convert_for_assignment (TREE_TYPE (actual),
+ parmtmp, place);
+ copy_back = tree_cons (NULL_TREE,
+ build_chill_modify_expr (actual,
+ out_actual),
+ copy_back);
+ }
+ /* we can do this because build_chill_function_type
+ turned these parameters into REFERENCE_TYPEs. */
+ actual = build1 (ADDR_EXPR, type, parmtmp);
+ }
+ else if (attr == ridpointers[(int) RID_LOC])
+ {
+ int is_location = chill_location (actual);
+ if (is_location)
+ {
+ if (is_location == 1)
+ {
+ error ("LOC actual parameter %d is a non-referable location",
+ parmno);
+ actual = error_mark_node;
+ }
+ else if (! CH_READ_COMPATIBLE (type, TREE_TYPE (actual)))
+ {
+ error ("mode mismatch in parameter %d", parmno);
+ actual = error_mark_node;
+ }
+ else
+ actual = convert (type, actual);
+ }
+ else
+ {
+ actual = chill_convert_for_assignment (TREE_TYPE (type),
+ actual, place);
+ sprintf (place, "parameter_%d", parmno);
+ actual = decl_temp1 (get_identifier (place),
+ TREE_TYPE (type), 0, actual, 0, 0);
+ actual = convert (type, actual);
+ }
+ mark_addressable (actual);
+ }
+ else
+ actual = chill_convert_for_assignment (type, actual, place);
+
+ actual_args = tree_cons (NULL_TREE, actual, actual_args);
+ }
+
+ if (valtail != 0 && TREE_VALUE (valtail) != void_type_node)
+ {
+ char *errstr = "too many arguments to procedure";
+ if (name)
+ error ("%s `%s'", errstr, IDENTIFIER_POINTER (name));
+ else
+ error (errstr);
+ return error_mark_node;
+ }
+ else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node)
+ {
+ char *errstr = "too few arguments to procedure";
+ if (name)
+ error ("%s `%s'", errstr, IDENTIFIER_POINTER (name));
+ else
+ error (errstr);
+ return error_mark_node;
+ }
+
+ if (callee_raise_exception)
+ {
+ /* add linenumber and filename of the caller as arguments */
+ actual_args = tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
+ actual_args);
+ actual_args = tree_cons (NULL_TREE, get_chill_linenumber (), actual_args);
+ }
+
+ function_call = build (CALL_EXPR, TREE_TYPE (fntype),
+ function, nreverse (actual_args), NULL_TREE);
+ TREE_SIDE_EFFECTS (function_call) = 1;
+
+ if (copy_back == NULL_TREE && expr_list == NULL_TREE)
+ return function_call; /* no copying to do, either way */
+ else
+ {
+ tree result_type = TREE_TYPE (fntype);
+ tree result_tmp = NULL_TREE;
+
+ /* no result wanted from procedure call */
+ if (result_type == NULL_TREE || result_type == void_type_node)
+ expr_list = tree_cons (NULL_TREE, function_call, expr_list);
+ else
+ {
+ /* create a temp for the function's result. this is so that we can
+ evaluate this temp as the last expression in the list, which will
+ make the function's return value the value of the whole list of
+ expressions (by the C rules for compound expressions) */
+ result_tmp = decl_temp1 (get_unique_identifier ("FUNC_RESULT"),
+ result_type, 0, NULL_TREE, 0, 0);
+ expr_list = tree_cons (NULL_TREE,
+ build_chill_modify_expr (result_tmp, function_call),
+ expr_list);
+ }
+
+ expr_list = chainon (copy_back, expr_list);
+
+ /* last, but not least, the function's result */
+ if (result_tmp != NULL_TREE)
+ expr_list = tree_cons (NULL_TREE, result_tmp, expr_list);
+ temp = build_chill_compound_expr (nreverse (expr_list));
+ return temp;
+ }
+}
+\f
+/* We saw something that looks like a function call,
+ but if it's pass 1, we're not sure. */
+
+tree
+build_generalized_call (func, args)
+ tree func, args;
+{
+ tree type = TREE_TYPE (func);
+
+ if (pass == 1)
+ return build (CALL_EXPR, NULL_TREE, func, args, NULL_TREE);
+
+ /* Handle string repetition */
+ if (TREE_CODE (func) == INTEGER_CST)
+ {
+ if (args == NULL_TREE || TREE_CHAIN (args) != NULL_TREE)
+ {
+ error ("syntax error (integer used as function)");
+ return error_mark_node;
+ }
+ if (TREE_CODE (args) == TREE_LIST)
+ args = TREE_VALUE (args);
+ return build_chill_repetition_op (func, args);
+ }
+
+ if (args != NULL_TREE)
+ {
+ if (TREE_CODE (args) == RANGE_EXPR)
+ {
+ tree lo = TREE_OPERAND (args, 0), hi = TREE_OPERAND (args, 1);
+ if (TREE_CODE_CLASS (TREE_CODE (func)) == 't')
+ return build_chill_range_type (func, lo, hi);
+ else
+ return build_chill_slice_with_range (func, lo, hi);
+ }
+ else if (TREE_CODE (args) != TREE_LIST)
+ {
+ error ("syntax error - missing operator, comma, or '('?");
+ return error_mark_node;
+ }
+ }
+
+ if (TREE_CODE (func) == TYPE_DECL)
+ {
+ if (CH_DECL_SIGNAL (func))
+ return build_signal_descriptor (func, args);
+ func = TREE_TYPE (func);
+ }
+
+ if (TREE_CODE_CLASS (TREE_CODE (func)) == 't'
+ && args != NULL_TREE && TREE_CHAIN (args) == NULL_TREE)
+ return build_chill_cast (func, TREE_VALUE (args));
+
+ if (TREE_CODE (type) == FUNCTION_TYPE
+ || (TREE_CODE (type) == POINTER_TYPE
+ && TREE_TYPE (type) != NULL_TREE
+ && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE))
+ {
+ /* Check for a built-in Chill function. */
+ if (TREE_CODE (func) == FUNCTION_DECL
+ && DECL_BUILT_IN (func)
+ && DECL_FUNCTION_CODE (func) > END_BUILTINS)
+ {
+ tree fnname = DECL_NAME (func);
+ switch ((enum chill_built_in_function)DECL_FUNCTION_CODE (func))
+ {
+ case BUILT_IN_CH_ABS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_abs (TREE_VALUE (args));
+ case BUILT_IN_ABSTIME:
+ if (check_arglist_length (args, 0, 6, fnname) < 0)
+ return error_mark_node;
+ return build_chill_abstime (args);
+ case BUILT_IN_ADDR:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+#if 0
+ return build_chill_addr_expr (TREE_VALUE (args), (char *)0);
+#else
+ return build_chill_arrow_expr (TREE_VALUE (args), 0);
+#endif
+ case BUILT_IN_ALLOCATE_GLOBAL_MEMORY:
+ if (check_arglist_length (args, 2, 2, fnname) < 0)
+ return error_mark_node;
+ return build_allocate_global_memory_call
+ (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_ALLOCATE:
+ if (check_arglist_length (args, 1, 2, fnname) < 0)
+ return error_mark_node;
+ return build_chill_allocate (TREE_VALUE (args),
+ TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_ALLOCATE_MEMORY:
+ if (check_arglist_length (args, 2, 2, fnname) < 0)
+ return error_mark_node;
+ return build_allocate_memory_call
+ (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_ASSOCIATE:
+ if (check_arglist_length (args, 2, 3, fnname) < 0)
+ return error_mark_node;
+ return build_chill_associate
+ (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)),
+ TREE_CHAIN (TREE_CHAIN (args)));
+ case BUILT_IN_ARCCOS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__acos");
+ case BUILT_IN_ARCSIN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__asin");
+ case BUILT_IN_ARCTAN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__atan");
+ case BUILT_IN_CARD:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_card (TREE_VALUE (args));
+ case BUILT_IN_CONNECT:
+ if (check_arglist_length (args, 3, 5, fnname) < 0)
+ return error_mark_node;
+ return build_chill_connect
+ (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)),
+ TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))),
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args))));
+ case BUILT_IN_COPY_NUMBER:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_copy_number (TREE_VALUE (args));
+ case BUILT_IN_CH_COS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__cos");
+ case BUILT_IN_CREATE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_create (TREE_VALUE (args));
+ case BUILT_IN_DAYS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_duration (TREE_VALUE (args), DAYS_MULTIPLIER,
+ fnname, DAYS_MAX);
+ case BUILT_IN_CH_DELETE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_delete (TREE_VALUE (args));
+ case BUILT_IN_DESCR:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_descr (TREE_VALUE (args));
+ case BUILT_IN_DISCONNECT:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_disconnect (TREE_VALUE (args));
+ case BUILT_IN_DISSOCIATE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_dissociate (TREE_VALUE (args));
+ case BUILT_IN_EOLN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_eoln (TREE_VALUE (args));
+ case BUILT_IN_EXISTING:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_existing (TREE_VALUE (args));
+ case BUILT_IN_EXP:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__exp");
+ case BUILT_IN_GEN_CODE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_gen_code (TREE_VALUE (args));
+ case BUILT_IN_GEN_INST:
+ if (check_arglist_length (args, 2, 2, fnname) < 0)
+ return error_mark_node;
+ return build_gen_inst (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_GEN_PTYPE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_gen_ptype (TREE_VALUE (args));
+ case BUILT_IN_GETASSOCIATION:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_getassociation (TREE_VALUE (args));
+ case BUILT_IN_GETSTACK:
+ if (check_arglist_length (args, 1, 2, fnname) < 0)
+ return error_mark_node;
+ return build_chill_getstack (TREE_VALUE (args),
+ TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_GETTEXTACCESS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_gettextaccess (TREE_VALUE (args));
+ case BUILT_IN_GETTEXTINDEX:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_gettextindex (TREE_VALUE (args));
+ case BUILT_IN_GETTEXTRECORD:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_gettextrecord (TREE_VALUE (args));
+ case BUILT_IN_GETUSAGE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_getusage (TREE_VALUE (args));
+ case BUILT_IN_HOURS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_duration (TREE_VALUE (args), HOURS_MULTIPLIER,
+ fnname, HOURS_MAX);
+ case BUILT_IN_INDEXABLE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_indexable (TREE_VALUE (args));
+ case BUILT_IN_INTTIME:
+ if (check_arglist_length (args, 2, 7, fnname) < 0)
+ return error_mark_node;
+ return build_chill_inttime (TREE_VALUE (args),
+ TREE_CHAIN (args));
+ case BUILT_IN_ISASSOCIATED:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_isassociated (TREE_VALUE (args));
+ case BUILT_IN_LENGTH:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_length (TREE_VALUE (args));
+ case BUILT_IN_LN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__log");
+ case BUILT_IN_LOG:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__log10");
+ case BUILT_IN_LOWER:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_lower (TREE_VALUE (args));
+ case BUILT_IN_MAX:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_max (TREE_VALUE (args));
+ case BUILT_IN_MILLISECS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_duration (TREE_VALUE (args), MILLISECS_MULTIPLIER,
+ fnname, MILLISECS_MAX);
+ case BUILT_IN_MIN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_min (TREE_VALUE (args));
+ case BUILT_IN_MINUTES:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_duration (TREE_VALUE (args), MINUTES_MULTIPLIER,
+ fnname, MINUTES_MAX);
+ case BUILT_IN_MODIFY:
+ if (check_arglist_length (args, 1, -1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_modify (TREE_VALUE (args), TREE_CHAIN (args));
+ case BUILT_IN_NUM:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_num (TREE_VALUE (args));
+ case BUILT_IN_OUTOFFILE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_outoffile (TREE_VALUE (args));
+ case BUILT_IN_PRED:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_pred_or_succ (TREE_VALUE (args), MINUS_EXPR);
+ case BUILT_IN_PROC_TYPE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_proc_type (TREE_VALUE (args));
+ case BUILT_IN_QUEUE_LENGTH:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_queue_length (TREE_VALUE (args));
+ case BUILT_IN_READABLE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_readable (TREE_VALUE (args));
+ case BUILT_IN_READRECORD:
+ if (check_arglist_length (args, 1, 3, fnname) < 0)
+ return error_mark_node;
+ return build_chill_readrecord (TREE_VALUE (args), TREE_CHAIN (args));
+ case BUILT_IN_READTEXT:
+ if (check_arglist_length (args, 2, -1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_readtext (TREE_VALUE (args),
+ TREE_CHAIN (args));
+ case BUILT_IN_RETURN_MEMORY:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_return_memory (TREE_VALUE (args));
+ case BUILT_IN_SECS:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_duration (TREE_VALUE (args), SECS_MULTIPLIER,
+ fnname, SECS_MAX);
+ case BUILT_IN_SEQUENCIBLE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_sequencible (TREE_VALUE (args));
+ case BUILT_IN_SETTEXTACCESS:
+ if (check_arglist_length (args, 2, 2, fnname) < 0)
+ return error_mark_node;
+ return build_chill_settextaccess (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_SETTEXTINDEX:
+ if (check_arglist_length (args, 2, 2, fnname) < 0)
+ return error_mark_node;
+ return build_chill_settextindex (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_SETTEXTRECORD:
+ if (check_arglist_length (args, 2, 2, fnname) < 0)
+ return error_mark_node;
+ return build_chill_settextrecord (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)));
+ case BUILT_IN_CH_SIN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__sin");
+ case BUILT_IN_SIZE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_sizeof (TREE_VALUE (args));
+ case BUILT_IN_SQRT:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__sqrt");
+ case BUILT_IN_SUCC:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_pred_or_succ (TREE_VALUE (args), PLUS_EXPR);
+ case BUILT_IN_TAN:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_floatcall (TREE_VALUE (args),
+ IDENTIFIER_POINTER (fnname),
+ "__tan");
+ case BUILT_IN_TERMINATE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_terminate (TREE_VALUE (args));
+ case BUILT_IN_UPPER:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_upper (TREE_VALUE (args));
+ case BUILT_IN_VARIABLE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_variable (TREE_VALUE (args));
+ case BUILT_IN_WRITEABLE:
+ if (check_arglist_length (args, 1, 1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_writeable (TREE_VALUE (args));
+ case BUILT_IN_WRITERECORD:
+ if (check_arglist_length (args, 2, 3, fnname) < 0)
+ return error_mark_node;
+ return build_chill_writerecord (TREE_VALUE (args), TREE_CHAIN (args));
+ case BUILT_IN_WRITETEXT:
+ if (check_arglist_length (args, 2, -1, fnname) < 0)
+ return error_mark_node;
+ return build_chill_writetext (TREE_VALUE (args),
+ TREE_CHAIN (args));
+
+ case BUILT_IN_EXPIRED:
+ case BUILT_IN_WAIT:
+ sorry ("unimplemented builtin function `%s'",
+ IDENTIFIER_POINTER (fnname));
+ break;
+ default:
+ error ("internal error - bad builtin function `%s'",
+ IDENTIFIER_POINTER (fnname));
+ }
+ }
+ return build_chill_function_call (func, args);
+ }
+
+ if (chill_varying_type_p (TREE_TYPE (func)))
+ type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+
+ if (CH_STRING_TYPE_P (type))
+ {
+ if (args == NULL_TREE)
+ {
+ error ("empty expression in string index");
+ return error_mark_node;
+ }
+ if (TREE_CHAIN (args) != NULL)
+ {
+ error ("only one expression allowed in string index");
+ return error_mark_node;
+ }
+ if (flag_old_strings)
+ return build_chill_slice_with_length (func,
+ TREE_VALUE (args),
+ integer_one_node);
+ else if (CH_BOOLS_TYPE_P (type))
+ return build_chill_bitref (func, args);
+ else
+ return build_chill_array_ref (func, args);
+ }
+
+ else if (TREE_CODE (type) == ARRAY_TYPE)
+ return build_chill_array_ref (func, args);
+
+ if (TREE_CODE (func) != ERROR_MARK)
+ error ("invalid: primval ( untyped_exprlist )");
+ return error_mark_node;
+}
+\f
+/* Given a set stored as one bit per char (in BUFFER[0 .. BIT_SIZE-1]),
+ return a CONTRUCTOR, of type TYPE (a SET_TYPE). */
+tree
+expand_packed_set (buffer, bit_size, type)
+ char *buffer;
+ int bit_size;
+ tree type;
+{
+ /* The ordinal number corresponding to the first stored bit. */
+ HOST_WIDE_INT first_bit_no =
+ TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (type)));
+ tree list = NULL_TREE;
+ int i;
+
+ for (i = 0; i < bit_size; i++)
+ if (buffer[i])
+ {
+ int next_0;
+ for (next_0 = i + 1;
+ next_0 < bit_size && buffer[next_0]; next_0++)
+ ;
+ if (next_0 == i + 1)
+ list = tree_cons (NULL_TREE,
+ build_int_2 (i + first_bit_no, 0), list);
+ else
+ {
+ list = tree_cons (build_int_2 (i + first_bit_no, 0),
+ build_int_2 (next_0 - 1 + first_bit_no, 0), list);
+ /* advance i past the range of 1-bits */
+ i = next_0;
+ }
+ }
+ list = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list));
+ TREE_CONSTANT (list) = 1;
+ return list;
+}
+\f
+/*
+ * fold a set represented as a CONSTRUCTOR list.
+ * An empty set has a NULL_TREE in its TREE_OPERAND (set, 1) slot.
+ */
+static tree
+fold_set_expr (code, op0, op1)
+ enum chill_tree_code code;
+ tree op0, op1;
+{
+ tree temp;
+ char *buffer0, *buffer1, *bufferr;
+ int i, size0, size1, first_unused_bit;
+
+ if (! TREE_CONSTANT (op0) || TREE_CODE (op0) != CONSTRUCTOR)
+ return NULL_TREE;
+
+ if (op1
+ && (! TREE_CONSTANT (op1) || TREE_CODE (op1) != CONSTRUCTOR))
+ return NULL_TREE;
+
+ size0 = int_size_in_bytes (TREE_TYPE (op0)) * BITS_PER_UNIT;
+ if (size0 < 0)
+ {
+ error ("operand is variable-size bitstring/power-set");
+ return error_mark_node;
+ }
+ buffer0 = (char*) alloca (size0);
+
+ temp = get_set_constructor_bits (op0, buffer0, size0);
+ if (temp)
+ return NULL_TREE;
+
+ if (op0 && op1)
+ {
+ size1 = int_size_in_bytes (TREE_TYPE (op1)) * BITS_PER_UNIT;
+ if (size1 < 0)
+ {
+ error ("operand is variable-size bitstring/power-set");
+ return error_mark_node;
+ }
+ if (size0 != size1)
+ return NULL_TREE;
+ buffer1 = (char*) alloca (size1);
+ temp = get_set_constructor_bits (op1, buffer1, size1);
+ if (temp)
+ return NULL_TREE;
+ }
+
+ bufferr = (char*) alloca (size0); /* result buffer */
+
+ switch ((int)code)
+ {
+ case SET_NOT_EXPR:
+ case BIT_NOT_EXPR:
+ for (i = 0; i < size0; i++)
+ bufferr[i] = 1 & ~buffer0[i];
+ goto build_result;
+ case SET_AND_EXPR:
+ case BIT_AND_EXPR:
+ for (i = 0; i < size0; i++)
+ bufferr[i] = buffer0[i] & buffer1[i];
+ goto build_result;
+ case SET_IOR_EXPR:
+ case BIT_IOR_EXPR:
+ for (i = 0; i < size0; i++)
+ bufferr[i] = buffer0[i] | buffer1[i];
+ goto build_result;
+ case SET_XOR_EXPR:
+ case BIT_XOR_EXPR:
+ for (i = 0; i < size0; i++)
+ bufferr[i] = (buffer0[i] ^ buffer1[i]) & 1;
+ goto build_result;
+ case SET_DIFF_EXPR:
+ case MINUS_EXPR:
+ for (i = 0; i < size0; i++)
+ bufferr[i] = buffer0[i] & ~buffer1[i];
+ goto build_result;
+ build_result:
+ /* mask out unused bits. Same as runtime library does. */
+ first_unused_bit = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (op0))))
+ - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (op0)))) + 1;
+ for (i = first_unused_bit; i < size0 ; i++)
+ bufferr[i] = 0;
+ return expand_packed_set (bufferr, size0, TREE_TYPE (op0));
+ case EQ_EXPR:
+ for (i = 0; i < size0; i++)
+ if (buffer0[i] != buffer1[i])
+ return boolean_false_node;
+ return boolean_true_node;
+
+ case NE_EXPR:
+ for (i = 0; i < size0; i++)
+ if (buffer0[i] != buffer1[i])
+ return boolean_true_node;
+ return boolean_false_node;
+
+ default:
+ return NULL_TREE;
+ }
+}
+\f
+/*
+ * build a set or bit-array expression. Type-checking is
+ * done elsewhere.
+ */
+static tree
+build_compare_set_expr (code, op0, op1)
+ enum chill_tree_code code;
+ tree op0, op1;
+{
+ tree result_type = NULL_TREE;
+ char *fnname;
+ tree x;
+
+ /* These conversions are needed if -fold-strings. */
+ if (TREE_CODE (TREE_TYPE (op0)) == BOOLEAN_TYPE)
+ {
+ if (CH_BOOLS_ONE_P (TREE_TYPE (op1)))
+ return build_compare_discrete_expr (code,
+ op0,
+ convert (boolean_type_node, op1));
+ else
+ op0 = convert (bitstring_one_type_node, op0);
+ }
+ if (TREE_CODE (TREE_TYPE (op1)) == BOOLEAN_TYPE)
+ {
+ if (CH_BOOLS_ONE_P (TREE_TYPE (op0)))
+ return build_compare_discrete_expr (code,
+ convert (boolean_type_node, op0),
+ op1);
+ else
+ op1 = convert (bitstring_one_type_node, op1);
+ }
+
+ switch ((int)code)
+ {
+ case EQ_EXPR:
+ {
+ tree temp = fold_set_expr (EQ_EXPR, op0, op1);
+ if (temp)
+ return temp;
+ fnname = "__eqpowerset";
+ goto compare_powerset;
+ }
+ break;
+
+ case GE_EXPR:
+ /* switch operands and fall thru */
+ x = op0;
+ op0 = op1;
+ op1 = x;
+
+ case LE_EXPR:
+ fnname = "__lepowerset";
+ goto compare_powerset;
+
+ case GT_EXPR:
+ /* switch operands and fall thru */
+ x = op0;
+ op0 = op1;
+ op1 = x;
+
+ case LT_EXPR:
+ fnname = "__ltpowerset";
+ goto compare_powerset;
+
+ case NE_EXPR:
+ return invert_truthvalue (build_compare_set_expr (EQ_EXPR, op0, op1));
+
+ compare_powerset:
+ {
+ tree tsize = powersetlen (op0);
+
+ if (TREE_CODE (TREE_TYPE (op0)) != SET_TYPE)
+ tsize = fold (build (MULT_EXPR, sizetype, tsize,
+ size_int (BITS_PER_UNIT)));
+
+ return build_chill_function_call (lookup_name (get_identifier (fnname)),
+ tree_cons (NULL_TREE, force_addr_of (op0),
+ tree_cons (NULL_TREE, force_addr_of (op1),
+ tree_cons (NULL_TREE, tsize, NULL_TREE))));
+ }
+ break;
+
+ default:
+ if ((int) code >= (int)LAST_AND_UNUSED_TREE_CODE)
+ {
+ error ("tree code `%s' unhandled in build_compare_set_expr",
+ tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+ break;
+ }
+
+ return build ((enum tree_code)code, result_type,
+ op0, op1);
+}
+\f
+/* Convert a varying string (or array) to dynamic non-varying string:
+ EXP becomes EXP.var_data(0 UP EXP.var_length). */
+
+tree
+varying_to_slice (exp)
+ tree exp;
+{
+ if (!chill_varying_type_p (TREE_TYPE (exp)))
+ return exp;
+ else
+ { tree size, data, data_domain, doamin, min;
+ tree novelty = CH_NOVELTY (TREE_TYPE (exp));
+ exp = save_if_needed (exp);
+ size = build_component_ref (exp, var_length_id);
+ data = build_component_ref (exp, var_data_id);
+ TREE_TYPE (data) = copy_novelty (novelty, TREE_TYPE (data));
+ data_domain = TYPE_DOMAIN (TREE_TYPE (data));
+ if (data_domain != NULL_TREE
+ && TYPE_MIN_VALUE (data_domain) != NULL_TREE)
+ min = TYPE_MIN_VALUE (data_domain);
+ else
+ min = integer_zero_node;
+ return build_chill_slice (data, min, size);
+ }
+}
+
+/* Convert a scalar argument to a string or array type. This is a subroutine
+ of `build_concat_expr'. */
+
+static tree
+scalar_to_string (exp)
+ tree exp;
+{
+ tree type = TREE_TYPE (exp);
+
+ if (SCALAR_P (type))
+ {
+ int was_const = TREE_CONSTANT (exp);
+ if (TREE_TYPE (exp) == char_type_node)
+ exp = convert (string_one_type_node, exp);
+ else if (TREE_TYPE (exp) == boolean_type_node)
+ exp = convert (bitstring_one_type_node, exp);
+ else
+ exp = convert (build_array_type_for_scalar (type), exp);
+ TREE_CONSTANT (exp) = was_const;
+ return exp;
+ }
+ return varying_to_slice (exp);
+}
+
+/* FIXME: Generalize this to general arrays (not just strings),
+ at least for the compiler-generated case of padding fixed-length arrays. */
+
+static tree
+build_concat_expr (op0, op1)
+ tree op0, op1;
+{
+ tree orig_op0 = op0, orig_op1 = op1;
+ tree type0, type1, size0, size1, res;
+
+ op0 = scalar_to_string (op0);
+ type0 = TREE_TYPE (op0);
+ op1 = scalar_to_string (op1);
+ type1 = TREE_TYPE (op1);
+ size1 = size_in_bytes (type1);
+
+ /* try to fold constant string literals */
+ if (TREE_CODE (op0) == STRING_CST
+ && (TREE_CODE (op1) == STRING_CST
+ || TREE_CODE (op1) == UNDEFINED_EXPR)
+ && TREE_CODE (size1) == INTEGER_CST)
+ {
+ int len0 = TREE_STRING_LENGTH (op0);
+ int len1 = TREE_INT_CST_LOW (size1);
+ char *result = xmalloc (len0 + len1 + 1);
+ memcpy (result, TREE_STRING_POINTER (op0), len0);
+ if (TREE_CODE (op1) == UNDEFINED_EXPR)
+ memset (&result[len0], '\0', len1);
+ else
+ memcpy (&result[len0], TREE_STRING_POINTER (op1), len1);
+ return build_chill_string (len0 + len1, result);
+ }
+ else if (TREE_CODE (type0) == TREE_CODE (type1))
+ {
+ tree result_size;
+ struct ch_class result_class;
+ struct ch_class class0;
+ struct ch_class class1;
+
+ class0 = chill_expr_class (orig_op0);
+ class1 = chill_expr_class (orig_op1);
+
+ if (TREE_CODE (type0) == SET_TYPE)
+ {
+ result_size = size_binop (PLUS_EXPR,
+ discrete_count (TYPE_DOMAIN (type0)),
+ discrete_count (TYPE_DOMAIN (type1)));
+ result_class.mode = build_bitstring_type (result_size);
+ }
+ else
+ {
+ tree max0 = TYPE_MAX_VALUE (type0);
+ tree max1 = TYPE_MAX_VALUE (type1);
+
+ /* new array's dynamic size (in bytes). */
+ size0 = size_in_bytes (type0);
+ /* size1 was computed above. */
+
+ result_size = size_binop (PLUS_EXPR, size0, size1);
+ /* new array's type. */
+ result_class.mode = build_string_type (char_type_node, result_size);
+
+ if (max0 || max1)
+ {
+ max0 = max0 == 0 ? size0 : convert (sizetype, max0);
+ max1 = max1 == 0 ? size1 : convert (sizetype, max1);
+ TYPE_MAX_VALUE (result_class.mode)
+ = size_binop (PLUS_EXPR, max0, max1);
+ }
+ }
+
+ if (class0.kind == CH_VALUE_CLASS || class1.kind == CH_VALUE_CLASS)
+ {
+ tree novelty0 = CH_NOVELTY (TREE_TYPE (orig_op0));
+ result_class.kind = CH_VALUE_CLASS;
+ if (class0.kind == CH_VALUE_CLASS && novelty0 != NULL_TREE)
+ SET_CH_NOVELTY_NONNIL (result_class.mode, novelty0);
+ else if (class1.kind == CH_VALUE_CLASS)
+ SET_CH_NOVELTY (result_class.mode,
+ CH_NOVELTY (TREE_TYPE (orig_op1)));
+ }
+ else
+ result_class.kind = CH_DERIVED_CLASS;
+
+ if (TREE_CODE (result_class.mode) == SET_TYPE
+ && TREE_CONSTANT (op0) && TREE_CONSTANT (op1)
+ && TREE_CODE (op0) == CONSTRUCTOR && TREE_CODE (op1) == CONSTRUCTOR)
+ {
+ HOST_WIDE_INT size0, size1; char *buffer;
+ size0 = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type0))) + 1;
+ size1 = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type1))) + 1;
+ buffer = (char*) alloca (size0 + size1);
+ if (size0 < 0 || size1 < 0
+ || get_set_constructor_bits (op0, buffer, size0)
+ || get_set_constructor_bits (op1, buffer + size0, size1))
+ abort ();
+ res = expand_packed_set (buffer, size0 + size1, result_class.mode);
+ }
+ else
+ res = build (CONCAT_EXPR, result_class.mode, op0, op1);
+ return convert_to_class (result_class, res);
+ }
+ else
+ {
+ error ("incompatible modes in concat expression");
+ return error_mark_node;
+ }
+}
+
+/*
+ * handle varying and fixed array compare operations
+ */
+static tree
+build_compare_string_expr (code, op0, op1)
+ enum chill_tree_code code;
+ tree op0, op1;
+{
+ if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK)
+ return error_mark_node;
+ if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK)
+ return error_mark_node;
+
+ if (tree_int_cst_equal (TYPE_SIZE (TREE_TYPE (op0)),
+ TYPE_SIZE (TREE_TYPE (op1)))
+ && ! chill_varying_type_p (TREE_TYPE (op0))
+ && ! chill_varying_type_p (TREE_TYPE (op1)))
+ {
+ tree size = size_in_bytes (TREE_TYPE (op0));
+ tree temp = lookup_name (get_identifier ("memcmp"));
+ temp = build_chill_function_call (temp,
+ tree_cons (NULL_TREE, force_addr_of (op0),
+ tree_cons (NULL_TREE, force_addr_of (op1),
+ tree_cons (NULL_TREE, size, NULL_TREE))));
+ return build_compare_discrete_expr (code, temp, integer_zero_node);
+ }
+
+ switch ((int)code)
+ {
+ case EQ_EXPR:
+ code = STRING_EQ_EXPR;
+ break;
+ case GE_EXPR:
+ return invert_truthvalue (build_compare_string_expr (LT_EXPR, op0, op1));
+ case LE_EXPR:
+ return invert_truthvalue (build_compare_string_expr (LT_EXPR, op1, op0));
+ case GT_EXPR:
+ return build_compare_string_expr (LT_EXPR, op1, op0);
+ case LT_EXPR:
+ code = STRING_LT_EXPR;
+ break;
+ case NE_EXPR:
+ return invert_truthvalue (build_compare_string_expr (EQ_EXPR, op0, op1));
+ default:
+ error ("Invalid operation on array of chars");
+ return error_mark_node;
+ }
+
+ return build (code, boolean_type_node, op0, op1);
+}
+
+tree
+compare_records (exp0, exp1)
+ tree exp0, exp1;
+{
+ tree type = TREE_TYPE (exp0);
+ tree field;
+ int have_variants = 0;
+
+ tree result = boolean_true_node;
+ extern int maximum_field_alignment;
+
+ if (TREE_CODE (type) != RECORD_TYPE)
+ abort ();
+
+ exp0 = save_if_needed (exp0);
+ exp1 = save_if_needed (exp1);
+
+ for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+ {
+ if (DECL_NAME (field) == NULL_TREE)
+ {
+ have_variants = 1;
+ break;
+ }
+ }
+
+ /* in case of -fpack we always do a memcmp */
+ if (maximum_field_alignment != 0)
+ {
+ tree memcmp_func = lookup_name (get_identifier ("memcmp"));
+ tree arg1 = force_addr_of (exp0);
+ tree arg2 = force_addr_of (exp1);
+ tree arg3 = size_in_bytes (type);
+ tree fcall = build_chill_function_call (memcmp_func,
+ tree_cons (NULL_TREE, arg1,
+ tree_cons (NULL_TREE, arg2,
+ tree_cons (NULL_TREE, arg3, NULL_TREE))));
+
+ if (have_variants)
+ warning ("comparison of variant structures is unsafe");
+ result = build_chill_binary_op (EQ_EXPR, fcall, integer_zero_node);
+ return result;
+ }
+
+ if (have_variants)
+ {
+ sorry ("compare with variant records");
+ return error_mark_node;
+ }
+
+ for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+ {
+ tree exp0fld = build_component_ref (exp0, DECL_NAME (field));
+ tree exp1fld = build_component_ref (exp1, DECL_NAME (field));
+ tree eq_flds = build_chill_binary_op (EQ_EXPR, exp0fld, exp1fld);
+ result = build_chill_binary_op (TRUTH_AND_EXPR, result, eq_flds);
+ }
+ return result;
+}
+\f
+int
+compare_int_csts (op, val1, val2)
+ enum tree_code op;
+ tree val1, val2;
+{
+ int result;
+ tree tmp;
+ tree type1 = TREE_TYPE (val1);
+ tree type2 = TREE_TYPE (val2);
+ switch (op)
+ {
+ case GT_EXPR:
+ case GE_EXPR:
+ tmp = val1; val1 = val2; val2 = tmp;
+ tmp = type1; type1 = type2; type2 = tmp;
+ op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR;
+ /* ... fall through ... */
+ case LT_EXPR:
+ case LE_EXPR:
+ if (!TREE_UNSIGNED (type1))
+ {
+ if (!TREE_UNSIGNED (type2))
+ result = INT_CST_LT (val1, val2);
+ else if (TREE_INT_CST_HIGH (val1) < 0)
+ result = 1;
+ else
+ result = INT_CST_LT_UNSIGNED (val1, val2);
+ }
+ else
+ {
+ if (!TREE_UNSIGNED (type2) && TREE_INT_CST_HIGH (val2) < 0)
+ result = 0;
+ else
+ result = INT_CST_LT_UNSIGNED (val1, val2);
+ }
+ if (op == LT_EXPR || result == 1)
+ break;
+ /* else fall through ... */
+ case NE_EXPR:
+ case EQ_EXPR:
+ if (TREE_INT_CST_LOW (val1) == TREE_INT_CST_LOW (val2)
+ && TREE_INT_CST_HIGH (val1) == TREE_INT_CST_HIGH (val2)
+ /* They're bitwise equal.
+ Check for one being negative and the other unsigned. */
+ && (TREE_INT_CST_HIGH (val2) >= 0
+ || TREE_UNSIGNED (TREE_TYPE (val1))
+ == TREE_UNSIGNED (TREE_TYPE (val2))))
+ result = 1;
+ else
+ result = 0;
+ if (op == NE_EXPR)
+ result = !result;
+ break;
+ }
+ return result;
+}
+
+/* Build an expression to compare discrete values VAL1 and VAL2.
+ This does not check that they are discrete, nor that they are
+ compatible; if you need such checks use build_compare_expr. */
+
+tree
+build_compare_discrete_expr (op, val1, val2)
+ enum chill_tree_code op;
+ tree val1, val2;
+{
+ tree type1 = TREE_TYPE (val1);
+ tree type2 = TREE_TYPE (val2);
+ tree tmp;
+
+ if (TREE_CODE (val1) == INTEGER_CST && TREE_CODE (val2) == INTEGER_CST)
+ {
+ if (compare_int_csts (op, val1, val2))
+ return boolean_true_node;
+ else
+ return boolean_false_node;
+ }
+
+ if (TREE_UNSIGNED (type1) != TREE_UNSIGNED (type2))
+ {
+ switch (op)
+ {
+ case GT_EXPR:
+ case GE_EXPR:
+ tmp = val1; val1 = val2; val2 = tmp;
+ tmp = type1; type1 = type2; type2 = tmp;
+ op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR;
+ /* ... fall through ... */
+ case LT_EXPR:
+ case LE_EXPR:
+ if (TREE_UNSIGNED (type2))
+ {
+ tmp = build_int_2_wide (0, 0);
+ TREE_TYPE (tmp) = type1;
+ val1 = save_expr (val1);
+ tmp = fold (build (LT_EXPR, boolean_type_node, val1, tmp));
+ if (TYPE_PRECISION (type2) < TYPE_PRECISION (type1))
+ {
+ type2 = unsigned_type (type1);
+ val2 = convert_to_integer (type2, val2);
+ }
+ val1 = convert_to_integer (type2, val1);
+ return fold (build (TRUTH_OR_EXPR, boolean_type_node,
+ tmp,
+ fold (build (op, boolean_type_node,
+ val1, val2))));
+ }
+ unsigned_vs_signed: /* val1 is unsigned, val2 is signed */
+ tmp = build_int_2_wide (0, 0);
+ TREE_TYPE (tmp) = type2;
+ val2 = save_expr (val2);
+ tmp = fold (build (GE_EXPR, boolean_type_node, val2, tmp));
+ if (TYPE_PRECISION (type1) < TYPE_PRECISION (type2))
+ {
+ type1 = unsigned_type (type2);
+ val1 = convert_to_integer (type1, val1);
+ }
+ val2 = convert_to_integer (type1, val2);
+ return fold (build (TRUTH_AND_EXPR, boolean_type_node, tmp,
+ fold (build (op, boolean_type_node,
+ val1, val2))));
+ case EQ_EXPR:
+ if (TREE_UNSIGNED (val2))
+ {
+ tmp = val1; val1 = val2; val2 = tmp;
+ tmp = type1; type1 = type2; type2 = tmp;
+ }
+ goto unsigned_vs_signed;
+ case NE_EXPR:
+ tmp = build_compare_expr (EQ_EXPR, val1, val2);
+ return build_chill_unary_op (TRUTH_NOT_EXPR, tmp);
+ }
+ }
+ if (TYPE_PRECISION (type1) > TYPE_PRECISION (type2))
+ val2 = convert (type1, val2);
+ else if (TYPE_PRECISION (type1) < TYPE_PRECISION (type2))
+ val1 = convert (type2, val1);
+ return fold (build (op, boolean_type_node, val1, val2));
+}
+
+tree
+build_compare_expr (op, val1, val2)
+ enum chill_tree_code op;
+ tree val1, val2;
+{
+ tree tmp;
+ tree type1, type2;
+ val1 = check_have_mode (val1, "relational expression");
+ val2 = check_have_mode (val2, "relational expression");
+ if (val1 == NULL_TREE || TREE_CODE (val1) == ERROR_MARK)
+ return error_mark_node;
+ if (val2 == NULL_TREE || TREE_CODE (val2) == ERROR_MARK)
+ return error_mark_node;
+
+ if (pass == 1)
+ return build (op, NULL_TREE, val1, val2);
+
+ if (!CH_COMPATIBLE_CLASSES (val1, val2))
+ {
+ error ("incompatible operands to %s", boolean_code_name [op]);
+ return error_mark_node;
+ }
+
+ tmp = CH_ROOT_MODE (TREE_TYPE (val1));
+ if (tmp != TREE_TYPE (val1))
+ val1 = convert (tmp, val1);
+ tmp = CH_ROOT_MODE (TREE_TYPE (val2));
+ if (tmp != TREE_TYPE (val2))
+ val2 = convert (tmp, val2);
+
+ type1 = TREE_TYPE (val1);
+ type2 = TREE_TYPE (val2);
+
+ if (TREE_CODE (type1) == SET_TYPE)
+ tmp = build_compare_set_expr (op, val1, val2);
+
+ else if (discrete_type_p (type1))
+ tmp = build_compare_discrete_expr (op, val1, val2);
+
+ else if (chill_varying_type_p (type1) || chill_varying_type_p (type2)
+ || (TREE_CODE (type1) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (type1)) == CHAR_TYPE)
+ || (TREE_CODE (type2) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (type2)) == CHAR_TYPE) )
+ tmp = build_compare_string_expr (op, val1, val2);
+
+ else if ((TREE_CODE (type1) == RECORD_TYPE
+ || TREE_CODE (type2) == RECORD_TYPE)
+ && (op == EQ_EXPR || op == NE_EXPR))
+ {
+ /* This is for handling INSTANCEs being compared against NULL. */
+ if (val1 == null_pointer_node)
+ val1 = convert (type2, val1);
+ if (val2 == null_pointer_node)
+ val2 = convert (type1, val2);
+
+ tmp = compare_records (val1, val2);
+ if (op == NE_EXPR)
+ tmp = build_chill_unary_op (TRUTH_NOT_EXPR, tmp);
+ }
+
+ else if (TREE_CODE (type1) == REAL_TYPE || TREE_CODE (type2) == REAL_TYPE
+ || (op == EQ_EXPR || op == NE_EXPR))
+ {
+ tmp = build (op, boolean_type_node, val1, val2);
+ CH_DERIVED_FLAG (tmp) = 1; /* Optimization to avoid copy_node. */
+ tmp = fold (tmp);
+ }
+
+ else
+ {
+ error ("relational operator not allowed for this mode");
+ return error_mark_node;
+ }
+
+ if (!CH_DERIVED_FLAG (tmp))
+ {
+ tmp = copy_node (tmp);
+ CH_DERIVED_FLAG (tmp) = 1;
+ }
+ return tmp;
+}
+\f
+tree
+finish_chill_binary_op (node)
+ tree node;
+{
+ tree op0 = check_have_mode (TREE_OPERAND (node, 0), "binary expression");
+ tree op1 = check_have_mode (TREE_OPERAND (node, 1), "binary expression");
+ tree type0 = TREE_TYPE (op0);
+ tree type1 = TREE_TYPE (op1);
+ enum tree_code code0;
+ enum tree_code code1;
+ tree folded;
+
+ if (TREE_CODE (op0) == ERROR_MARK || TREE_CODE (op1) == ERROR_MARK)
+ return error_mark_node;
+
+ if (UNSATISFIED (op0) || UNSATISFIED (op1))
+ {
+ UNSATISFIED_FLAG (node) = 1;
+ return node;
+ }
+#if 0
+ /* assure that both operands have a type */
+ if (! type0 && type1)
+ {
+ op0 = convert (type1, op0);
+ type0 = TREE_TYPE (op0);
+ }
+ if (! type1 && type0)
+ {
+ op1 = convert (type0, op1);
+ type1 = TREE_TYPE (op1);
+ }
+#endif
+ UNSATISFIED_FLAG (node) = 0;
+#if 0
+
+ { int op0f = TREE_CODE (op0) == FUNCTION_DECL;
+ int op1f = TREE_CODE (op1) == FUNCTION_DECL;
+ if (op0f)
+ op0 = convert (build_pointer_type (TREE_TYPE (op0)), op0);
+ if (op1f)
+ op1 = convert (build_pointer_type (TREE_TYPE (op1)), op1);
+ if ((op0f || op1f)
+ && code != EQ_EXPR && code != NE_EXPR)
+ error ("Cannot use %s operator on PROC mode variable",
+ tree_code_name[(int)code]);
+ }
+
+ if (invalid_left_operand (type0, code))
+ {
+ error ("invalid left operand of %s", tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+ if (invalid_right_operand (code, type1))
+ {
+ error ("invalid right operand of %s", tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+#endif
+
+ switch (TREE_CODE (node))
+ {
+ case CONCAT_EXPR:
+ return build_concat_expr (op0, op1);
+
+ case REPLICATE_EXPR:
+ op0 = fold (op0);
+ if (!TREE_CONSTANT (op0) || !TREE_CONSTANT (op1))
+ {
+ error ("repetition expression must be constant");
+ return error_mark_node;
+ }
+ else
+ return build_chill_repetition_op (op0, op1);
+
+ case FLOOR_MOD_EXPR:
+ case TRUNC_MOD_EXPR:
+ if (TREE_CODE (type0) != INTEGER_TYPE)
+ {
+ error ("left argument to MOD/REM operator must be integral");
+ return error_mark_node;
+ }
+ if (TREE_CODE (type1) != INTEGER_TYPE)
+ {
+ error ("right argument to MOD/REM operator must be integral");
+ return error_mark_node;
+ }
+ break;
+
+ case MINUS_EXPR:
+ if (TREE_CODE (type1) == SET_TYPE)
+ {
+ tree temp = fold_set_expr (MINUS_EXPR, op0, op1);
+
+ if (temp)
+ return temp;
+ if (TYPE_MODE (type1) == BLKmode)
+ TREE_SET_CODE (node, SET_DIFF_EXPR);
+ else
+ {
+ op1 = build_chill_unary_op (BIT_NOT_EXPR, op1);
+ TREE_OPERAND (node, 1) = op1;
+ TREE_SET_CODE (node, BIT_AND_EXPR);
+ }
+ }
+ break;
+
+ case TRUNC_DIV_EXPR:
+ if (TREE_CODE (type0) == REAL_TYPE || TREE_CODE (type1) == REAL_TYPE)
+ TREE_SET_CODE (node, RDIV_EXPR);
+ break;
+
+ case BIT_AND_EXPR:
+ if (TYPE_MODE (type1) == BLKmode)
+ TREE_SET_CODE (node, SET_AND_EXPR);
+ goto fold_set_binop;
+ case BIT_IOR_EXPR:
+ if (TYPE_MODE (type1) == BLKmode)
+ TREE_SET_CODE (node, SET_IOR_EXPR);
+ goto fold_set_binop;
+ case BIT_XOR_EXPR:
+ if (TYPE_MODE (type1) == BLKmode)
+ TREE_SET_CODE (node, SET_XOR_EXPR);
+ goto fold_set_binop;
+ case SET_AND_EXPR:
+ case SET_IOR_EXPR:
+ case SET_XOR_EXPR:
+ case SET_DIFF_EXPR:
+ fold_set_binop:
+ if (TREE_CODE (type0) == SET_TYPE)
+ {
+ tree temp = fold_set_expr (TREE_CODE (node), op0, op1);
+
+ if (temp)
+ return temp;
+ }
+ break;
+
+ case SET_IN_EXPR:
+ if (TREE_CODE (type1) != SET_TYPE || CH_BOOLS_TYPE_P (type1))
+ {
+ error ("right operand of IN is not a powerset");
+ return error_mark_node;
+ }
+ if (!CH_COMPATIBLE (op0, TYPE_DOMAIN (type1)))
+ {
+ error ("left operand of IN incompatible with right operand");
+ return error_mark_node;
+ }
+ type0 = CH_ROOT_MODE (type0);
+ if (type0 != TREE_TYPE (op0))
+ TREE_OPERAND (node, 0) = op0 = convert (type0, op0);
+ TREE_TYPE (node) = boolean_type_node;
+ CH_DERIVED_FLAG (node) = 1;
+ node = fold (node);
+ if (!CH_DERIVED_FLAG (node))
+ {
+ node = copy_node (node);
+ CH_DERIVED_FLAG (node) = 1;
+ }
+ return node;
+ case NE_EXPR:
+ case EQ_EXPR:
+ case GE_EXPR:
+ case GT_EXPR:
+ case LE_EXPR:
+ case LT_EXPR:
+ return build_compare_expr (TREE_CODE (node), op0, op1);
+ default:
+ ;
+ }
+
+ if (!CH_COMPATIBLE_CLASSES (op0, op1))
+ {
+ error ("incompatible operands to %s", tree_code_name[(int) TREE_CODE (node)]);
+ return error_mark_node;
+ }
+
+
+ finish:
+ if (TREE_TYPE (node) == NULL_TREE)
+ {
+ struct ch_class class;
+ class = CH_ROOT_RESULTING_CLASS (op0, op1);
+ TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0);
+ type0 = TREE_TYPE (op0);
+ TREE_OPERAND (node, 1) = op1 = convert_to_class (class, op1);
+ type1 = TREE_TYPE (op1);
+ TREE_TYPE (node) = class.mode;
+ folded = convert_to_class (class, fold (node));
+ }
+ else
+ folded = fold (node);
+#if 0
+ if (folded == node)
+ TREE_CONSTANT (folded) = TREE_CONSTANT (op0) & TREE_CONSTANT (op1);
+#endif
+ if (TREE_CODE (node) == TRUNC_DIV_EXPR)
+ if (TREE_CONSTANT (op1))
+ {
+ if (tree_int_cst_equal (op1, integer_zero_node))
+ {
+ error ("division by zero");
+ return integer_zero_node;
+ }
+ }
+ else if (range_checking)
+ {
+#if 0
+ tree test = build (EQ_EXPR, boolean_type_node, op1, integer_zero_node);
+ /* Should this be overflow? */
+ folded = check_expression (folded, test,
+ ridpointers[(int) RID_RANGEFAIL]);
+#endif
+ }
+ return folded;
+}
+\f
+/*
+ * This implements the '->' operator, which, like the '&' in C,
+ * returns a pointer to an object, which has the type of
+ * pointer-to-that-object.
+ *
+ * FORCE is 0 when we're evaluating a user-level syntactic construct,
+ * and 1 when we're calling from inside the compiler.
+ */
+tree
+build_chill_arrow_expr (ref, force)
+ tree ref;
+ int force;
+{
+ tree addr_type;
+ tree result;
+
+ if (pass == 1)
+ {
+ error ("-> operator not allow in constant expression");
+ return error_mark_node;
+ }
+
+ if (ref == NULL_TREE || TREE_CODE (ref) == ERROR_MARK)
+ return ref;
+
+ while (TREE_CODE (TREE_TYPE (ref)) == REFERENCE_TYPE)
+ ref = convert (TREE_TYPE (TREE_TYPE (ref)), ref);
+
+ if (!force && ! CH_LOCATION_P (ref))
+ {
+ if (TREE_CODE (ref) == STRING_CST)
+ pedwarn ("taking the address of a string literal is non-standard");
+ else if (TREE_CODE (TREE_TYPE (ref)) == FUNCTION_TYPE)
+ pedwarn ("taking the address of a function is non-standard");
+ else
+ {
+ error ("ADDR requires a LOCATION argument");
+ return error_mark_node;
+ }
+ /* FIXME: Should we be sure that ref isn't a
+ function if we're being pedantic? */
+ }
+
+ addr_type = build_pointer_type (TREE_TYPE (ref));
+
+#if 0
+ /* This transformation makes chill_expr_class return CH_VALUE_CLASS
+ when it should return CH_REFERENCE_CLASS. That could be fixed,
+ but we probably don't want this transformation anyway. */
+ if (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */
+ {
+ tree addr;
+ while (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */
+ ref = TREE_OPERAND (ref, 0);
+ mark_addressable (ref);
+ addr = build1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (ref)), ref);
+ return build1 (NOP_EXPR, /* RETYPE_EXPR */
+ addr_type,
+ addr);
+ }
+ else
+#endif
+ {
+ if (! mark_addressable (ref))
+ {
+ error ("-> expression is not addressable");
+ return error_mark_node;
+ }
+ result = build1 (ADDR_EXPR, addr_type, ref);
+ if (staticp (ref)
+ && ! (TREE_CODE (ref) == FUNCTION_DECL
+ && DECL_CONTEXT (ref) != 0))
+ TREE_CONSTANT (result) = 1;
+ return result;
+ }
+}
+\f
+/*
+ * This implements the ADDR builtin function, which returns a
+ * free reference, analogous to the C 'void *'.
+ */
+tree
+build_chill_addr_expr (ref, errormsg)
+ tree ref;
+ char *errormsg;
+{
+ if (ref == error_mark_node)
+ return ref;
+
+ if (! CH_LOCATION_P (ref)
+ && TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE)
+ {
+ error ("ADDR parameter must be a LOCATION", errormsg);
+ return error_mark_node;
+ }
+ ref = build_chill_arrow_expr (ref, 1);
+
+ if (ref != NULL_TREE && TREE_CODE (ref) != ERROR_MARK)
+ TREE_TYPE (ref) = ptr_type_node;
+ else if (errormsg == NULL)
+ {
+ error ("possible internal error in build_chill_arrow_expr");
+ return error_mark_node;
+ }
+ else
+ {
+ error ("%s is not addressable", errormsg);
+ return error_mark_node;
+ }
+ return ref;
+}
+\f
+tree
+build_chill_binary_op (code, op0, op1)
+ enum chill_tree_code code;
+ tree op0, op1;
+{
+ register tree result;
+
+ if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK)
+ return error_mark_node;
+ if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK)
+ return error_mark_node;
+
+ result = build (code, NULL_TREE, op0, op1);
+
+ if (pass != 1)
+ result = finish_chill_binary_op (result);
+ return result;
+}
+\f
+/*
+ * process a string repetition phrase '(' COUNT ')' STRING
+ */
+tree
+string_char_rep (count, string)
+ int count;
+ tree string;
+{
+ int slen, charindx, repcnt;
+ char ch;
+ char *temp;
+ char *inp;
+ char *outp;
+ tree type;
+
+ if (string == NULL_TREE || TREE_CODE (string) == ERROR_MARK)
+ return error_mark_node;
+
+ type = TREE_TYPE (string);
+ slen = int_size_in_bytes (type);
+ temp = xmalloc (slen * count);
+ inp = &ch;
+ outp = temp;
+ if (TREE_CODE (string) == STRING_CST)
+ inp = TREE_STRING_POINTER (string);
+ else /* single character */
+ ch = (char)TREE_INT_CST_LOW (string);
+
+ /* copy the string/char COUNT times into the output buffer */
+ for (outp = temp, repcnt = 0; repcnt < count; repcnt++)
+ for (charindx = 0; charindx < slen; charindx++)
+ *outp++ = inp[charindx];
+ return build_chill_string (slen * count, temp);
+}
+\f
+/* Build a bit-string constant containing with the given LENGTH
+ containing all ones (if VALUE is true), or all zeros (if VALUE is false). */
+
+tree
+build_boring_bitstring (length, value)
+ long length;
+ int value;
+{
+ tree result;
+ tree list; /* Value of CONSTRUCTOR_ELTS in the result. */
+ if (value && length > 0)
+ list = tree_cons (integer_zero_node, size_int (length - 1), NULL_TREE);
+ else
+ list = NULL_TREE;
+
+ result = build (CONSTRUCTOR,
+ build_bitstring_type (size_int (length)),
+ NULL_TREE,
+ list);
+ TREE_CONSTANT (result) = 1;
+ CH_DERIVED_FLAG (result) = 1;
+ return result;
+}
+
+/*
+ * handle a string repetition, with the syntax:
+ * ( COUNT ) 'STRING'
+ * COUNT is required to be constant, positive and folded.
+ */
+tree
+build_chill_repetition_op (count_op, string)
+ tree count_op;
+ tree string;
+{
+ int count;
+ tree type = TREE_TYPE (string);
+
+ if (TREE_CODE (count_op) != INTEGER_CST)
+ {
+ error ("repetition count is not an integer constant");
+ return error_mark_node;
+ }
+
+ count = TREE_INT_CST_LOW (count_op);
+
+ if (count < 0)
+ {
+ error ("repetition count < 0");
+ return error_mark_node;
+ }
+ if (! TREE_CONSTANT (string))
+ {
+ error ("repetition value not constant");
+ return error_mark_node;
+ }
+
+ if (TREE_CODE (string) == STRING_CST)
+ return string_char_rep (count, string);
+
+ switch ((int)TREE_CODE (type))
+ {
+ case BOOLEAN_TYPE:
+ if (TREE_CODE (string) == INTEGER_CST)
+ return build_boring_bitstring (count, TREE_INT_CST_LOW (string));
+ error ("bitstring repetition of non-constant boolean");
+ return error_mark_node;
+
+ case CHAR_TYPE:
+ return string_char_rep (count, string);
+
+ case SET_TYPE:
+ { int i, tree_const = 1;
+ tree new_list = NULL_TREE;
+ tree vallist;
+ tree result;
+ tree domain = TYPE_DOMAIN (type);
+ tree orig_length;
+ HOST_WIDE_INT orig_len;
+
+ if (!CH_BOOLS_TYPE_P (type)) /* cannot replicate a powerset */
+ break;
+
+ orig_length = discrete_count (domain);
+
+ if (TREE_CODE (string) != CONSTRUCTOR || !TREE_CONSTANT (string)
+ || TREE_CODE (orig_length) != INTEGER_CST)
+ {
+ error ("string repetition operand is non-constant bitstring");
+ return error_mark_node;
+ }
+
+
+ orig_len = TREE_INT_CST_LOW (orig_length);
+
+ /* if the set is empty, this is NULL */
+ vallist = TREE_OPERAND (string, 1);
+
+ if (vallist == NULL_TREE) /* No bits are set. */
+ return build_boring_bitstring (count * orig_len, 0);
+ else if (TREE_CHAIN (vallist) == NULL_TREE
+ && (TREE_PURPOSE (vallist) == NULL_TREE
+ ? (orig_len == 1
+ && tree_int_cst_equal (TYPE_MIN_VALUE (domain),
+ TREE_VALUE (vallist)))
+ : (tree_int_cst_equal (TYPE_MIN_VALUE (domain),
+ TREE_PURPOSE (vallist))
+ && tree_int_cst_equal (TYPE_MAX_VALUE (domain),
+ TREE_VALUE (vallist)))))
+ return build_boring_bitstring (count * orig_len, 1);
+
+ for (i = 0; i < count; i++)
+ {
+ tree origin = build_int_2 (i * orig_len, 0);
+ tree temp;
+
+ /* scan down the given value list, building
+ new bit-positions */
+ for (temp = vallist; temp; temp = TREE_CHAIN (temp))
+ {
+ tree new_value
+ = fold (size_binop (PLUS_EXPR, origin, TREE_VALUE (temp)));
+ tree new_purpose = NULL_TREE;
+ if (! TREE_CONSTANT (TREE_VALUE (temp)))
+ tree_const = 0;
+ if (TREE_PURPOSE (temp))
+ {
+ new_purpose = fold (size_binop (PLUS_EXPR,
+ origin,
+ TREE_PURPOSE (temp)));
+ if (! TREE_CONSTANT (TREE_PURPOSE (temp)))
+ tree_const = 0;
+ }
+
+ new_list = tree_cons (new_purpose,
+ new_value, new_list);
+ }
+ }
+ result = build (CONSTRUCTOR,
+ build_bitstring_type (size_int (count * orig_len)),
+ NULL_TREE, nreverse (new_list));
+ TREE_CONSTANT (result) = tree_const;
+ CH_DERIVED_FLAG (result) = CH_DERIVED_FLAG (string);
+ return result;
+ }
+
+ default:
+ error ("non-char, non-bit string repetition");
+ return error_mark_node;
+ }
+ return error_mark_node;
+}
+\f
+tree
+finish_chill_unary_op (node)
+ tree node;
+{
+ enum chill_tree_code code = TREE_CODE (node);
+ tree op0 = check_have_mode (TREE_OPERAND (node, 0), "unary expression");
+ tree type0 = TREE_TYPE (op0);
+ struct ch_class class;
+
+ if (TREE_CODE (op0) == ERROR_MARK)
+ return error_mark_node;
+ /* The expression codes of the data types of the arguments tell us
+ whether the arguments are integers, floating, pointers, etc. */
+
+ if (TREE_CODE (type0) == REFERENCE_TYPE)
+ {
+ op0 = convert (TREE_TYPE (type0), op0);
+ type0 = TREE_TYPE (op0);
+ }
+
+ if (invalid_right_operand (code, type0))
+ {
+ error ("invalid operand of %s",
+ tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+ switch ((int)TREE_CODE (type0))
+ {
+ case ARRAY_TYPE:
+ if (TREE_CODE ( TREE_TYPE (type0)) == BOOLEAN_TYPE)
+ code = SET_NOT_EXPR;
+ else
+ {
+ error ("right operand of %s is not array of boolean",
+ tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+ break;
+ case BOOLEAN_TYPE:
+ switch ((int)code)
+ {
+ case BIT_NOT_EXPR:
+ case TRUTH_NOT_EXPR:
+ return invert_truthvalue (truthvalue_conversion (op0));
+
+ default:
+ error ("%s operator applied to boolean variable",
+ tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+ break;
+
+ case SET_TYPE:
+ switch ((int)code)
+ {
+ case BIT_NOT_EXPR:
+ case NEGATE_EXPR:
+ {
+ tree temp = fold_set_expr (BIT_NOT_EXPR, op0, NULL_TREE);
+
+ if (temp)
+ return temp;
+
+ code = SET_NOT_EXPR;
+ }
+ break;
+
+ default:
+ error ("invalid right operand of %s", tree_code_name[(int)code]);
+ return error_mark_node;
+ }
+
+ }
+
+ class = chill_expr_class (op0);
+ if (class.mode)
+ class.mode = CH_ROOT_MODE (class.mode);
+ TREE_SET_CODE (node, code);
+ TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0);
+ TREE_TYPE (node) = TREE_TYPE (op0);
+
+ node = convert_to_class (class, fold (node));
+
+ /* FIXME: should call
+ * cond_type_range_exception (op0);
+ */
+ return node;
+}
+
+/* op is TRUTH_NOT_EXPR, BIT_NOT_EXPR, or NEGATE_EXPR */
+
+tree
+build_chill_unary_op (code, op0)
+ enum chill_tree_code code;
+ tree op0;
+{
+ register tree result = NULL_TREE;
+ struct ch_class class;
+ tree type0 = TREE_TYPE (op0);
+
+ if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK)
+ return error_mark_node;
+
+ result = build1 (code, NULL_TREE, op0);
+
+ if (pass != 1)
+ result = finish_chill_unary_op (result);
+ return result;
+}
+
+tree
+truthvalue_conversion (expr)
+ tree expr;
+{
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+#if 0 /* what about a LE_EXPR (integer_type, integer_type ) */
+ if (TREE_CODE (TREE_TYPE (expr)) != BOOLEAN_TYPE)
+ error ("non-boolean mode in conditional expression");
+#endif
+
+ switch ((int)TREE_CODE (expr))
+ {
+ /* It is simpler and generates better code to have only TRUTH_*_EXPR
+ or comparison expressions as truth values at this level. */
+#if 0
+ case COMPONENT_REF:
+ /* A one-bit unsigned bit-field is already acceptable. */
+ if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
+ && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
+ return expr;
+ break;
+#endif
+
+ case EQ_EXPR:
+ /* It is simpler and generates better code to have only TRUTH_*_EXPR
+ or comparison expressions as truth values at this level. */
+ case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case ERROR_MARK:
+ return expr;
+
+ case INTEGER_CST:
+ return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
+
+ case REAL_CST:
+ return real_zerop (expr) ? boolean_false_node : boolean_true_node;
+
+ case ADDR_EXPR:
+ if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
+ return build (COMPOUND_EXPR, boolean_type_node,
+ TREE_OPERAND (expr, 0), boolean_true_node);
+ else
+ return boolean_true_node;
+
+ case NEGATE_EXPR:
+ case ABS_EXPR:
+ case FLOAT_EXPR:
+ case FFS_EXPR:
+ /* These don't change whether an object is non-zero or zero. */
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
+
+ case LROTATE_EXPR:
+ case RROTATE_EXPR:
+ /* These don't change whether an object is zero or non-zero, but
+ we can't ignore them if their second arg has side-effects. */
+ if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
+ return build (COMPOUND_EXPR, boolean_type_node, TREE_OPERAND (expr, 1),
+ truthvalue_conversion (TREE_OPERAND (expr, 0)));
+ else
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
+
+ case COND_EXPR:
+ /* Distribute the conversion into the arms of a COND_EXPR. */
+ return fold (build (COND_EXPR, boolean_type_node, TREE_OPERAND (expr, 0),
+ truthvalue_conversion (TREE_OPERAND (expr, 1)),
+ truthvalue_conversion (TREE_OPERAND (expr, 2))));
+
+ case CONVERT_EXPR:
+ /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
+ since that affects how `default_conversion' will behave. */
+ if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
+ || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
+ break;
+ /* fall through... */
+ case NOP_EXPR:
+ /* If this is widening the argument, we can ignore it. */
+ if (TYPE_PRECISION (TREE_TYPE (expr))
+ >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ break;
+
+ case BIT_XOR_EXPR:
+ case MINUS_EXPR:
+ /* These can be changed into a comparison of the two objects. */
+ if (TREE_TYPE (TREE_OPERAND (expr, 0))
+ == TREE_TYPE (TREE_OPERAND (expr, 1)))
+ return build_chill_binary_op (NE_EXPR, TREE_OPERAND (expr, 0),
+ TREE_OPERAND (expr, 1));
+ return build_chill_binary_op (NE_EXPR, TREE_OPERAND (expr, 0),
+ fold (build1 (NOP_EXPR,
+ TREE_TYPE (TREE_OPERAND (expr, 0)),
+ TREE_OPERAND (expr, 1))));
+ }
+
+ return build_chill_binary_op (NE_EXPR, expr, boolean_false_node);
+}
+
+
+/*
+ * return a folded tree for the powerset's length in bits. If a
+ * non-set is passed, we assume it's an array or boolean bytes.
+ */
+tree
+powersetlen (powerset)
+ tree powerset;
+{
+ tree domain, temp;
+
+ if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK)
+ return error_mark_node;
+
+ return discrete_count (TYPE_DOMAIN (TREE_TYPE (powerset)));
+}
--- /dev/null
+/* Definitions for specs for GNU CHILL.
+ Copyright (C) 1995 Free Software Foundation, Inc..
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* This is the contribution to the `default_compilers' array in gcc.c for
+ CHILL. */
+
+ {".ch", "@chill" },
+ {".chi", "@chill" },
+ {"@chill",
+ "cpp -lang-chill %{nostdinc*} %{C} %{v} %{A*} %{I*} %{P} %I\
+ %{C:%{!E:%eGNU CHILL does not support -C without using -E}}\
+ -undef -D__GNUCHILL__=%v1 -D__GNUC_MINOR__=%v2\
+ %c %{Os:-D__OPTIMIZE_SIZE__} %{O*:-D__OPTIMIZE__} %{traditional} %{ftraditional:-traditional}\
+ %{traditional-cpp:-traditional} %{!undef:%{!ansi:%p} %P} %{trigraphs}\
+ %{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*} %Z\
+ %i %{!E:%g.i}%{E:%W{o*}} \n",
+ "%{!E:cc1chill %g.i %1 \
+ %{!Q:-quiet} -dumpbase %b.ch %{d*} %{m*} %{a}\
+ %{g*} %{O*} %{W*} %{w} %{pedantic*} %{itu} \
+ %{v:-version} %{pg:-p} %{p} %{f*} %{I*} \
+ %{aux-info*} %X \
+ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\
+ %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\
+ %{!S:as %a %Y \
+ %{c:%W{o*}%{!o*:-o %w%b%O}}%{!c:-o %d%w%u%O}\
+ %{!pipe:%g.s} %A\n }}"},
--- /dev/null
+/* Language-specific hook definitions for CHILL front end.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include <stdio.h>
+#include "input.h"
+
+/* Type node for boolean types. */
+
+tree boolean_type_node;
+
+/* True if STRING(INDEX) yields a CHARS(1) (or BOOLS(1)) rather than
+ a CHAR (or BOOL). Also, makes CHARS(1) similar for CHAR,
+ and BOOLS(1) similar to BOOL. This is for compatibility
+ for the 1984 version of Z.200.*/
+int flag_old_strings = 0;
+
+/* This is set non-zero to force user input tokens to lower case.
+ This is non-standard. See Z.200, page 8. */
+int ignore_case = 1;
+
+/* True if reserved and predefined words ('special' words in the Z.200
+ terminology) are in uppercase. Obviously, this had better not be
+ true if we're ignoring input case. */
+int special_UC = 0;
+
+/* The actual name of the input file, regardless of any #line directives */
+char* chill_real_input_filename;
+extern FILE* finput;
+
+extern int maximum_field_alignment;
+
+extern void error PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern void fatal PROTO((char *, ...));
+extern int floor_log2_wide PROTO((unsigned HOST_WIDE_INT));
+extern void pedwarn_with_decl PROTO((tree, char *, ...));
+extern void sorry PROTO((char *, ...));
+extern int type_hash_list PROTO((tree));
+\f
+/* return 1 if the expression tree given has all
+ constant nodes as its leaves; return 0 otherwise. */
+int
+deep_const_expr (exp)
+ tree exp;
+{
+ enum chill_tree_code code;
+ int length;
+ int i;
+
+ if (exp == NULL_TREE)
+ return 0;
+
+ code = TREE_CODE (exp);
+ length = tree_code_length[(int) code];
+
+ /* constant leaf? return TRUE */
+ if (TREE_CODE_CLASS (code) == 'c')
+ return 1;
+
+ /* recursively check next level down */
+ for (i = 0; i < length; i++)
+ if (! deep_const_expr (TREE_OPERAND (exp, i)))
+ return 0;
+ return 1;
+}
+
+
+tree
+const_expr (exp)
+ tree exp;
+{
+ if (TREE_CODE (exp) == INTEGER_CST)
+ return exp;
+ if (TREE_CODE (exp) == CONST_DECL)
+ return const_expr (DECL_INITIAL (exp));
+ if (TREE_CODE_CLASS (TREE_CODE (exp)) == 'd'
+ && DECL_INITIAL (exp) != NULL_TREE
+ && TREE_READONLY (exp))
+ return DECL_INITIAL (exp);
+ if (deep_const_expr (exp))
+ return exp;
+ if (TREE_CODE (exp) != ERROR_MARK)
+ error ("non-constant expression");
+ return error_mark_node;
+}
+
+/* Each of the functions defined here
+ is an alternative to a function in objc-actions.c. */
+
+/* Used by c-lex.c, but only for objc. */
+tree
+lookup_interface (arg)
+ tree arg;
+{
+ return 0;
+}
+
+int
+maybe_objc_comptypes (lhs, rhs)
+ tree lhs, rhs;
+{
+ return -1;
+}
+
+tree
+maybe_building_objc_message_expr ()
+{
+ return 0;
+}
+
+int
+recognize_objc_keyword ()
+{
+ return 0;
+}
+
+void
+lang_init_options ()
+{
+}
+
+/* used by print-tree.c */
+
+void
+lang_print_xnode (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+}
+
+void
+GNU_xref_begin ()
+{
+ fatal ("GCC does not yet support XREF");
+}
+
+void
+GNU_xref_end ()
+{
+ fatal ("GCC does not yet support XREF");
+}
+\f
+/*
+ * process chill-specific compiler command-line options
+ */
+int
+lang_decode_option (argc, argv)
+ int argc;
+ char **argv;
+{
+ char *p = argv[0];
+ static explicit_ignore_case = 0;
+ if (!strcmp(p, "-lang-chill"))
+ ; /* do nothing */
+ else if (!strcmp (p, "-fruntime-checking"))
+ {
+ range_checking = 1;
+ empty_checking = 1;
+ }
+ else if (!strcmp (p, "-fno-runtime-checking"))
+ {
+ range_checking = 0;
+ empty_checking = 0;
+ runtime_checking_flag = 0;
+ }
+ else if (!strcmp (p, "-flocal-loop-counter"))
+ flag_local_loop_counter = 1;
+ else if (!strcmp (p, "-fno-local-loop-counter"))
+ flag_local_loop_counter = 0;
+ else if (!strcmp (p, "-fold-strings"))
+ flag_old_strings = 1;
+ else if (!strcmp (p, "-fno-old-strings"))
+ flag_old_strings = 0;
+ else if (!strcmp (p, "-fignore-case"))
+ {
+ explicit_ignore_case = 1;
+ if (special_UC)
+ {
+ error ("Ignoring case upon input and");
+ error ("making special words uppercase wouldn't work.");
+ }
+ else
+ ignore_case = 1;
+ }
+ else if (!strcmp (p, "-fno-ignore-case"))
+ ignore_case = 0;
+ else if (!strcmp (p, "-fspecial_UC"))
+ {
+ if (explicit_ignore_case)
+ {
+ error ("Making special words uppercase and");
+ error (" ignoring case upon input wouldn't work.");
+ }
+ else
+ special_UC = 1, ignore_case = 0;
+ }
+ else if (!strcmp (p, "-fspecial_LC"))
+ special_UC = 0;
+ else if (!strcmp (p, "-fpack"))
+ maximum_field_alignment = BITS_PER_UNIT;
+ else if (!strcmp (p, "-fno-pack"))
+ maximum_field_alignment = 0;
+ else if (!strcmp (p, "-fchill-grant-only"))
+ grant_only_flag = 1;
+ else if (!strcmp (p, "-fgrant-only"))
+ grant_only_flag = 1;
+ /* user has specified a seize-file path */
+ else if (p[0] == '-' && p[1] == 'I')
+ register_seize_path (&p[2]);
+ if (!strcmp(p, "-itu")) /* Force Z.200 semantics */
+ {
+ pedantic = 1; /* FIXME: new flag name? */
+ flag_local_loop_counter = 1;
+ }
+ else
+ return c_decode_option (argc, argv);
+
+ return 1;
+}
+
+void
+chill_print_error_function (file)
+ char *file;
+{
+ static tree last_error_function = NULL_TREE;
+ static struct module *last_error_module = NULL;
+
+ if (last_error_function == current_function_decl
+ && last_error_module == current_module)
+ return;
+
+ last_error_function = current_function_decl;
+ last_error_module = current_module;
+
+ if (file)
+ fprintf (stderr, "%s: ", file);
+
+ if (current_function_decl == global_function_decl
+ || current_function_decl == NULL_TREE)
+ {
+ if (current_module == NULL)
+ fprintf (stderr, "At top level:\n");
+ else
+ fprintf (stderr, "In module %s:\n",
+ IDENTIFIER_POINTER (current_module->name));
+ }
+ else
+ {
+ char *kind = "function";
+ char *name = (*decl_printable_name) (current_function_decl, 2);
+ fprintf (stderr, "In %s `%s':\n", kind, name);
+ }
+}
+
+/* Print an error message for invalid use of an incomplete type.
+ VALUE is the expression that was used (or 0 if that isn't known)
+ and TYPE is the type that was invalid. */
+
+void
+incomplete_type_error (value, type)
+ tree value;
+ tree type;
+{
+ error ("internal error - use of undefined type");
+}
+
+void
+lang_init ()
+{
+ extern void (*print_error_function) PROTO((char*));
+
+ chill_real_input_filename = input_filename;
+
+ /* the beginning of the file is a new line; check for # */
+ /* With luck, we discover the real source file's name from that
+ and put it in input_filename. */
+
+ ungetc (check_newline (), finput);
+
+ /* set default grant file */
+ set_default_grant_file ();
+
+ print_error_function = chill_print_error_function;
+}
--- /dev/null
+/* Parser for GNU CHILL (CCITT High-Level Language) -*- C -*-
+ Copyright (C) 1992, 1993 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/*
+ * This is a two-pass parser. In pass 1, we collect declarations,
+ * ignoring actions and most expressions. We store only the
+ * declarations and close, open and re-lex the input file to save
+ * main memory. We anticipate that the compiler will be processing
+ * *very* large single programs which are mechanically generated,
+ * and so we want to store a minimum of information between passes.
+ *
+ * yylex detects the end of the main input file and returns the
+ * END_PASS_1 token. We then re-initialize each CHILL compiler
+ * module's global variables and re-process the input file. The
+ * grant file is output. If the user has requested it, GNU CHILL
+ * exits at this time - its only purpose was to generate the grant
+ * file. Optionally, the compiler may exit if errors were detected
+ * in pass 1.
+ *
+ * As each symbol scope is entered, we install its declarations into
+ * the symbol table. Undeclared types and variables are announced
+ * now.
+ *
+ * Then code is generated.
+ */
+
+#include <stdio.h>
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include "actions.h"
+#include "tasking.h"
+#include "parse.h"
+
+/* Since parsers are distinct for each language, put the
+ language string definition here. (fnf) */
+char *language_string = "GNU CHILL";
+
+/* Common code to be done before expanding any action. */
+#define INIT_ACTION { \
+ if (! ignoring) emit_line_note (input_filename, lineno); }
+
+/* Pop a scope for an ON handler. */
+#define POP_USED_ON_CONTEXT pop_handler(1)
+
+/* Pop a scope for an ON handler that wasn't there. */
+#define POP_UNUSED_ON_CONTEXT pop_handler(0)
+
+#define PUSH_ACTION push_action()
+
+/* Cause the `yydebug' variable to be defined. */
+#define YYDEBUG 1
+
+extern void assemble_external PROTO((tree));
+extern void chill_check_no_handlers PROTO((void));
+extern void chill_finish_on PROTO((void));
+extern void chill_handle_case_default PROTO((void));
+extern void chill_handle_on_labels PROTO((tree));
+extern tree chill_initializer_constant_valid_p PROTO((tree, tree));
+extern void chill_start_default_handler PROTO((void));
+extern void chill_start_on PROTO((void));
+extern struct rtx_def* emit_line_note PROTO((char *, int));
+extern struct rtx_def* gen_label_rtx PROTO((void));
+extern void emit_jump PROTO((struct rtx_def *));
+extern void emit_label PROTO((struct rtx_def *));
+extern void error PROTO((char *, ...));
+extern int expand_exit_labelled PROTO((tree));
+extern void lookup_and_expand_goto PROTO((tree));
+extern void lookup_and_handle_exit PROTO((tree));
+
+extern void push_granted PROTO((tree, tree));
+extern void sorry PROTO((char *, ...));
+extern void warning PROTO((char *, ...));
+
+extern int lineno;
+extern char *input_filename;
+extern tree generic_signal_type_node;
+extern tree signal_code;
+extern int all_static_flag;
+extern int ignore_case;
+
+static int quasi_signal = 0; /* 1 if processing a quasi signal decl */
+
+int parsing_newmode; /* 0 while parsing SYNMODE;
+ 1 while parsing NEWMODE. */
+int expand_exit_needed = 0;
+
+/* Gets incremented if we see errors such that we don't want to run pass 2. */
+
+int serious_errors = 0;
+
+static tree current_fieldlist;
+
+/* We don't care about expressions during pass 1, except while we're
+ parsing the RHS of a SYN definition, or while parsing a mode that
+ we need. NOTE: This also causes mode expressions to be ignored. */
+int ignoring = 1; /* 1 to ignore expressions */
+
+/* True if we have seen an action not in a (user) function. */
+int seen_action = 0;
+int build_constructor = 0;
+
+/* The action_nesting_level of the current procedure body. */
+int proc_action_level = 0;
+
+/* This is the identifier of the label that prefixes the current action,
+ or NULL if there was none. It is cleared at the end of an action,
+ or when starting a nested action list, so get it while you can! */
+static tree label = NULL_TREE; /* for statement labels */
+
+#if 0
+static tree current_block;
+#endif
+
+int in_pseudo_module = 0;
+int pass = 0; /* 0 for init_decl_processing,
+ 1 for pass 1, 2 for pass 2 */
+\f
+/* re-initialize global variables for pass 2 */
+static void
+ch_parse_init ()
+{
+ expand_exit_needed = 0;
+ label = NULL_TREE; /* for statement labels */
+ current_module = NULL;
+ in_pseudo_module = 0;
+}
+
+static void
+check_end_label (start, end)
+ tree start, end;
+{
+ if (end != NULL_TREE)
+ {
+ if (start == NULL_TREE && pass == 1)
+ error ("there was no start label to match the end label '%s'",
+ IDENTIFIER_POINTER(end));
+ else if (start != end && pass == 1)
+ error ("start label '%s' does not match end label '%s'",
+ IDENTIFIER_POINTER(start),
+ IDENTIFIER_POINTER(end));
+ }
+}
+
+
+/*
+ * given a tree which is an id, a type or a decl,
+ * return the associated type, or issue an error and
+ * return error_mark_node.
+ */
+tree
+get_type_of (id_or_decl)
+ tree id_or_decl;
+{
+ tree type = id_or_decl;
+
+ if (id_or_decl == NULL_TREE
+ || TREE_CODE (id_or_decl) == ERROR_MARK)
+ return error_mark_node;
+
+ if (pass == 1 || ignoring == 1)
+ return id_or_decl;
+
+ if (TREE_CODE (type) == IDENTIFIER_NODE)
+ {
+ type = lookup_name (id_or_decl);
+ if (type == NULL_TREE)
+ {
+ error ("`%s' not declared", IDENTIFIER_POINTER (id_or_decl));
+ type = error_mark_node;
+ }
+ }
+ if (TREE_CODE (type) == TYPE_DECL)
+ type = TREE_TYPE (type);
+ return type; /* was a type all along */
+}
+
+
+static void
+end_function ()
+{
+ if (CH_DECL_PROCESS (current_function_decl))
+ {
+ /* finishing a process */
+ if (! ignoring)
+ {
+ tree result =
+ build_chill_function_call
+ (lookup_name (get_identifier ("__stop_process")),
+ NULL_TREE);
+ expand_expr_stmt (result);
+ emit_line_note (input_filename, lineno);
+ }
+ }
+ else
+ {
+ /* finishing a procedure.. */
+ if (! ignoring)
+ {
+ if (result_never_set
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl)))
+ != VOID_TYPE)
+ warning ("No RETURN or RESULT in procedure");
+ chill_expand_return (NULL_TREE, 1);
+ }
+ }
+ finish_chill_function ();
+ pop_chill_function_context ();
+}
+
+static tree
+build_prefix_clause (id)
+ tree id;
+{
+ if (!id)
+ {
+ if (current_module && current_module->name)
+ { char *module_name = IDENTIFIER_POINTER (current_module->name);
+ if (module_name[0] && module_name[0] != '_')
+ return current_module->name;
+ }
+ error ("PREFIXED clause with no prelix in unlabeled module");
+ }
+ return id;
+}
+
+void
+possibly_define_exit_label (label)
+ tree label;
+{
+ if (label)
+ define_label (input_filename, lineno, munge_exit_label (label));
+}
+
+#define MAX_LOOK_AHEAD 2
+static enum terminal terminal_buffer[MAX_LOOK_AHEAD+1];
+YYSTYPE yylval;
+static YYSTYPE val_buffer[MAX_LOOK_AHEAD+1];
+
+/*enum terminal current_token, lookahead_token;*/
+
+#define TOKEN_NOT_READ dummy_last_terminal
+
+#ifdef __GNUC__
+__inline__
+#endif
+static int
+PEEK_TOKEN()
+{
+ if (terminal_buffer[0] == TOKEN_NOT_READ)
+ {
+ terminal_buffer[0] = yylex();
+ val_buffer[0] = yylval;
+ }
+ return terminal_buffer[0];
+}
+#define PEEK_TREE() val_buffer[0].ttype
+#define PEEK_TOKEN1() peek_token_(1)
+#define PEEK_TOKEN2() peek_token_(2)
+static int
+peek_token_ (i)
+ int i;
+{
+ if (i > MAX_LOOK_AHEAD)
+ fatal ("internal error - too much lookahead");
+ if (terminal_buffer[i] == TOKEN_NOT_READ)
+ {
+ terminal_buffer[i] = yylex();
+ val_buffer[i] = yylval;
+ }
+ return terminal_buffer[i];
+}
+
+static void
+pushback_token (code, node)
+ int code;
+ tree node;
+{
+ int i;
+ if (terminal_buffer[MAX_LOOK_AHEAD] != TOKEN_NOT_READ)
+ fatal ("internal error - cannot pushback token");
+ for (i = MAX_LOOK_AHEAD; i > 0; i--)
+ {
+ terminal_buffer[i] = terminal_buffer[i - 1];
+ val_buffer[i] = val_buffer[i - 1];
+ }
+ terminal_buffer[0] = code;
+ val_buffer[0].ttype = node;
+}
+
+static void
+forward_token_()
+{
+ int i;
+ for (i = 0; i < MAX_LOOK_AHEAD; i++)
+ {
+ terminal_buffer[i] = terminal_buffer[i+1];
+ val_buffer[i] = val_buffer[i+1];
+ }
+ terminal_buffer[MAX_LOOK_AHEAD] = TOKEN_NOT_READ;
+}
+#define FORWARD_TOKEN() forward_token_()
+
+/* Skip the next token.
+ if it isn't TOKEN, the parser is broken. */
+
+void
+require(token)
+ enum terminal token;
+{
+ if (PEEK_TOKEN() != token)
+ {
+ char buf[80];
+ sprintf (buf, "internal parser error - expected token %d", (int)token);
+ fatal(buf);
+ }
+ FORWARD_TOKEN();
+}
+
+int
+check_token (token)
+ enum terminal token;
+{
+ if (PEEK_TOKEN() != token)
+ return 0;
+ FORWARD_TOKEN ();
+ return 1;
+}
+
+/* return 0 if expected token was not found,
+ else return 1.
+*/
+int
+expect(token, message)
+ enum terminal token;
+ char *message;
+{
+ if (PEEK_TOKEN() != token)
+ {
+ if (pass == 1)
+ error(message ? message : "syntax error");
+ return 0;
+ }
+ else
+ FORWARD_TOKEN();
+ return 1;
+}
+
+/* define a SYNONYM __PROCNAME__ (__procname__) which holds
+ the name of the current procedure.
+ This should be quit the same as __FUNCTION__ in C */
+static void
+define__PROCNAME__ ()
+{
+ char *fname;
+ tree string;
+ tree procname;
+
+ if (current_function_decl == NULL_TREE)
+ fname = "toplevel";
+ else
+ fname = IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
+
+ string = build_chill_string (strlen (fname), fname);
+ procname = get_identifier (ignore_case ? "__procname__" : "__PROCNAME__");
+ push_syndecl (procname, NULL_TREE, string);
+}
+
+/* Forward declarations. */
+static tree parse_expression ();
+static tree parse_primval ();
+static tree parse_mode PROTO((void));
+static tree parse_opt_mode PROTO((void));
+static tree parse_untyped_expr ();
+static tree parse_opt_untyped_expr ();
+static int parse_definition PROTO((int));
+static void parse_opt_actions ();
+static void parse_body PROTO((void));
+static tree parse_if_expression_body PROTO((void));
+static tree parse_opt_handler PROTO((void));
+
+static tree
+parse_opt_name_string (allow_all)
+ int allow_all; /* 1 if ALL is allowed as a postfix */
+{
+ enum terminal token = PEEK_TOKEN();
+ tree name;
+ if (token != NAME)
+ {
+ if (token == ALL && allow_all)
+ {
+ FORWARD_TOKEN ();
+ return ALL_POSTFIX;
+ }
+ return NULL_TREE;
+ }
+ name = PEEK_TREE();
+ for (;;)
+ {
+ FORWARD_TOKEN ();
+ token = PEEK_TOKEN();
+ if (token != '!')
+ return name;
+ FORWARD_TOKEN();
+ token = PEEK_TOKEN();
+ if (token == ALL && allow_all)
+ return get_identifier3(IDENTIFIER_POINTER (name), "!", "*");
+ if (token != NAME)
+ {
+ if (pass == 1)
+ error ("'%s!' is not followed by an identifier",
+ IDENTIFIER_POINTER (name));
+ return name;
+ }
+ name = get_identifier3(IDENTIFIER_POINTER(name),
+ "!", IDENTIFIER_POINTER(PEEK_TREE()));
+ }
+}
+
+static tree
+parse_simple_name_string ()
+{
+ enum terminal token = PEEK_TOKEN();
+ tree name;
+ if (token != NAME)
+ {
+ error ("expected a name here");
+ return error_mark_node;
+ }
+ name = PEEK_TREE ();
+ FORWARD_TOKEN ();
+ return name;
+}
+
+static tree
+parse_name_string ()
+{
+ tree name = parse_opt_name_string (0);
+ if (name)
+ return name;
+ if (pass == 1)
+ error ("expected a name string here");
+ return error_mark_node;
+}
+
+static tree
+parse_defining_occurrence ()
+{
+ if (PEEK_TOKEN () == NAME)
+ {
+ tree id = PEEK_TREE();
+ FORWARD_TOKEN ();
+ return id;
+ }
+ return NULL;
+}
+
+/* Matches: <name_string>
+ Returns if pass 1: the identifier.
+ Returns if pass 2: a decl or value for identifier. */
+
+static tree
+parse_name ()
+{
+ tree name = parse_name_string ();
+ if (pass == 1 || ignoring)
+ return name;
+ else
+ {
+ tree decl = lookup_name (name);
+ if (decl == NULL_TREE)
+ {
+ error ("`%s' undeclared", IDENTIFIER_POINTER (name));
+ return error_mark_node;
+ }
+ else if (TREE_CODE (TREE_TYPE (decl)) == ERROR_MARK)
+ return error_mark_node;
+ else if (TREE_CODE (decl) == CONST_DECL)
+ return DECL_INITIAL (decl);
+ else if (TREE_CODE (TREE_TYPE (decl)) == REFERENCE_TYPE)
+ return convert_from_reference (decl);
+ else
+ return decl;
+ }
+}
+
+static tree
+parse_optlabel()
+{
+ tree label = parse_defining_occurrence();
+ if (label != NULL)
+ expect(COLON, "expected a ':' here");
+ return label;
+}
+
+static void
+parse_semi_colon ()
+{
+ enum terminal token = PEEK_TOKEN ();
+ if (token == SC)
+ FORWARD_TOKEN ();
+ else if (pass == 1)
+ (token == END ? pedwarn : error) ("expected ';' here");
+ label = NULL_TREE;
+}
+
+static void
+parse_opt_end_label_semi_colon (start_label)
+ tree start_label;
+{
+ if (PEEK_TOKEN() == NAME)
+ {
+ tree end_label = parse_name_string ();
+ check_end_label (start_label, end_label);
+ }
+ parse_semi_colon ();
+}
+
+extern tree set_module_name ();
+
+static void
+parse_modulion (label)
+ tree label;
+{
+ tree module_name;
+
+ label = set_module_name (label);
+ module_name = push_module (label, 0);
+ FORWARD_TOKEN();
+
+ push_action ();
+ parse_body();
+ expect(END, "expected END here");
+ parse_opt_handler ();
+ parse_opt_end_label_semi_colon (label);
+ find_granted_decls ();
+ pop_module ();
+}
+
+static void
+parse_spec_module (label)
+ tree label;
+{
+ tree module_name = push_module (set_module_name (label), 1);
+ int save_ignoring = ignoring;
+ ignoring = pass == 2;
+ FORWARD_TOKEN(); /* SKIP SPEC */
+ expect (MODULE, "expected 'MODULE' here");
+
+ while (parse_definition (1)) { }
+ if (parse_action ())
+ error ("action not allowed in SPEC MODULE");
+ expect(END, "expected END here");
+ parse_opt_end_label_semi_colon (label);
+ find_granted_decls ();
+ pop_module ();
+ ignoring = save_ignoring;
+}
+
+/* Matches: <name_string> ( "," <name_string> )*
+ Returns either a single IDENTIFIER_NODE,
+ or a chain (TREE_LIST) of IDENTIFIER_NODES.
+ (Since a single identifier is the common case, we avoid wasting space
+ (twice, once for each pass) with extra TREE_LIST nodes in that case.)
+ (Will not return NULL_TREE even if ignoring is true.) */
+
+static tree
+parse_defining_occurrence_list ()
+{
+ tree chain = NULL_TREE;
+ tree name = parse_defining_occurrence ();
+ if (name == NULL_TREE)
+ {
+ error("missing defining occurrence");
+ return NULL_TREE;
+ }
+ if (! check_token (COMMA))
+ return name;
+ chain = build_tree_list (NULL_TREE, name);
+ for (;;)
+ {
+ name = parse_defining_occurrence ();
+ if (name == NULL)
+ {
+ error ("bad defining occurrence following ','");
+ break;
+ }
+ chain = tree_cons (NULL_TREE, name, chain);
+ if (! check_token (COMMA))
+ break;
+ }
+ return nreverse (chain);
+}
+
+static void
+parse_mode_definition (is_newmode)
+ int is_newmode;
+{
+ tree mode, names;
+ int save_ignoring = ignoring;
+ ignoring = pass == 2;
+ names = parse_defining_occurrence_list ();
+ expect (EQL, "missing '=' in mode definition");
+ mode = parse_mode ();
+ if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
+ {
+ for ( ; names != NULL_TREE; names = TREE_CHAIN (names))
+ push_modedef (names, mode, is_newmode);
+ }
+ else
+ push_modedef (names, mode, is_newmode);
+ ignoring = save_ignoring;
+}
+
+void
+parse_mode_definition_statement (is_newmode)
+ int is_newmode;
+{
+ tree names;
+ FORWARD_TOKEN (); /* skip SYNMODE or NEWMODE */
+ parse_mode_definition (is_newmode);
+ while (PEEK_TOKEN () == COMMA)
+ {
+ FORWARD_TOKEN ();
+ parse_mode_definition (is_newmode);
+ }
+ parse_semi_colon ();
+}
+
+static void
+parse_synonym_definition ()
+{ tree expr = NULL_TREE;
+ tree names = parse_defining_occurrence_list ();
+ tree mode = parse_opt_mode ();
+ if (! expect (EQL, "missing '=' in synonym definition"))
+ mode = error_mark_node;
+ else
+ {
+ if (mode)
+ expr = parse_untyped_expr ();
+ else
+ expr = parse_expression ();
+ }
+ if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
+ {
+ for ( ; names != NULL_TREE; names = TREE_CHAIN (names))
+ push_syndecl (names, mode, expr);
+ }
+ else
+ push_syndecl (names, mode, expr);
+}
+
+static void
+parse_synonym_definition_statement()
+{
+ int save_ignoring= ignoring;
+ ignoring = pass == 2;
+ require (SYN);
+ parse_synonym_definition ();
+ while (PEEK_TOKEN () == COMMA)
+ {
+ FORWARD_TOKEN ();
+ parse_synonym_definition ();
+ }
+ ignoring = save_ignoring;
+ parse_semi_colon ();
+}
+
+/* Attempts to match: "(" <exception list> ")" ":".
+ Return NULL_TREE on failure, and non-NULL on success.
+ On success, if pass 1, return a TREE_LIST of IDENTIFIER_NODEs. */
+
+static tree
+parse_on_exception_list ()
+{
+ tree name;
+ tree list = NULL_TREE;
+ int tok1 = PEEK_TOKEN ();
+ int tok2 = PEEK_TOKEN1 ();
+
+ /* This requires a lot of look-ahead, because we cannot
+ easily a priori distinguish an exception-list from an expression. */
+ if (tok1 != LPRN || tok2 != NAME)
+ {
+ if (tok1 == NAME && tok2 == COLON && pass == 1)
+ error ("missing '(' in exception list");
+ return 0;
+ }
+ require (LPRN);
+ name = parse_name_string ();
+ if (PEEK_TOKEN () == RPRN && PEEK_TOKEN1 () == COLON)
+ {
+ /* Matched: '(' <name_string> ')' ':' */
+ FORWARD_TOKEN (); FORWARD_TOKEN ();
+ return pass == 1 ? build_tree_list (NULL_TREE, name) : name;
+ }
+ if (PEEK_TOKEN() == COMMA)
+ {
+ if (pass == 1)
+ list = build_tree_list (NULL_TREE, name);
+ while (check_token (COMMA))
+ {
+ tree old_names = list;
+ name = parse_name_string ();
+ if (pass == 1)
+ {
+ for ( ; old_names != NULL_TREE; old_names = TREE_CHAIN (old_names))
+ {
+ if (TREE_VALUE (old_names) == name)
+ {
+ error ("ON exception names must be unique");
+ goto continue_parsing;
+ }
+ }
+ list = tree_cons (NULL_TREE, name, list);
+ continue_parsing:
+ ;
+ }
+ }
+ if (! check_token (RPRN) || ! check_token(COLON))
+ error ("syntax error in exception list");
+ return pass == 1 ? nreverse (list) : name;
+ }
+ /* Matched: '(' name_string
+ but it doesn't match the syntax of an exception list.
+ It could be the beginning of an expression, so back up. */
+ pushback_token (NAME, name);
+ pushback_token (LPRN, 0);
+ return NULL_TREE;
+}
+
+static void
+parse_on_alternatives ()
+{
+ for (;;)
+ {
+ tree except_list = parse_on_exception_list ();
+ if (except_list != NULL)
+ chill_handle_on_labels (except_list);
+ else if (parse_action ())
+ expand_exit_needed = 1;
+ else
+ break;
+ }
+}
+
+static tree
+parse_opt_handler ()
+{
+ if (! check_token (ON))
+ {
+ POP_UNUSED_ON_CONTEXT;
+ return NULL_TREE;
+ }
+ if (check_token (END))
+ {
+ pedwarn ("empty ON-condition");
+ POP_UNUSED_ON_CONTEXT;
+ return NULL_TREE;
+ }
+ if (! ignoring)
+ {
+ chill_start_on ();
+ expand_exit_needed = 0;
+ }
+ if (PEEK_TOKEN () != ELSE)
+ {
+ parse_on_alternatives ();
+ if (! ignoring && expand_exit_needed)
+ expand_exit_something ();
+ }
+ if (check_token (ELSE))
+ {
+ chill_start_default_handler ();
+ label = NULL_TREE;
+ parse_opt_actions ();
+ if (! ignoring)
+ {
+ emit_line_note (input_filename, lineno);
+ expand_exit_something ();
+ }
+ }
+ expect (END, "missing 'END' after");
+ if (! ignoring)
+ chill_finish_on ();
+ POP_USED_ON_CONTEXT;
+ return integer_zero_node;
+}
+
+static void
+parse_loc_declaration (in_spec_module)
+ int in_spec_module;
+{
+ tree names = parse_defining_occurrence_list ();
+ int save_ignoring = ignoring;
+ int is_static, lifetime_bound;
+ tree mode, init_value = NULL_TREE;
+ int loc_decl = 0;
+
+ ignoring = pass == 2;
+ mode = parse_mode ();
+ ignoring = save_ignoring;
+ is_static = check_token (STATIC);
+ if (check_token (BASED))
+ {
+ expect(LPRN, "BASED must be followed by (NAME)");
+ do_based_decls (names, mode, parse_name_string ());
+ expect(RPRN, "BASED must be followed by (NAME)");
+ return;
+ }
+ if (check_token (LOC))
+ {
+ /* loc-identity declaration */
+ if (pass == 1)
+ mode = build_chill_reference_type (mode);
+ loc_decl = 1;
+ }
+ lifetime_bound = check_token (INIT);
+ if (lifetime_bound && loc_decl)
+ {
+ if (pass == 1)
+ error ("INIT not allowed at loc-identity declaration");
+ lifetime_bound = 0;
+ }
+ if (PEEK_TOKEN () == ASGN || PEEK_TOKEN() == EQL)
+ {
+ save_ignoring = ignoring;
+ ignoring = pass == 1;
+ if (PEEK_TOKEN() == EQL)
+ {
+ if (pass == 1)
+ error ("'=' used where ':=' is required");
+ }
+ FORWARD_TOKEN();
+ if (! lifetime_bound)
+ push_handler ();
+ init_value = parse_untyped_expr ();
+ if (in_spec_module)
+ {
+ error ("initialization is not allowed in spec module");
+ init_value = NULL_TREE;
+ }
+ if (! lifetime_bound)
+ parse_opt_handler ();
+ ignoring = save_ignoring;
+ }
+ if (init_value == NULL_TREE && loc_decl && pass == 1)
+ error ("loc-identity declaration without initialisation");
+ do_decls (names, mode,
+ is_static || global_bindings_p ()
+ /* the variable becomes STATIC if all_static_flag is set and
+ current functions doesn't have the RECURSIVE attribute */
+ || (all_static_flag && !CH_DECL_RECURSIVE (current_function_decl)),
+ lifetime_bound, init_value, in_spec_module);
+
+ /* Free any temporaries we made while initializing the decl. */
+ free_temp_slots ();
+}
+
+static void
+parse_declaration_statement (in_spec_module)
+ int in_spec_module;
+{
+ int save_ignoring = ignoring;
+ ignoring = pass == 2;
+ require (DCL);
+ parse_loc_declaration (in_spec_module);
+ while (PEEK_TOKEN () == COMMA)
+ {
+ FORWARD_TOKEN ();
+ parse_loc_declaration (in_spec_module);
+ }
+ ignoring = save_ignoring;
+ parse_semi_colon ();
+}
+
+tree
+parse_optforbid ()
+{
+ if (check_token (FORBID) == 0)
+ return NULL_TREE;
+ if (check_token (ALL))
+ return ignoring ? NULL_TREE : build_int_2 (-1, -1);
+#if 0
+ if (check_token (LPRN))
+ {
+ tree list = parse_forbidlist ();
+ expect (RPRN, "missing ')' after FORBID list");
+ return list;
+ }
+#endif
+ error ("bad syntax following FORBID");
+ return NULL_TREE;
+}
+
+/* Matches: <grant postfix> or <seize postfix>
+ Returns: A (singleton) TREE_LIST. */
+
+tree
+parse_postfix (grant_or_seize)
+ enum terminal grant_or_seize;
+{
+ tree name = parse_opt_name_string (1);
+ tree forbid = NULL_TREE;
+ if (name == NULL_TREE)
+ {
+ error ("expected a postfix name here");
+ name = error_mark_node;
+ }
+ if (grant_or_seize == GRANT)
+ forbid = parse_optforbid ();
+ return build_tree_list (forbid, name);
+}
+
+tree
+parse_postfix_list (grant_or_seize)
+ enum terminal grant_or_seize;
+{
+ tree list = parse_postfix (grant_or_seize);
+ while (check_token (COMMA))
+ list = chainon (list, parse_postfix (grant_or_seize));
+ return list;
+}
+
+void
+parse_rename_clauses (grant_or_seize)
+ enum terminal grant_or_seize;
+{
+ for (;;)
+ {
+ tree rename_old_prefix, rename_new_prefix, postfix;
+ require (LPRN);
+ rename_old_prefix = parse_opt_name_string (0);
+ expect (ARROW, "missing '->' in rename clause");
+ rename_new_prefix = parse_opt_name_string (0);
+ expect (RPRN, "missing ')' in rename clause");
+ expect ('!', "missing '!' in rename clause");
+ postfix = parse_postfix (grant_or_seize);
+
+ if (grant_or_seize == GRANT)
+ chill_grant (rename_old_prefix, rename_new_prefix,
+ TREE_VALUE (postfix), TREE_PURPOSE (postfix));
+ else
+ chill_seize (rename_old_prefix, rename_new_prefix,
+ TREE_VALUE (postfix));
+
+ if (PEEK_TOKEN () != COMMA)
+ break;
+ FORWARD_TOKEN ();
+ if (PEEK_TOKEN () != LPRN)
+ {
+ error ("expected another rename clause");
+ break;
+ }
+ }
+}
+
+static tree
+parse_opt_prefix_clause ()
+{
+ if (check_token (PREFIXED) == 0)
+ return NULL_TREE;
+ return build_prefix_clause (parse_opt_name_string (0));
+}
+
+void
+parse_grant_statement ()
+{
+ require (GRANT);
+ if (PEEK_TOKEN () == LPRN)
+ parse_rename_clauses (GRANT);
+ else
+ {
+ tree window = parse_postfix_list (GRANT);
+ tree new_prefix = parse_opt_prefix_clause ();
+ tree t;
+ for (t = window; t; t = TREE_CHAIN (t))
+ chill_grant (NULL_TREE, new_prefix, TREE_VALUE (t), TREE_PURPOSE (t));
+ }
+}
+
+void
+parse_seize_statement ()
+{
+ require (SEIZE);
+ if (PEEK_TOKEN () == LPRN)
+ parse_rename_clauses (SEIZE);
+ else
+ {
+ tree seize_window = parse_postfix_list (SEIZE);
+ tree old_prefix = parse_opt_prefix_clause ();
+ tree t;
+ for (t = seize_window; t; t = TREE_CHAIN (t))
+ chill_seize (old_prefix, NULL_TREE, TREE_VALUE (t));
+ }
+}
+
+/* In pass 1, this returns a TREE_LIST, one node for each parameter.
+ In pass 2, we get a list of PARM_DECLs chained together.
+ In either case, the list is in reverse order. */
+
+static tree
+parse_param_name_list ()
+{
+ tree list = NULL_TREE;
+ do
+ {
+ tree new_link;
+ tree name = parse_defining_occurrence ();
+ if (name == NULL_TREE)
+ {
+ error ("syntax error in parameter name list");
+ return list;
+ }
+ if (pass == 1)
+ new_link = build_tree_list (NULL_TREE, name);
+ /* else if (current_module->is_spec_module) ; nothing */
+ else /* pass == 2 */
+ {
+ new_link = make_node (PARM_DECL);
+ DECL_NAME (new_link) = name;
+ DECL_ASSEMBLER_NAME (new_link) = name;
+ }
+
+ TREE_CHAIN (new_link) = list;
+ list = new_link;
+ } while (check_token (COMMA));
+ return list;
+}
+
+static tree
+parse_param_attr ()
+{
+ tree attr;
+ switch (PEEK_TOKEN ())
+ {
+ case PARAMATTR: /* INOUT is returned here */
+ attr = PEEK_TREE ();
+ FORWARD_TOKEN ();
+ return attr;
+ case IN:
+ FORWARD_TOKEN ();
+ return ridpointers[(int) RID_IN];
+ case LOC:
+ FORWARD_TOKEN ();
+ return ridpointers[(int) RID_LOC];
+#if 0
+ case DYNAMIC:
+ FORWARD_TOKEN ();
+ return ridpointers[(int) RID_DYNAMIC];
+#endif
+ default:
+ return NULL_TREE;
+ }
+}
+
+/* We wrap CHILL array parameters in a STRUCT. The original parameter
+ name is unpacked from the struct at get_identifier time */
+
+/* In pass 1, returns list of types; in pass 2: chain of PARM_DECLs. */
+
+static tree
+parse_formpar (in_spec_module)
+ int in_spec_module;
+{
+ tree names = parse_param_name_list ();
+ tree mode = parse_mode ();
+ tree paramattr = parse_param_attr ();
+ return chill_munge_params (nreverse (names), mode, paramattr);
+}
+
+/*
+ * Note: build_process_header depends upon the *exact*
+ * representation of STRUCT fields and of formal parameter
+ * lists. If either is changed, build_process_header will
+ * also need change. Push_extern_process is affected as well.
+ */
+static tree
+parse_formparlist (in_spec_module)
+ int in_spec_module;
+{
+ tree list = NULL_TREE;
+ if (PEEK_TOKEN() == RPRN)
+ return NULL_TREE;
+ for (;;)
+ {
+ list = chainon (list, parse_formpar (in_spec_module));
+ if (! check_token (COMMA))
+ break;
+ }
+ return list;
+}
+
+static tree
+parse_opt_result_spec ()
+{
+ tree mode;
+ int is_nonref, is_loc, is_dynamic;
+ if (!check_token (RETURNS))
+ return void_type_node;
+ expect (LPRN, "expected '(' after RETURNS");
+ mode = parse_mode ();
+ is_nonref = check_token (NONREF);
+ is_loc = check_token (LOC);
+ is_dynamic = check_token (DYNAMIC);
+ if (is_nonref && !is_loc)
+ error ("NONREF specific without LOC in result attribute");
+ if (is_dynamic && !is_loc)
+ error ("DYNAMIC specific without LOC in result attribute");
+ mode = get_type_of (mode);
+ if (is_loc && ! ignoring)
+ mode = build_chill_reference_type (mode);
+ expect (RPRN, "expected ')' after RETURNS");
+ return mode;
+}
+
+static tree
+parse_opt_except ()
+{
+ tree list = NULL_TREE;
+ if (!check_token (EXCEPTIONS))
+ return NULL_TREE;
+ expect (LPRN, "expected '(' after EXCEPTIONS");
+ do
+ {
+ tree except_name = parse_name_string ();
+ tree name;
+ for (name = list; name != NULL_TREE; name = TREE_CHAIN (name))
+ if (TREE_VALUE (name) == except_name && pass == 1)
+ {
+ error ("exception names must be unique");
+ break;
+ }
+ if (name == NULL_TREE && !ignoring)
+ list = tree_cons (NULL_TREE, except_name, list);
+ } while (check_token (COMMA));
+ expect (RPRN, "expected ')' after EXCEPTIONS");
+ return list;
+}
+
+static tree
+parse_opt_recursive ()
+{
+ if (check_token (RECURSIVE))
+ return ridpointers[RID_RECURSIVE];
+ else
+ return NULL_TREE;
+}
+
+static tree
+parse_procedureattr ()
+{
+ tree generality;
+ tree optrecursive;
+ switch (PEEK_TOKEN ())
+ {
+ case GENERAL:
+ FORWARD_TOKEN ();
+ generality = ridpointers[RID_GENERAL];
+ break;
+ case SIMPLE:
+ FORWARD_TOKEN ();
+ generality = ridpointers[RID_SIMPLE];
+ break;
+ case INLINE:
+ FORWARD_TOKEN ();
+ generality = ridpointers[RID_INLINE];
+ break;
+ default:
+ generality = NULL_TREE;
+ }
+ optrecursive = parse_opt_recursive ();
+ if (pass != 1)
+ return NULL_TREE;
+ if (generality)
+ generality = build_tree_list (NULL_TREE, generality);
+ if (optrecursive)
+ generality = tree_cons (NULL_TREE, optrecursive, generality);
+ return generality;
+}
+
+/* Parse the body and last part of a procedure or process definition. */
+
+static void
+parse_proc_body (name, exceptions)
+ tree name;
+ tree exceptions;
+{
+ int save_proc_action_level = proc_action_level;
+ proc_action_level = action_nesting_level;
+ if (exceptions != NULL_TREE)
+ /* set up a handler for reraising exceptions */
+ push_handler ();
+ push_action ();
+ define__PROCNAME__ ();
+ parse_body ();
+ proc_action_level = save_proc_action_level;
+ expect (END, "'END' was expected here");
+ parse_opt_handler ();
+ if (exceptions != NULL_TREE)
+ chill_reraise_exceptions (exceptions);
+ parse_opt_end_label_semi_colon (name);
+ end_function ();
+}
+
+static void
+parse_procedure_definition (in_spec_module)
+ int in_spec_module;
+{
+ int save_ignoring = ignoring;
+ tree name = parse_defining_occurrence ();
+ tree params, result, exceptlist, attributes;
+ int save_chill_at_module_level = chill_at_module_level;
+ chill_at_module_level = 0;
+ if (!in_spec_module)
+ ignoring = pass == 2;
+ require (COLON); require (PROC);
+ expect (LPRN, "missing '(' after PROC");
+ params = parse_formparlist (in_spec_module);
+ expect (RPRN, "missing ')' in PROC");
+ result = parse_opt_result_spec ();
+ exceptlist = parse_opt_except ();
+ attributes = parse_procedureattr ();
+ ignoring = save_ignoring;
+ if (in_spec_module)
+ {
+ expect (END, "missing 'END'");
+ parse_opt_end_label_semi_colon (name);
+ push_extern_function (name, result, params, exceptlist, 0);
+ return;
+ }
+ push_chill_function_context ();
+ start_chill_function (name, result, params, exceptlist, attributes);
+ current_module->procedure_seen = 1;
+ parse_proc_body (name, TYPE_RAISES_EXCEPTIONS (TREE_TYPE (current_function_decl)));
+ chill_at_module_level = save_chill_at_module_level;
+}
+
+static tree
+parse_processpar ()
+{
+ tree names = parse_defining_occurrence_list ();
+ tree mode = parse_mode ();
+ tree paramattr = parse_param_attr ();
+ tree parms = NULL_TREE;
+ if (names && TREE_CODE (names) == IDENTIFIER_NODE)
+ names = build_tree_list (NULL_TREE, names);
+ return tree_cons (tree_cons (paramattr, mode, NULL_TREE), names, NULL_TREE);
+}
+
+static tree
+parse_processparlist ()
+{
+ tree list = NULL_TREE;
+ if (PEEK_TOKEN() == RPRN)
+ return NULL_TREE;
+ for (;;)
+ {
+ list = chainon (list, parse_processpar ());
+ if (! check_token (COMMA))
+ break;
+ }
+ return list;
+}
+
+static void
+parse_process_definition (in_spec_module)
+ int in_spec_module;
+{
+ int save_ignoring = ignoring;
+ tree name = parse_defining_occurrence ();
+ tree params;
+ tree tmp;
+ if (!in_spec_module)
+ ignoring = 0;
+ require (COLON); require (PROCESS);
+ expect (LPRN, "missing '(' after PROCESS");
+ params = parse_processparlist (in_spec_module);
+ expect (RPRN, "missing ')' in PROCESS");
+ ignoring = save_ignoring;
+ if (in_spec_module)
+ {
+ expect (END, "missing 'END'");
+ parse_opt_end_label_semi_colon (name);
+ push_extern_process (name, params, NULL_TREE, 0);
+ return;
+ }
+ tmp = build_process_header (name, params);
+ parse_proc_body (name, NULL_TREE);
+ build_process_wrapper (name, tmp);
+}
+
+static void
+parse_signal_definition ()
+{
+ tree signame = parse_defining_occurrence ();
+ tree modes = NULL_TREE;
+ tree dest = NULL_TREE;
+
+ if (check_token (EQL))
+ {
+ expect (LPRN, "missing '(' after 'SIGNAL <name> ='");
+ for (;;)
+ {
+ tree mode = parse_mode ();
+ modes = tree_cons (NULL_TREE, mode, modes);
+ if (! check_token (COMMA))
+ break;
+ }
+ expect (RPRN, "missing ')'");
+ modes = nreverse (modes);
+ }
+
+ if (check_token (TO))
+ {
+ tree decl;
+ int save_ignoring = ignoring;
+ ignoring = 0;
+ decl = parse_name ();
+ ignoring = save_ignoring;
+ if (pass > 1)
+ {
+ if (decl == NULL_TREE
+ || TREE_CODE (decl) == ERROR_MARK
+ || TREE_CODE (decl) != FUNCTION_DECL
+ || !CH_DECL_PROCESS (decl))
+ error ("must specify a PROCESS name");
+ else
+ dest = decl;
+ }
+ }
+
+ if (! global_bindings_p ())
+ error ("SIGNAL must be in global reach");
+ else
+ {
+ tree struc = build_signal_struct_type (signame, modes, dest);
+ tree decl =
+ generate_tasking_code_variable (signame,
+ &signal_code,
+ current_module->is_spec_module);
+ /* remember the code variable in the struct type */
+ DECL_TASKING_CODE_DECL (struc) = (struct lang_decl *)decl;
+ CH_DECL_SIGNAL (struc) = 1;
+ add_taskstuff_to_list (decl, "_TT_Signal",
+ current_module->is_spec_module ?
+ NULL_TREE : signal_code, struc, NULL_TREE);
+ }
+
+}
+
+static void
+parse_signal_definition_statement ()
+{
+ int save_ignoring = ignoring;
+ ignoring = pass == 2;
+ require (SIGNAL);
+ for (;;)
+ {
+ parse_signal_definition ();
+ if (! check_token (COMMA))
+ break;
+ if (PEEK_TOKEN () == SC)
+ {
+ error ("syntax error while parsing signal definition statement");
+ break;
+ }
+ }
+ parse_semi_colon ();
+ ignoring = save_ignoring;
+}
+
+static int
+parse_definition (in_spec_module)
+ int in_spec_module;
+{
+ switch (PEEK_TOKEN ())
+ {
+ case NAME:
+ if (PEEK_TOKEN1() == COLON)
+ if (PEEK_TOKEN2() == PROC)
+ {
+ parse_procedure_definition (in_spec_module);
+ return 1;
+ }
+ else if (PEEK_TOKEN2() == PROCESS)
+ {
+ parse_process_definition (in_spec_module);
+ return 1;
+ }
+ return 0;
+ case DCL:
+ parse_declaration_statement(in_spec_module);
+ break;
+ case GRANT:
+ parse_grant_statement ();
+ break;
+ case NEWMODE:
+ parse_mode_definition_statement(1);
+ break;
+ case SC:
+ label = NULL_TREE;
+ FORWARD_TOKEN();
+ return 1;
+ case SEIZE:
+ parse_seize_statement ();
+ break;
+ case SIGNAL:
+ parse_signal_definition_statement ();
+ break;
+ case SYN:
+ parse_synonym_definition_statement();
+ break;
+ case SYNMODE:
+ parse_mode_definition_statement(0);
+ break;
+ default:
+ return 0;
+ }
+ return 1;
+}
+
+static void
+parse_then_clause ()
+{
+ expect (THEN, "expected 'THEN' after 'IF'");
+ if (! ignoring)
+ emit_line_note (input_filename, lineno);
+ parse_opt_actions ();
+}
+
+static void
+parse_opt_else_clause ()
+{
+ while (check_token (ELSIF))
+ {
+ tree cond = parse_expression ();
+ if (! ignoring)
+ expand_start_elseif (truthvalue_conversion (cond));
+ parse_then_clause ();
+ }
+ if (check_token (ELSE))
+ {
+ if (! ignoring)
+ { emit_line_note (input_filename, lineno);
+ expand_start_else ();
+ }
+ parse_opt_actions ();
+ }
+}
+
+static tree parse_expr_list ()
+{
+ tree expr = parse_expression ();
+ tree list = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr);
+ while (check_token (COMMA))
+ {
+ expr = parse_expression ();
+ if (! ignoring)
+ list = tree_cons (NULL_TREE, expr, list);
+ }
+ return list;
+}
+
+static tree
+parse_range_list_clause ()
+{
+ tree name = parse_opt_name_string (0);
+ if (name == NULL_TREE)
+ return NULL_TREE;
+ while (check_token (COMMA))
+ {
+ name = parse_name_string (0);
+ }
+ if (check_token (SC))
+ {
+ sorry ("case range list");
+ return error_mark_node;
+ }
+ pushback_token (NAME, name);
+ return NULL_TREE;
+}
+
+static void
+pushback_paren_expr (expr)
+ tree expr;
+{
+ if (pass == 1 && !ignoring)
+ expr = build1 (PAREN_EXPR, NULL_TREE, expr);
+ pushback_token (EXPR, expr);
+}
+
+/* Matches: <case label> */
+
+static tree
+parse_case_label ()
+{
+ tree expr;
+ if (check_token (ELSE))
+ return case_else_node;
+ /* Does this also handle the case of a mode name? FIXME */
+ expr = parse_expression ();
+ if (check_token (COLON))
+ {
+ tree max_expr = parse_expression ();
+ if (! ignoring)
+ expr = build (RANGE_EXPR, NULL_TREE, expr, max_expr);
+ }
+ return expr;
+}
+
+/* Parses: <case_label_list>
+ Fails if not followed by COMMA or COLON.
+ If it fails, it backs up if needed, and returns NULL_TREE.
+ IN_TUPLE is true if we are parsing a tuple element,
+ and 0 if we are parsing a case label specification. */
+
+static tree
+parse_case_label_list (selector, in_tuple)
+ tree selector;
+ int in_tuple;
+{
+ tree expr, list;
+ if (! check_token (LPRN))
+ return NULL_TREE;
+ if (check_token (MUL))
+ {
+ expect (RPRN, "missing ')' after '*' case label list");
+ if (ignoring)
+ return integer_zero_node;
+ expr = build (RANGE_EXPR, NULL_TREE, NULL_TREE, NULL_TREE);
+ expr = build_tree_list (NULL_TREE, expr);
+ return expr;
+ }
+ expr = parse_case_label ();
+ if (check_token (RPRN))
+ {
+ if ((in_tuple || PEEK_TOKEN () != COMMA) && PEEK_TOKEN () != COLON)
+ {
+ /* Ooops! It looks like it was the start of an action or
+ unlabelled tuple element, and not a case label, so back up. */
+ if (expr != NULL_TREE && TREE_CODE (expr) == RANGE_EXPR)
+ {
+ error ("misplaced colon in case label");
+ expr = error_mark_node;
+ }
+ pushback_paren_expr (expr);
+ return NULL_TREE;
+ }
+ list = build_tree_list (NULL_TREE, expr);
+ if (expr == case_else_node && selector != NULL_TREE)
+ ELSE_LABEL_SPECIFIED (selector) = 1;
+ return list;
+ }
+ list = build_tree_list (NULL_TREE, expr);
+ if (expr == case_else_node && selector != NULL_TREE)
+ ELSE_LABEL_SPECIFIED (selector) = 1;
+
+ while (check_token (COMMA))
+ {
+ expr = parse_case_label ();
+ list = tree_cons (NULL_TREE, expr, list);
+ if (expr == case_else_node && selector != NULL_TREE)
+ ELSE_LABEL_SPECIFIED (selector) = 1;
+ }
+ expect (RPRN, "missing ')' at end of case label list");
+ return nreverse (list);
+}
+
+/* Parses: <case_label_specification>
+ Must be followed by a COLON.
+ If it fails, it backs up if needed, and returns NULL_TREE. */
+
+static tree
+parse_case_label_specification (selectors)
+ tree selectors;
+{
+ tree list_list = NULL_TREE;
+ tree list;
+ list = parse_case_label_list (selectors, 0);
+ if (list == NULL_TREE)
+ return NULL_TREE;
+ list_list = build_tree_list (NULL_TREE, list);
+ while (check_token (COMMA))
+ {
+ if (selectors != NULL_TREE)
+ selectors = TREE_CHAIN (selectors);
+ list = parse_case_label_list (selectors, 0);
+ if (list == NULL_TREE)
+ {
+ error ("unrecognized case label list after ','");
+ return list_list;
+ }
+ list_list = tree_cons (NULL_TREE, list, list_list);
+ }
+ return nreverse (list_list);
+}
+
+static void
+parse_single_dimension_case_action (selector)
+ tree selector;
+{
+ int no_completeness_check = 0;
+
+/* The case label/action toggle. It is 0 initially, and when an action
+ was last seen. It is 1 integer_zero_node when a label was last seen. */
+ int caseaction_flag = 0;
+
+ if (! ignoring)
+ {
+ expand_exit_needed = 0;
+ selector = check_case_selector (selector);
+ expand_start_case (1, selector, TREE_TYPE (selector), "CASE statement");
+ push_momentary ();
+ }
+
+ for (;;)
+ {
+ tree label_spec = parse_case_label_specification (selector);
+ if (label_spec != NULL_TREE)
+ {
+ expect (COLON, "missing ':' in case alternative");
+ if (! ignoring)
+ {
+ no_completeness_check |= chill_handle_single_dimension_case_label (
+ selector, label_spec, &expand_exit_needed, &caseaction_flag);
+ }
+ }
+ else if (parse_action ())
+ {
+ expand_exit_needed = 1;
+ caseaction_flag = 0;
+ }
+ else
+ break;
+ }
+
+ if (! ignoring)
+ {
+ if (expand_exit_needed || caseaction_flag == 1)
+ expand_exit_something ();
+ }
+ if (check_token (ELSE))
+ {
+ if (! ignoring)
+ chill_handle_case_default ();
+ parse_opt_actions ();
+ if (! ignoring)
+ {
+ emit_line_note (input_filename, lineno);
+ expand_exit_something ();
+ }
+ }
+ else if (! ignoring && TREE_CODE (selector) != ERROR_MARK &&
+ ! no_completeness_check)
+ check_missing_cases (TREE_TYPE (selector));
+
+ expect (ESAC, "missing 'ESAC' after 'CASE'");
+ if (! ignoring)
+ {
+ expand_end_case (selector);
+ pop_momentary ();
+ }
+}
+
+static void
+parse_multi_dimension_case_action (selector)
+ tree selector;
+{
+ struct rtx_def *begin_test_label, *end_case_label, *new_label;
+ tree action_labels = NULL_TREE;
+ tree tests = NULL_TREE;
+ tree new_test;
+ int save_lineno = lineno;
+ char *save_filename = input_filename;
+
+ /* We can't compute the range of an (ELSE) label until all of the CASE
+ label specifications have been seen, however, the code for the actions
+ between them is generated on the fly. We can still generate everything in
+ one pass is we use the following form:
+
+ Compile a CASE of the form
+
+ case S1,...,Sn of
+ (X11),...,(X1n): A1;
+ ...
+ (Xm1),...,(Xmn): Am;
+ else Ae;
+ esac;
+
+ into:
+
+ goto L0;
+ L1: A1; goto L99;
+ ...
+ Lm: Am; goto L99;
+ Le: Ae; goto L99;
+ L0:
+ T1 := s1; ...; Tn := Sn;
+ if (T1 = X11 and ... and Tn = X1n) GOTO L1;
+ ...
+ if (T1 = Xm1 and ... and Tn = Xmn) GOTO Lm;
+ GOTO Le;
+ L99;
+ */
+
+ if (! ignoring)
+ {
+ selector = check_case_selector_list (selector);
+ begin_test_label = gen_label_rtx ();
+ end_case_label = gen_label_rtx ();
+ emit_jump (begin_test_label);
+ }
+
+ for (;;)
+ {
+ tree label_spec = parse_case_label_specification (selector);
+ if (label_spec != NULL_TREE)
+ {
+ expect (COLON, "missing ':' in case alternative");
+ if (! ignoring)
+ {
+ tests = tree_cons (label_spec, NULL_TREE, tests);
+
+ if (action_labels != NULL_TREE)
+ emit_jump (end_case_label);
+
+ new_label = gen_label_rtx ();
+ emit_label (new_label);
+ emit_line_note (input_filename, lineno);
+ action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels);
+ TREE_CST_RTL (action_labels) = new_label;
+ }
+ }
+ else if (! parse_action ())
+ {
+ if (action_labels != NULL_TREE)
+ emit_jump (end_case_label);
+ break;
+ }
+ }
+
+ if (check_token (ELSE))
+ {
+ if (! ignoring)
+ {
+ new_label = gen_label_rtx ();
+ emit_label (new_label);
+ emit_line_note (input_filename, lineno);
+ action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels);
+ TREE_CST_RTL (action_labels) = new_label;
+ }
+ parse_opt_actions ();
+ if (! ignoring)
+ emit_jump (end_case_label);
+ }
+
+ expect (ESAC, "missing 'ESAC' after 'CASE'");
+
+ if (! ignoring)
+ {
+ emit_label (begin_test_label);
+ emit_line_note (save_filename, save_lineno);
+ if (tests != NULL_TREE)
+ {
+ tree cond;
+ tests = nreverse (tests);
+ action_labels = nreverse (action_labels);
+ compute_else_ranges (selector, tests);
+
+ cond = build_multi_case_selector_expression (selector, TREE_PURPOSE (tests));
+ expand_start_cond (truthvalue_conversion (cond), label ? 1 : 0);
+ emit_jump (TREE_CST_RTL (action_labels));
+
+ for (tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels);
+ tests != NULL_TREE && action_labels != NULL_TREE;
+ tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels))
+ {
+ cond =
+ build_multi_case_selector_expression (selector, TREE_PURPOSE (tests));
+ expand_start_elseif (truthvalue_conversion (cond));
+ emit_jump (TREE_CST_RTL (action_labels));
+ }
+ if (action_labels != NULL_TREE)
+ {
+ expand_start_else ();
+ emit_jump (TREE_CST_RTL (action_labels));
+ }
+ expand_end_cond ();
+ }
+ emit_label (end_case_label);
+ }
+}
+
+static void
+parse_case_action (label)
+ tree label;
+{
+ tree selector;
+ int multi_dimension_case = 0;
+
+/* The case label/action toggle. It is 0 initially, and when an action
+ was last seen. It is 1 integer_zero_node when a label was last seen. */
+ int caseaction_flag = 0;
+
+ require (CASE);
+ selector = parse_expr_list ();
+ selector = nreverse (selector);
+ expect (OF, "missing 'OF' after 'CASE'");
+ parse_range_list_clause ();
+
+ PUSH_ACTION;
+ if (label)
+ pushlevel (1);
+
+ if (! ignoring)
+ {
+ expand_exit_needed = 0;
+ if (TREE_CODE (selector) == TREE_LIST)
+ {
+ if (TREE_CHAIN (selector) != NULL_TREE)
+ multi_dimension_case = 1;
+ else
+ selector = TREE_VALUE (selector);
+ }
+ }
+
+ /* We want to use the regular CASE support for the single dimension case. The
+ multi dimension case requires different handling. Note that when "ignoring"
+ is true we parse using the single dimension code. This is OK since it will
+ still parse correctly. */
+ if (multi_dimension_case)
+ parse_multi_dimension_case_action (selector);
+ else
+ parse_single_dimension_case_action (selector);
+
+ if (label)
+ {
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+ }
+}
+
+/* Matches: [ <asm_operand> { "," <asm_operand> }* ],
+ where <asm_operand> = STRING '(' <expression> ')'
+ These are the operands other than the first string and colon
+ in asm ("addextend %2,%1": "=dm" (x), "0" (y), "g" (*x)) */
+
+static tree
+parse_asm_operands ()
+{
+ tree list = NULL_TREE;
+ if (PEEK_TOKEN () != STRING)
+ return NULL_TREE;
+ for (;;)
+ {
+ tree string, expr;
+ if (PEEK_TOKEN () != STRING)
+ {
+ error ("bad ASM operand");
+ return list;
+ }
+ string = PEEK_TREE();
+ FORWARD_TOKEN ();
+ expect (LPRN, "missing '(' in ASM operand");
+ expr = parse_expression ();
+ expect (RPRN, "missing ')' in ASM operand");
+ list = tree_cons (string, expr, list);
+ if (! check_token (COMMA))
+ break;
+ }
+ return nreverse (list);
+}
+
+/* Matches: STRING { ',' STRING }* */
+
+static tree
+parse_asm_clobbers ()
+{
+ tree list = NULL_TREE;
+ for (;;)
+ {
+ tree string, expr;
+ if (PEEK_TOKEN () != STRING)
+ {
+ error ("bad ASM operand");
+ return list;
+ }
+ string = PEEK_TREE();
+ FORWARD_TOKEN ();
+ list = tree_cons (NULL_TREE, string, list);
+ if (! check_token (COMMA))
+ break;
+ }
+ return list;
+}
+
+void
+ch_expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line)
+ tree string, outputs, inputs, clobbers;
+ int vol;
+ char *filename;
+ int line;
+{
+ int noutputs = list_length (outputs);
+ register int i;
+ /* o[I] is the place that output number I should be written. */
+ register tree *o = (tree *) alloca (noutputs * sizeof (tree));
+ register tree tail;
+
+ if (TREE_CODE (string) == ADDR_EXPR)
+ string = TREE_OPERAND (string, 0);
+ if (TREE_CODE (string) != STRING_CST)
+ {
+ error ("asm template is not a string constant");
+ return;
+ }
+
+ /* Record the contents of OUTPUTS before it is modified. */
+ for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++)
+ o[i] = TREE_VALUE (tail);
+
+#if 0
+ /* Perform default conversions on array and function inputs. */
+ /* Don't do this for other types--
+ it would screw up operands expected to be in memory. */
+ for (i = 0, tail = inputs; tail; tail = TREE_CHAIN (tail), i++)
+ if (TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == FUNCTION_TYPE)
+ TREE_VALUE (tail) = default_conversion (TREE_VALUE (tail));
+#endif
+
+ /* Generate the ASM_OPERANDS insn;
+ store into the TREE_VALUEs of OUTPUTS some trees for
+ where the values were actually stored. */
+ expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line);
+
+ /* Copy all the intermediate outputs into the specified outputs. */
+ for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++)
+ {
+ if (o[i] != TREE_VALUE (tail))
+ {
+ expand_expr (build_chill_modify_expr (o[i], TREE_VALUE (tail)),
+ 0, VOIDmode, 0);
+ free_temp_slots ();
+ }
+ /* Detect modification of read-only values.
+ (Otherwise done by build_modify_expr.) */
+ else
+ {
+ tree type = TREE_TYPE (o[i]);
+ if (TYPE_READONLY (type)
+ || ((TREE_CODE (type) == RECORD_TYPE
+ || TREE_CODE (type) == UNION_TYPE)
+ && TYPE_FIELDS_READONLY (type)))
+ warning ("readonly location modified by 'asm'");
+ }
+ }
+
+ /* Those MODIFY_EXPRs could do autoincrements. */
+ emit_queue ();
+}
+
+static void
+parse_asm_action ()
+{
+ tree insn;
+ require (ASM_KEYWORD);
+ expect (LPRN, "missing '('");
+ PUSH_ACTION;
+ if (!ignoring)
+ emit_line_note (input_filename, lineno);
+ insn = parse_expression ();
+ if (check_token (COLON))
+ {
+ tree output_operand, input_operand, clobbered_regs;
+ output_operand = parse_asm_operands ();
+ if (check_token (COLON))
+ input_operand = parse_asm_operands ();
+ else
+ input_operand = NULL_TREE;
+ if (check_token (COLON))
+ clobbered_regs = parse_asm_clobbers ();
+ else
+ clobbered_regs = NULL_TREE;
+ expect (RPRN, "missing ')'");
+ if (!ignoring)
+ ch_expand_asm_operands (insn, output_operand, input_operand,
+ clobbered_regs, FALSE,
+ input_filename, lineno);
+ }
+ else
+ {
+ expect (RPRN, "missing ')'");
+ STRIP_NOPS (insn);
+ if (ignoring) { }
+ else if ((TREE_CODE (insn) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (insn, 0)) == STRING_CST)
+ || TREE_CODE (insn) == STRING_CST)
+ expand_asm (insn);
+ else
+ error ("argument of `asm' is not a constant string");
+ }
+}
+
+static void
+parse_begin_end_block (label)
+ tree label;
+{
+ require (BEGINTOKEN);
+#if 0
+ /* don't make a linenote at BEGIN */
+ INIT_ACTION;
+#endif
+ pushlevel (1);
+ if (! ignoring)
+ {
+ clear_last_expr ();
+ push_momentary ();
+ expand_start_bindings (label ? 1 : 0);
+ }
+ push_handler ();
+ parse_body ();
+ expect (END, "missing 'END'");
+ /* Note that the opthandler comes before the poplevel
+ - hence a handler is in the scope of the block. */
+ parse_opt_handler ();
+ possibly_define_exit_label (label);
+ if (! ignoring)
+ {
+ emit_line_note (input_filename, lineno);
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ }
+ poplevel (kept_level_p (), 0, 0);
+ if (! ignoring)
+ pop_momentary ();
+ parse_opt_end_label_semi_colon (label);
+}
+
+static void
+parse_if_action (label)
+ tree label;
+{
+ tree cond;
+ require (IF);
+ PUSH_ACTION;
+ cond = parse_expression ();
+ if (label)
+ pushlevel (1);
+ if (! ignoring)
+ {
+ expand_start_cond (truthvalue_conversion (cond),
+ label ? 1 : 0);
+ }
+ parse_then_clause ();
+ parse_opt_else_clause ();
+ expect (FI, "expected 'FI' after 'IF'");
+ if (! ignoring)
+ {
+ emit_line_note (input_filename, lineno);
+ expand_end_cond ();
+ }
+ if (label)
+ {
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+ }
+}
+
+/* Matches: <iteration> (as in a <for control>). */
+
+static void
+parse_iteration ()
+{
+ tree loop_counter = parse_defining_occurrence ();
+ if (check_token (ASGN))
+ {
+ tree start_value = parse_expression ();
+ tree step_value
+ = check_token (BY) ? parse_expression () : NULL_TREE;
+ int going_down = check_token (DOWN);
+ tree end_value;
+ if (check_token (TO))
+ end_value = parse_expression ();
+ else
+ {
+ error ("expected 'TO' in step enumeration");
+ end_value = error_mark_node;
+ }
+ if (!ignoring)
+ build_loop_iterator (loop_counter, start_value, step_value,
+ end_value, going_down, 0, 0);
+ }
+ else
+ {
+ int going_down = check_token (DOWN);
+ tree expr;
+ if (check_token (IN))
+ expr = parse_expression ();
+ else
+ {
+ error ("expected 'IN' in FOR control here");
+ expr = error_mark_node;
+ }
+ if (!ignoring)
+ {
+ tree low_bound, high_bound;
+ if (expr && TREE_CODE (expr) == TYPE_DECL)
+ {
+ expr = TREE_TYPE (expr);
+ /* FIXME: expr must be an array or powerset */
+ low_bound = convert (expr, TYPE_MIN_VALUE (expr));
+ high_bound = convert (expr, TYPE_MAX_VALUE (expr));
+ }
+ else
+ {
+ low_bound = expr;
+ high_bound = NULL_TREE;
+ }
+ build_loop_iterator (loop_counter, low_bound,
+ NULL_TREE, high_bound,
+ going_down, 1, 0);
+ }
+ }
+}
+
+/* Matches: '(' <event list> ')' ':'.
+ Or; returns NULL_EXPR. */
+
+static tree
+parse_delay_case_event_list ()
+{
+ tree event_list = NULL_TREE;
+ tree event;
+ if (! check_token (LPRN))
+ return NULL_TREE;
+ event = parse_expression ();
+ if (PEEK_TOKEN () == ')' && PEEK_TOKEN1 () != ':')
+ {
+ /* Oops. */
+ require (RPRN);
+ pushback_paren_expr (event);
+ return NULL_TREE;
+ }
+ for (;;)
+ {
+ if (! ignoring)
+ event_list = tree_cons (NULL_TREE, event, event_list);
+ if (! check_token (COMMA))
+ break;
+ event = parse_expression ();
+ }
+ expect (RPRN, "missing ')'");
+ expect (COLON, "missing ':'");
+ return ignoring ? error_mark_node : event_list;
+}
+
+static void
+parse_delay_case_action (label)
+ tree label;
+{
+ tree label_cnt, set_location, priority;
+ tree combined_event_list = NULL_TREE;
+ require (DELAY);
+ require (CASE);
+ PUSH_ACTION;
+ pushlevel (1);
+ expand_exit_needed = 0;
+ if (check_token (SET))
+ {
+ set_location = parse_expression ();
+ parse_semi_colon ();
+ }
+ else
+ set_location = NULL_TREE;
+ if (check_token (PRIORITY))
+ {
+ priority = parse_expression ();
+ parse_semi_colon ();
+ }
+ else
+ priority = NULL_TREE;
+ if (! ignoring)
+ label_cnt = build_delay_case_start (set_location, priority);
+ for (;;)
+ {
+ tree event_list = parse_delay_case_event_list ();
+ if (event_list)
+ {
+ if (! ignoring )
+ {
+ int if_or_elseif = combined_event_list == NULL_TREE;
+ build_delay_case_label (event_list, if_or_elseif);
+ combined_event_list = chainon (combined_event_list, event_list);
+ }
+ }
+ else if (parse_action ())
+ {
+ if (! ignoring)
+ {
+ expand_exit_needed = 1;
+ if (combined_event_list == NULL_TREE)
+ error ("missing DELAY CASE alternative");
+ }
+ }
+ else
+ break;
+ }
+ expect (ESAC, "missing 'ESAC' in DELAY CASE'");
+ if (! ignoring)
+ build_delay_case_end (label_cnt, combined_event_list);
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+}
+
+static void
+parse_do_action (label)
+ tree label;
+{
+ tree condition;
+ int token;
+ require (DO);
+ if (check_token (WITH))
+ {
+ tree list = NULL_TREE;
+ for (;;)
+ {
+ tree name = parse_primval ();
+ if (! ignoring && TREE_CODE (name) != ERROR_MARK)
+ {
+ if (TREE_CODE (TREE_TYPE (name)) == REFERENCE_TYPE)
+ name = convert (TREE_TYPE (TREE_TYPE (name)), name);
+ else
+ {
+ int is_loc = chill_location (name);
+ if (is_loc == 1) /* This is probably not possible */
+ warning ("non-referable location in DO WITH");
+
+ if (is_loc > 1)
+ name = build_chill_arrow_expr (name, 1);
+ name = decl_temp1 (get_identifier ("__with_element"),
+ TREE_TYPE (name),
+ 0, name, 0, 0);
+ if (is_loc > 1)
+ name = build_chill_indirect_ref (name, NULL_TREE, 0);
+
+ }
+ if (TREE_CODE (TREE_TYPE (name)) != RECORD_TYPE)
+ error ("WITH element must be of STRUCT mode");
+ else
+ list = tree_cons (NULL_TREE, name, list);
+ }
+ if (! check_token (COMMA))
+ break;
+ }
+ pushlevel (1);
+ push_action ();
+ for (list = nreverse (list); list != NULL_TREE; list = TREE_CHAIN (list))
+ shadow_record_fields (TREE_VALUE (list));
+
+ parse_semi_colon ();
+ parse_opt_actions ();
+ expect (OD, "missing 'OD' in 'DO WITH'");
+ if (! ignoring)
+ emit_line_note (input_filename, lineno);
+ possibly_define_exit_label (label);
+ parse_opt_handler ();
+ parse_opt_end_label_semi_colon (label);
+ poplevel (0, 0, 0);
+ return;
+ }
+ token = PEEK_TOKEN();
+ if (token != FOR && token != WHILE)
+ {
+ push_handler ();
+ parse_opt_actions ();
+ expect (OD, "Missing 'OD' after 'DO'");
+ parse_opt_handler ();
+ parse_opt_end_label_semi_colon (label);
+ return;
+ }
+ if (! ignoring)
+ emit_line_note (input_filename, lineno);
+ push_loop_block ();
+ if (check_token (FOR))
+ {
+ if (check_token (EVER))
+ {
+ if (!ignoring)
+ build_loop_iterator (NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE,
+ 0, 0, 1);
+ }
+ else
+ {
+ parse_iteration ();
+ while (check_token (COMMA))
+ parse_iteration ();
+ }
+ }
+ else if (!ignoring)
+ build_loop_iterator (NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE,
+ 0, 0, 1);
+
+ begin_loop_scope ();
+ if (! ignoring)
+ build_loop_start (label);
+ condition = check_token (WHILE) ? parse_expression () : NULL_TREE;
+ if (! ignoring)
+ top_loop_end_check (condition);
+ parse_semi_colon ();
+ parse_opt_actions ();
+ if (! ignoring)
+ build_loop_end ();
+ expect (OD, "Missing 'OD' after 'DO'");
+ /* Note that the handler is inside the reach of the DO. */
+ parse_opt_handler ();
+ end_loop_scope (label);
+ pop_loop_block ();
+ parse_opt_end_label_semi_colon (label);
+}
+
+/* Matches: '(' <signal name> [ 'IN' <defining occurrence list> ']' ')' ':'
+ or: '(' <buffer location> IN (defining occurrence> ')' ':'
+ or: returns NULL_TREE. */
+
+static tree
+parse_receive_spec ()
+{
+ tree val;
+ tree name_list = NULL_TREE;
+ if (!check_token (LPRN))
+ return NULL_TREE;
+ val = parse_primval ();
+ if (check_token (IN))
+ {
+#if 0
+ if (flag_local_loop_counter)
+ name_list = parse_defining_occurrence_list ();
+ else
+#endif
+ {
+ for (;;)
+ {
+ tree loc = parse_primval ();
+ if (! ignoring)
+ name_list = tree_cons (NULL_TREE, loc, name_list);
+ if (! check_token (COMMA))
+ break;
+ }
+ }
+ }
+ if (! check_token (RPRN))
+ {
+ error ("missing ')' in signal/buffer receive alternative");
+ return NULL_TREE;
+ }
+ if (check_token (COLON))
+ {
+ if (ignoring || val == NULL_TREE || TREE_CODE (val) == ERROR_MARK)
+ return error_mark_node;
+ else
+ return build_receive_case_label (val, name_list);
+ }
+
+ /* We saw: '(' <primitive value> ')' not followed by ':'.
+ Presumably the start of an action. Backup and fail. */
+ if (name_list != NULL_TREE)
+ error ("misplaced 'IN' in signal/buffer receive alternative");
+ pushback_paren_expr (val);
+ return NULL_TREE;
+}
+
+/* To understand the code generation for this, see ch-tasking.c,
+ and the 2-page comments preceding the
+ build_chill_receive_case_start () definition. */
+
+static void
+parse_receive_case_action (label)
+ tree label;
+{
+ tree instance_location;
+ tree have_else_actions;
+ int spec_seen = 0;
+ tree alt_list = NULL_TREE;
+ require (RECEIVE);
+ require (CASE);
+ push_action ();
+ pushlevel (1);
+ if (! ignoring)
+ {
+ expand_exit_needed = 0;
+ }
+
+ if (check_token (SET))
+ {
+ instance_location = parse_expression ();
+ parse_semi_colon ();
+ }
+ else
+ instance_location = NULL_TREE;
+ if (! ignoring)
+ instance_location = build_receive_case_start (instance_location);
+
+ for (;;)
+ {
+ tree receive_spec = parse_receive_spec ();
+ if (receive_spec)
+ {
+ if (! ignoring)
+ alt_list = tree_cons (NULL_TREE, receive_spec, alt_list);
+ spec_seen++;
+ }
+ else if (parse_action ())
+ {
+ if (! spec_seen && pass == 1)
+ error ("missing RECEIVE alternative");
+ if (! ignoring)
+ expand_exit_needed = 1;
+ spec_seen = 1;
+ }
+ else
+ break;
+ }
+ if (check_token (ELSE))
+ {
+ if (! ignoring)
+ {
+ emit_line_note (input_filename, lineno);
+ if (build_receive_case_if_generated ())
+ expand_start_else ();
+ }
+ parse_opt_actions ();
+ have_else_actions = integer_one_node;
+ }
+ else
+ have_else_actions = integer_zero_node;
+ expect (ESAC, "missing 'ESAC' matching 'RECEIVE CASE'");
+ if (! ignoring)
+ {
+ build_receive_case_end (instance_location, nreverse (alt_list),
+ have_else_actions);
+ }
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+}
+
+static void
+parse_send_action ()
+{
+ tree signal = NULL_TREE;
+ tree buffer = NULL_TREE;
+ tree value_list;
+ tree with_expr, to_expr, priority;
+ require (SEND);
+ /* The tricky part is distinguishing between a SEND buffer action,
+ and a SEND signal action. */
+ if (pass != 2 || PEEK_TOKEN () != NAME)
+ {
+ /* If this is pass 2, it's a SEND buffer action.
+ If it's pass 1, we don't care. */
+ buffer = parse_primval ();
+ }
+ else
+ {
+ /* We have to specifically check for signalname followed by
+ a '(', since we allow a signalname to be used (syntactically)
+ as a "function". */
+ tree name = parse_name ();
+ if (TREE_CODE (name) == TYPE_DECL && CH_DECL_SIGNAL (name))
+ signal = name; /* It's a SEND signal action! */
+ else
+ {
+ /* It's not a legal SEND signal action.
+ Back up and try as a SEND buffer action. */
+ pushback_token (EXPR, name);
+ buffer = parse_primval ();
+ }
+ }
+ if (check_token (LPRN))
+ {
+ value_list = NULL_TREE;
+ for (;;)
+ {
+ tree expr = parse_untyped_expr ();
+ if (! ignoring)
+ value_list = tree_cons (NULL_TREE, expr, value_list);
+ if (! check_token (COMMA))
+ break;
+ }
+ value_list = nreverse (value_list);
+ expect (RPRN, "missing ')'");
+ }
+ else
+ value_list = NULL_TREE;
+ if (check_token (WITH))
+ with_expr = parse_expression ();
+ else
+ with_expr = NULL_TREE;
+ if (check_token (TO))
+ to_expr = parse_expression ();
+ else
+ to_expr = NULL_TREE;
+ if (check_token (PRIORITY))
+ priority = parse_expression ();
+ else
+ priority = NULL_TREE;
+ PUSH_ACTION;
+ if (ignoring)
+ return;
+
+ if (signal)
+ { /* It's a <send signal action>! */
+ tree sigdesc = build_signal_descriptor (signal, value_list);
+ if (sigdesc != NULL_TREE && TREE_CODE (sigdesc) != ERROR_MARK)
+ {
+ tree sendto = to_expr ? to_expr : IDENTIFIER_SIGNAL_DEST (signal);
+ expand_send_signal (sigdesc, with_expr,
+ sendto, priority, DECL_NAME (signal));
+ }
+ }
+ else
+ {
+ /* all checks are done in expand_send_buffer */
+ expand_send_buffer (buffer, value_list, priority, with_expr, to_expr);
+ }
+}
+
+static void
+parse_start_action ()
+{
+ tree name, copy_number, param_list, startset;
+ require (START);
+ name = parse_name_string ();
+ expect (LPRN, "missing '(' in START action");
+ PUSH_ACTION;
+ /* copy number is a required parameter */
+ copy_number = parse_expression ();
+ if (!ignoring
+ && (copy_number == NULL_TREE
+ || TREE_CODE (copy_number) == ERROR_MARK
+ || TREE_CODE (TREE_TYPE (copy_number)) != INTEGER_TYPE))
+ {
+ error ("PROCESS copy number must be integer");
+ copy_number = integer_zero_node;
+ }
+ if (check_token (COMMA))
+ param_list = parse_expr_list (); /* user parameters */
+ else
+ param_list = NULL_TREE;
+ expect (RPRN, "missing ')'");
+ startset = check_token (SET) ? parse_primval () : NULL;
+ build_start_process (name, copy_number, param_list, startset);
+}
+
+static void
+parse_opt_actions ()
+{
+ while (parse_action ()) ;
+}
+
+int
+parse_action ()
+{
+ tree label = NULL_TREE;
+ tree expr, rhs, loclist;
+ enum tree_code op;
+
+ if (current_function_decl == global_function_decl
+ && PEEK_TOKEN () != SC
+ && PEEK_TOKEN () != END)
+ seen_action = 1, build_constructor = 1;
+
+ if (PEEK_TOKEN () == NAME && PEEK_TOKEN1 () == COLON)
+ {
+ label = parse_defining_occurrence ();
+ require (COLON);
+ INIT_ACTION;
+ define_label (input_filename, lineno, label);
+ }
+
+ switch (PEEK_TOKEN ())
+ {
+ case AFTER:
+ {
+ int delay;
+ require (AFTER);
+ expr = parse_primval ();
+ delay = check_token (DELAY);
+ expect (IN, "missing 'IN'");
+ push_action ();
+ pushlevel (1);
+ build_after_start (expr, delay);
+ parse_opt_actions ();
+ expect (TIMEOUT, "missing 'TIMEOUT'");
+ build_after_timeout_start ();
+ parse_opt_actions ();
+ expect (END, "missing 'END'");
+ build_after_end ();
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+ }
+ goto bracketed_action;
+ case ASM_KEYWORD:
+ parse_asm_action ();
+ goto no_handler_action;
+ case ASSERT:
+ require (ASSERT);
+ PUSH_ACTION;
+ expr = parse_expression ();
+ if (! ignoring)
+ { tree assertfail = ridpointers[(int) RID_ASSERTFAIL];
+ expr = build (TRUTH_ORIF_EXPR, void_type_node, expr,
+ build_cause_exception (assertfail, 0));
+ expand_expr_stmt (fold (expr));
+ }
+ goto handler_action;
+ case AT:
+ require (AT);
+ PUSH_ACTION;
+ expr = parse_primval ();
+ expect (IN, "missing 'IN'");
+ pushlevel (1);
+ if (! ignoring)
+ build_at_action (expr);
+ parse_opt_actions ();
+ expect (TIMEOUT, "missing 'TIMEOUT'");
+ if (! ignoring)
+ expand_start_else ();
+ parse_opt_actions ();
+ expect (END, "missing 'END'");
+ if (! ignoring)
+ expand_end_cond ();
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+ goto bracketed_action;
+ case BEGINTOKEN:
+ parse_begin_end_block (label);
+ return 1;
+ case CASE:
+ parse_case_action (label);
+ goto bracketed_action;
+ case CAUSE:
+ require (CAUSE);
+ expr = parse_name_string ();
+ PUSH_ACTION;
+ if (! ignoring && TREE_CODE (expr) != ERROR_MARK)
+ expand_cause_exception (expr);
+ goto no_handler_action;
+ case CONTINUE:
+ require (CONTINUE);
+ expr = parse_expression ();
+ PUSH_ACTION;
+ if (! ignoring)
+ expand_continue_event (expr);
+ goto handler_action;
+ case CYCLE:
+ require (CYCLE);
+ PUSH_ACTION;
+ expr = parse_primval ();
+ expect (IN, "missing 'IN' after 'CYCLE'");
+ pushlevel (1);
+ /* We a tree list where TREE_VALUE is the label
+ and TREE_PURPOSE is the variable denotes the timeout id. */
+ expr = build_cycle_start (expr);
+ parse_opt_actions ();
+ expect (END, "missing 'END'");
+ if (! ignoring)
+ build_cycle_end (expr);
+ possibly_define_exit_label (label);
+ poplevel (0, 0, 0);
+ goto bracketed_action;
+ case DELAY:
+ if (PEEK_TOKEN1 () == CASE)
+ {
+ parse_delay_case_action (label);
+ goto bracketed_action;
+ }
+ require (DELAY);
+ PUSH_ACTION;
+ expr = parse_primval ();
+ rhs = check_token (PRIORITY) ? parse_expression () : NULL_TREE;
+ if (! ignoring)
+ build_delay_action (expr, rhs);
+ goto handler_action;
+ case DO:
+ parse_do_action (label);
+ return 1;
+ case EXIT:
+ require (EXIT);
+ expr = parse_name_string ();
+ PUSH_ACTION;
+ lookup_and_handle_exit (expr);
+ goto no_handler_action;
+ case GOTO:
+ require (GOTO);
+ expr = parse_name_string ();
+ PUSH_ACTION;
+ lookup_and_expand_goto (expr);
+ goto no_handler_action;
+ case IF:
+ parse_if_action (label);
+ goto bracketed_action;
+ case RECEIVE:
+ if (PEEK_TOKEN1 () != CASE)
+ return 0;
+ parse_receive_case_action (label);
+ goto bracketed_action;
+ case RESULT:
+ require (RESULT);
+ PUSH_ACTION;
+ expr = parse_untyped_expr ();
+ if (! ignoring)
+ chill_expand_result (expr, 1);
+ goto handler_action;
+ case RETURN:
+ require (RETURN);
+ PUSH_ACTION;
+ expr = parse_opt_untyped_expr ();
+ if (! ignoring)
+ {
+ /* Do this as RESULT expr and RETURN to get exceptions */
+ chill_expand_result (expr, 0);
+ expand_goto_except_cleanup (proc_action_level);
+ chill_expand_return (NULL_TREE, 0);
+ }
+ if (expr)
+ goto handler_action;
+ else
+ goto no_handler_action;
+ case SC:
+ require (SC);
+ return 1;
+ case SEND:
+ parse_send_action ();
+ goto handler_action;
+ case START:
+ parse_start_action ();
+ goto handler_action;
+ case STOP:
+ require (STOP);
+ PUSH_ACTION;
+ if (! ignoring)
+ { tree func = lookup_name (get_identifier ("__stop_process"));
+ tree result = build_chill_function_call (func, NULL_TREE);
+ expand_expr_stmt (result);
+ }
+ goto no_handler_action;
+ case CALL:
+ require (CALL);
+ /* Fall through to here ... */
+ case EXPR:
+ case LPRN:
+ case NAME:
+ /* This handles calls and assignments. */
+ PUSH_ACTION;
+ expr = parse_primval ();
+ switch (PEEK_TOKEN ())
+ {
+ case END:
+ parse_semi_colon (); /* Emits error message. */
+ case ON:
+ case SC:
+ if (!ignoring && TREE_CODE (expr) != ERROR_MARK)
+ {
+ if (TREE_CODE (expr) != CALL_EXPR
+ && TREE_TYPE (expr) != void_type_node
+ && ! TREE_SIDE_EFFECTS (expr))
+ {
+ if (TREE_CODE (expr) == FUNCTION_DECL)
+ error ("missing parenthesis for procedure call");
+ else
+ error ("expression is not an action");
+ expr = error_mark_node;
+ }
+ else
+ expand_expr_stmt (expr);
+ }
+ goto handler_action;
+ default:
+ loclist
+ = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr);
+ while (PEEK_TOKEN () == COMMA)
+ {
+ FORWARD_TOKEN ();
+ expr = parse_primval ();
+ if (!ignoring && TREE_CODE (expr) != ERROR_MARK)
+ loclist = tree_cons (NULL_TREE, expr, loclist);
+ }
+ }
+ switch (PEEK_TOKEN ())
+ {
+ case OR: op = BIT_IOR_EXPR; break;
+ case XOR: op = BIT_XOR_EXPR; break;
+ case ORIF: op = TRUTH_ORIF_EXPR; break;
+ case AND: op = BIT_AND_EXPR; break;
+ case ANDIF: op = TRUTH_ANDIF_EXPR; break;
+ case PLUS: op = PLUS_EXPR; break;
+ case SUB: op = MINUS_EXPR; break;
+ case CONCAT: op = CONCAT_EXPR; break;
+ case MUL: op = MULT_EXPR; break;
+ case DIV: op = TRUNC_DIV_EXPR; break;
+ case MOD: op = FLOOR_MOD_EXPR; break;
+ case REM: op = TRUNC_MOD_EXPR; break;
+
+ default:
+ error ("syntax error in action");
+ case SC: case ON:
+ case ASGN: op = NOP_EXPR; break;
+ ;
+ }
+
+ /* Looks like it was an assignment action. */
+ FORWARD_TOKEN ();
+ if (op != NOP_EXPR)
+ expect (ASGN, "expected ':=' here");
+ rhs = parse_untyped_expr ();
+ if (!ignoring)
+ expand_assignment_action (loclist, op, rhs);
+ goto handler_action;
+
+ default:
+ return 0;
+ }
+
+ bracketed_action:
+ /* We've parsed a bracketed action. */
+ parse_opt_handler ();
+ parse_opt_end_label_semi_colon (label);
+ return 1;
+
+ no_handler_action:
+ if (parse_opt_handler () != NULL_TREE && pass == 1)
+ error ("no handler is permitted on this action.");
+ parse_semi_colon ();
+ return 1;
+
+ handler_action:
+ parse_opt_handler ();
+ parse_semi_colon ();
+ return 1;
+}
+
+static void
+parse_body ()
+{
+ again:
+ while (parse_definition (0)) ;
+
+ while (parse_action ()) ;
+
+ if (parse_definition (0))
+ {
+ if (pass == 1)
+ pedwarn ("definition follows action");
+ goto again;
+ }
+}
+
+static tree
+parse_opt_untyped_expr ()
+{
+ switch (PEEK_TOKEN ())
+ {
+ case ON:
+ case END:
+ case SC:
+ case COMMA:
+ case COLON:
+ case RPRN:
+ return NULL_TREE;
+ default:
+ return parse_untyped_expr ();
+ }
+}
+
+static tree
+parse_call (function)
+ tree function;
+{
+ tree arg1, arg2, arg_list = NULL_TREE;
+ enum terminal tok;
+ require (LPRN);
+ arg1 = parse_opt_untyped_expr ();
+ if (arg1 != NULL_TREE)
+ {
+ tok = PEEK_TOKEN ();
+ if (tok == UP || tok == COLON)
+ {
+ FORWARD_TOKEN ();
+#if 0
+ /* check that arg1 isn't untyped (or mode);*/
+#endif
+ arg2 = parse_expression ();
+ expect (RPRN, "expected ')' to terminate slice");
+ if (ignoring)
+ return integer_zero_node;
+ else if (tok == UP)
+ return build_chill_slice_with_length (function, arg1, arg2);
+ else
+ return build_chill_slice_with_range (function, arg1, arg2);
+ }
+ if (!ignoring)
+ arg_list = build_tree_list (NULL_TREE, arg1);
+ while (check_token (COMMA))
+ {
+ arg2 = parse_untyped_expr ();
+ if (!ignoring)
+ arg_list = tree_cons (NULL_TREE, arg2, arg_list);
+ }
+ }
+
+ expect (RPRN, "expected ')' here");
+ return ignoring ? function
+ : build_generalized_call (function, nreverse (arg_list));
+}
+
+/* Matches: <field name list>
+ Returns: A list of IDENTIFIER_NODEs (or NULL_TREE if ignoring),
+ in reverse order. */
+
+static tree
+parse_tuple_fieldname_list ()
+{
+ tree list = NULL_TREE;
+ do
+ {
+ tree name;
+ if (!check_token (DOT))
+ {
+ error ("bad tuple field name list");
+ return NULL_TREE;
+ }
+ name = parse_simple_name_string ();
+ list = ignoring ? NULL_TREE : tree_cons (NULL_TREE, name, list);
+ } while (check_token (COMMA));
+ return list;
+}
+
+/* Returns one or nore TREE_LIST nodes, in reverse order. */
+
+static tree
+parse_tuple_element ()
+{
+ /* The tupleelement chain is built in reverse order,
+ and put in forward order when the list is used. */
+ tree value, list, label;
+ if (PEEK_TOKEN () == DOT)
+ {
+ /* Parse a labelled structure tuple. */
+ tree list = parse_tuple_fieldname_list (), field;
+ expect (COLON, "missing ':' in tuple");
+ value = parse_untyped_expr ();
+ if (ignoring)
+ return NULL_TREE;
+ /* FIXME: Should use save_expr(value), but that
+ confuses nested calls to digest_init! */
+ /* Re-use the list of field names as a list of name-value pairs. */
+ for (field = list; field != NULL_TREE; field = TREE_CHAIN (field))
+ { tree field_name = TREE_VALUE (field);
+ TREE_PURPOSE (field) = field_name;
+ TREE_VALUE (field) = value;
+ TUPLE_NAMED_FIELD (field) = 1;
+ }
+ return list;
+ }
+
+ label = parse_case_label_list (NULL_TREE, 1);
+ if (label)
+ {
+ expect (COLON, "missing ':' in tuple");
+ value = parse_untyped_expr ();
+ if (ignoring || label == NULL_TREE)
+ return NULL_TREE;
+ if (TREE_CODE (label) != TREE_LIST)
+ {
+ error ("invalid syntax for label in tuple");
+ return NULL_TREE;
+ }
+ else
+ {
+ /* FIXME: Should use save_expr(value), but that
+ confuses nested calls to digest_init! */
+ tree link = label;
+ for (; link != NULL_TREE; link = TREE_CHAIN (link))
+ { tree index = TREE_VALUE (link);
+ if (pass == 1 && TREE_CODE (index) != TREE_LIST)
+ index = build1 (PAREN_EXPR, NULL_TREE, index);
+ TREE_VALUE (link) = value;
+ TREE_PURPOSE (link) = index;
+ }
+ return nreverse (label);
+ }
+ }
+
+ value = parse_untyped_expr ();
+ if (check_token (COLON))
+ {
+ /* A powerset range [or possibly a labeled Array?] */
+ tree value2 = parse_untyped_expr ();
+ return ignoring ? NULL_TREE : build_tree_list (value, value2);
+ }
+ return ignoring ? NULL_TREE : build_tree_list (NULL_TREE, value);
+}
+
+/* Matches: a COMMA-separated list of tuple elements.
+ Returns a list (of TREE_LIST nodes). */
+static tree
+parse_opt_element_list ()
+{
+ tree list = NULL_TREE;
+ if (PEEK_TOKEN () == RPC)
+ return NULL_TREE;
+ for (;;)
+ {
+ tree element = parse_tuple_element ();
+ list = chainon (element, list); /* Built in reverse order */
+ if (PEEK_TOKEN () == RPC)
+ break;
+ if (!check_token (COMMA))
+ {
+ error ("bad syntax in tuple");
+ return NULL_TREE;
+ }
+ }
+ return nreverse (list);
+}
+
+/* Parses: '[' elements ']'
+ If modename is non-NULL it prefixed the tuple. */
+
+static tree
+parse_tuple (modename)
+ tree modename;
+{
+ tree list;
+ require (LPC);
+ list = parse_opt_element_list ();
+ expect (RPC, "missing ']' after tuple");
+ if (ignoring)
+ return integer_zero_node;
+ list = build_nt (CONSTRUCTOR, NULL_TREE, list);
+ if (modename == NULL_TREE)
+ return list;
+ else if (pass == 1)
+ TREE_TYPE (list) = modename;
+ else if (TREE_CODE (modename) != TYPE_DECL)
+ {
+ error ("non-mode name before tuple");
+ return error_mark_node;
+ }
+ else
+ list = chill_expand_tuple (TREE_TYPE (modename), list);
+ return list;
+}
+
+static tree
+parse_primval ()
+{
+ tree val;
+ switch (PEEK_TOKEN ())
+ {
+ case NUMBER:
+ case FLOATING:
+ case STRING:
+ case SINGLECHAR:
+ case BITSTRING:
+ case CONST:
+ case EXPR:
+ val = PEEK_TREE();
+ FORWARD_TOKEN ();
+ break;
+ case THIS:
+ val = build_chill_function_call (PEEK_TREE (), NULL_TREE);
+ FORWARD_TOKEN ();
+ break;
+ case LPRN:
+ FORWARD_TOKEN ();
+ val = parse_expression ();
+ expect (RPRN, "missing right parenthesis");
+ if (pass == 1 && ! ignoring)
+ val = build1 (PAREN_EXPR, NULL_TREE, val);
+ break;
+ case LPC:
+ val = parse_tuple (NULL_TREE);
+ break;
+ case NAME:
+ val = parse_name ();
+ if (PEEK_TOKEN() == LPC)
+ val = parse_tuple (val); /* Matched: <mode_name> <tuple> */
+ break;
+ default:
+ if (!ignoring)
+ error ("invalid expression/location syntax");
+ val = error_mark_node;
+ }
+ for (;;)
+ {
+ tree name, args;
+ switch (PEEK_TOKEN ())
+ {
+ case DOT:
+ FORWARD_TOKEN ();
+ name = parse_simple_name_string ();
+ val = ignoring ? val : build_chill_component_ref (val, name);
+ continue;
+ case ARROW:
+ FORWARD_TOKEN ();
+ name = parse_opt_name_string (0);
+ val = ignoring ? val : build_chill_indirect_ref (val, name, 1);
+ continue;
+ case LPRN:
+ /* The SEND buffer action syntax is ambiguous, at least when
+ parsed left-to-right. In the example 'SEND foo(v) ...' the
+ phrase 'foo(v)' could be a buffer location procedure call
+ (which then must be followed by the value to send).
+ On the other hand, if 'foo' is a buffer, stop parsing
+ after 'foo', and let parse_send_action pick up '(v) as
+ the value ot send.
+
+ We handle the ambiguity for SEND signal action differently,
+ since we allow (as an extension) a signal to be used as
+ a "function" (see build_generalized_call). */
+ if (TREE_TYPE (val) != NULL_TREE
+ && CH_IS_BUFFER_MODE (TREE_TYPE (val)))
+ return val;
+ val = parse_call (val);
+ continue;
+ case STRING:
+ case BITSTRING:
+ case SINGLECHAR:
+ case NAME:
+ /* Handle string repetition. (See comment in parse_operand5.) */
+ args = parse_primval ();
+ val = ignoring ? val : build_generalized_call (val, args);
+ continue;
+ }
+ break;
+ }
+ return val;
+}
+
+static tree
+parse_operand6 ()
+{
+ if (check_token (RECEIVE))
+ {
+ tree location = parse_primval ();
+ sorry ("RECEIVE expression");
+ return integer_one_node;
+ }
+ else if (check_token (ARROW))
+ {
+ tree location = parse_primval ();
+ return ignoring ? location : build_chill_arrow_expr (location, 0);
+ }
+ else
+ return parse_primval();
+}
+
+static tree
+parse_operand5()
+{
+ enum tree_code op;
+ /* We are supposed to be looking for a <string repetition operator>,
+ but in general we can't distinguish that from a parenthesized
+ expression. This is especially difficult if we allow the
+ string operand to be a constant expression (as requested by
+ some users), and not just a string literal.
+ Consider: LPRN expr RPRN LPRN expr RPRN
+ Is that a function call or string repetition?
+ Instead, we handle string repetition in parse_primval,
+ and build_generalized_call. */
+ tree rarg;
+ switch (PEEK_TOKEN())
+ {
+ case NOT: op = BIT_NOT_EXPR; break;
+ case SUB: op = NEGATE_EXPR; break;
+ default:
+ op = NOP_EXPR;
+ }
+ if (op != NOP_EXPR)
+ FORWARD_TOKEN();
+ rarg = parse_operand6();
+ return (op == NOP_EXPR || ignoring) ? rarg
+ : build_chill_unary_op (op, rarg);
+}
+
+static tree
+parse_operand4 ()
+{
+ tree larg = parse_operand5(), rarg;
+ enum tree_code op;
+ for (;;)
+ {
+ switch (PEEK_TOKEN())
+ {
+ case MUL: op = MULT_EXPR; break;
+ case DIV: op = TRUNC_DIV_EXPR; break;
+ case MOD: op = FLOOR_MOD_EXPR; break;
+ case REM: op = TRUNC_MOD_EXPR; break;
+ default:
+ return larg;
+ }
+ FORWARD_TOKEN();
+ rarg = parse_operand5();
+ if (!ignoring)
+ larg = build_chill_binary_op (op, larg, rarg);
+ }
+}
+
+static tree
+parse_operand3 ()
+{
+ tree larg = parse_operand4 (), rarg;
+ enum tree_code op;
+ for (;;)
+ {
+ switch (PEEK_TOKEN())
+ {
+ case PLUS: op = PLUS_EXPR; break;
+ case SUB: op = MINUS_EXPR; break;
+ case CONCAT: op = CONCAT_EXPR; break;
+ default:
+ return larg;
+ }
+ FORWARD_TOKEN();
+ rarg = parse_operand4();
+ if (!ignoring)
+ larg = build_chill_binary_op (op, larg, rarg);
+ }
+}
+
+static tree
+parse_operand2 ()
+{
+ tree larg = parse_operand3 (), rarg;
+ enum tree_code op;
+ for (;;)
+ {
+ if (check_token (IN))
+ {
+ rarg = parse_operand3();
+ if (! ignoring)
+ larg = build_chill_binary_op (SET_IN_EXPR, larg, rarg);
+ }
+ else
+ {
+ switch (PEEK_TOKEN())
+ {
+ case GT: op = GT_EXPR; break;
+ case GTE: op = GE_EXPR; break;
+ case LT: op = LT_EXPR; break;
+ case LTE: op = LE_EXPR; break;
+ case EQL: op = EQ_EXPR; break;
+ case NE: op = NE_EXPR; break;
+ default:
+ return larg;
+ }
+ FORWARD_TOKEN();
+ rarg = parse_operand3();
+ if (!ignoring)
+ larg = build_compare_expr (op, larg, rarg);
+ }
+ }
+}
+
+static tree
+parse_operand1 ()
+{
+ tree larg = parse_operand2 (), rarg;
+ enum tree_code op;
+ for (;;)
+ {
+ switch (PEEK_TOKEN())
+ {
+ case AND: op = BIT_AND_EXPR; break;
+ case ANDIF: op = TRUTH_ANDIF_EXPR; break;
+ default:
+ return larg;
+ }
+ FORWARD_TOKEN();
+ rarg = parse_operand2();
+ if (!ignoring)
+ larg = build_chill_binary_op (op, larg, rarg);
+ }
+}
+
+static tree
+parse_operand0 ()
+{
+ tree larg = parse_operand1(), rarg;
+ enum tree_code op;
+ for (;;)
+ {
+ switch (PEEK_TOKEN())
+ {
+ case OR: op = BIT_IOR_EXPR; break;
+ case XOR: op = BIT_XOR_EXPR; break;
+ case ORIF: op = TRUTH_ORIF_EXPR; break;
+ default:
+ return larg;
+ }
+ FORWARD_TOKEN();
+ rarg = parse_operand1();
+ if (!ignoring)
+ larg = build_chill_binary_op (op, larg, rarg);
+ }
+}
+
+static tree
+parse_expression ()
+{
+ return parse_operand0 ();
+}
+
+static tree
+parse_case_expression ()
+{
+ tree selector_list;
+ tree else_expr;
+ tree case_expr;
+ tree case_alt_list = NULL_TREE;
+
+ require (CASE);
+ selector_list = parse_expr_list ();
+ selector_list = nreverse (selector_list);
+
+ expect (OF, "missing 'OF'");
+ while (PEEK_TOKEN () == LPRN)
+ {
+ tree label_spec = parse_case_label_specification (selector_list);
+ tree sub_expr;
+ expect (COLON, "missing ':' in value case alternative");
+ sub_expr = parse_expression ();
+ expect (SC, "missing ';'");
+ if (! ignoring)
+ case_alt_list = tree_cons (label_spec, sub_expr, case_alt_list);
+ }
+ if (check_token (ELSE))
+ {
+ else_expr = parse_expression ();
+ if (check_token (SC) && pass == 1)
+ warning("there should not be a ';' here");
+ }
+ else
+ else_expr = NULL_TREE;
+ expect (ESAC, "missing 'ESAC' in 'CASE' expression");
+
+ if (ignoring)
+ return integer_zero_node;
+
+ /* If this is a multi dimension case, then transform it into an COND_EXPR
+ here. This must be done before store_expr is called since it has some
+ special handling for COND_EXPR expressions. */
+ if (TREE_CHAIN (selector_list) != NULL_TREE)
+ {
+ case_alt_list = nreverse (case_alt_list);
+ compute_else_ranges (selector_list, case_alt_list);
+ case_expr =
+ build_chill_multi_dimension_case_expr (selector_list, case_alt_list, else_expr);
+ }
+ else
+ case_expr = build_chill_case_expr (selector_list, case_alt_list, else_expr);
+
+ return case_expr;
+}
+
+static tree
+parse_then_alternative ()
+{
+ expect (THEN, "missing 'THEN' in 'IF' expression");
+ return parse_expression ();
+}
+
+static tree
+parse_else_alternative ()
+{
+ if (check_token (ELSIF))
+ return parse_if_expression_body ();
+ else if (check_token (ELSE))
+ return parse_expression ();
+ error ("missing ELSE/ELSIF in IF expression");
+ return error_mark_node;
+}
+
+/* Matches: <boolean expression> <then alternative> <else alternative> */
+
+static tree
+parse_if_expression_body ()
+{
+ tree bool_expr, then_expr, else_expr;
+ bool_expr = parse_expression ();
+ then_expr = parse_then_alternative ();
+ else_expr = parse_else_alternative ();
+ if (ignoring)
+ return integer_zero_node;
+ else
+ return build_nt (COND_EXPR, bool_expr, then_expr, else_expr);
+}
+
+static tree
+parse_if_expression ()
+{
+ tree expr;
+ require (IF);
+ expr = parse_if_expression_body ();
+ expect (FI, "missing 'FI' at end of conditional expression");
+ return expr;
+}
+
+/* An <untyped_expr> is a superset of <expr>. It also includes
+ <conditional expressions> and untyped <tuples>, whose types
+ are not given by their constituents. Hence, these are only
+ allowed in certain contexts that expect a certain type.
+ You should call convert() to fix up the <untyped_expr>. */
+
+static tree
+parse_untyped_expr ()
+{
+ tree val;
+ switch (PEEK_TOKEN())
+ {
+ case IF:
+ return parse_if_expression ();
+ case CASE:
+ return parse_case_expression ();
+ case LPRN:
+ switch (PEEK_TOKEN1())
+ {
+ case IF:
+ case CASE:
+ if (pass == 1)
+ pedwarn ("conditional expression not allowed inside parentheses");
+ goto skip_lprn;
+ case LPC:
+ if (pass == 1)
+ pedwarn ("mode-less tuple not allowed inside parentheses");
+ skip_lprn:
+ FORWARD_TOKEN ();
+ val = parse_untyped_expr ();
+ expect (RPRN, "missing ')'");
+ return val;
+ default: ;
+ /* fall through */
+ }
+ default:
+ return parse_operand0 ();
+ }
+}
+
+/* Matches: <index mode> */
+
+static tree
+parse_index_mode ()
+{
+ /* This is another one that is nasty to parse!
+ Let's feel our way ahead ... */
+ tree lower, upper;
+ if (PEEK_TOKEN () == NAME)
+ {
+ tree name = parse_name ();
+ switch (PEEK_TOKEN ())
+ {
+ case COMMA:
+ case RPRN:
+ case SC: /* An error */
+ /* This can only (legally) be a discrete mode name. */
+ return name;
+ case LPRN:
+ /* This could be named discrete range,
+ a cast, or some other expression (maybe). */
+ require (LPRN);
+ lower = parse_expression ();
+ if (check_token (COLON))
+ {
+ upper = parse_expression ();
+ expect (RPRN, "missing ')'");
+ /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */
+ if (ignoring)
+ return NULL_TREE;
+ else
+ return build_chill_range_type (name, lower, upper);
+ }
+ /* Looks like a cast or procedure call or something.
+ Backup, and try again. */
+ pushback_token (EXPR, lower);
+ pushback_token (LPRN, NULL_TREE);
+ lower = parse_call (name);
+ goto parse_literal_range_colon;
+ default:
+ /* This has to be the start of an expression. */
+ pushback_token (EXPR, name);
+ goto parse_literal_range;
+ }
+ }
+ /* It's not a name. But it could still be a discrete mode. */
+ lower = parse_opt_mode ();
+ if (lower)
+ return lower;
+ parse_literal_range:
+ /* Nope, it's a discrete literal range. */
+ lower = parse_expression ();
+ parse_literal_range_colon:
+ expect (COLON, "expected ':' here");
+
+ upper = parse_expression ();
+ return ignoring ? NULL_TREE
+ : build_chill_range_type (NULL_TREE, lower, upper);
+}
+
+static tree
+parse_set_mode ()
+{
+ int set_name_cnt = 0; /* count of named set elements */
+ int set_is_numbered = 0; /* TRUE if set elements have explicit values */
+ int set_is_not_numbered = 0;
+ tree list = NULL_TREE;
+ tree mode = ignoring ? void_type_node : start_enum (NULL_TREE);
+ require (SET);
+ expect (LPRN, "missing left parenthesis after SET");
+ for (;;)
+ {
+ tree name, value = NULL_TREE;
+ if (check_token (MUL))
+ name = NULL_TREE;
+ else
+ {
+ name = parse_defining_occurrence ();
+ if (check_token (EQL))
+ {
+ value = parse_expression ();
+ set_is_numbered = 1;
+ }
+ else
+ set_is_not_numbered = 1;
+ set_name_cnt++;
+ }
+ name = build_enumerator (name, value);
+ if (pass == 1)
+ list = chainon (name, list);
+ if (! check_token (COMMA))
+ break;
+ }
+ expect (RPRN, "missing right parenthesis after SET");
+ if (!ignoring)
+ {
+ if (set_is_numbered && set_is_not_numbered)
+ /* Z.200 doesn't allow mixed numbered and unnumbered set elements,
+ but we can do it. Print a warning */
+ pedwarn ("mixed numbered and unnumbered set elements is not standard");
+ mode = finish_enum (mode, list);
+ if (set_name_cnt == 0)
+ error ("SET mode must define at least one named value");
+ CH_ENUM_IS_NUMBERED(mode) = set_is_numbered ? 1 : 0;
+ }
+ return mode;
+}
+
+/* parse layout POS:
+ returns a tree with following layout
+
+ treelist
+ pupose=treelist value=NULL_TREE (to indicate POS)
+ pupose=word value=treelist | NULL_TREE
+ pupose=startbit value=treelist | NULL_TREE
+ purpose= value=
+ integer_zero | integer_one length | endbit
+*/
+static tree
+parse_pos ()
+{
+ tree word;
+ tree startbit = NULL_TREE, endbit = NULL_TREE;
+ tree what = NULL_TREE;
+
+ require (LPRN);
+ word = parse_untyped_expr ();
+ if (check_token (COMMA))
+ {
+ startbit = parse_untyped_expr ();
+ if (check_token (COMMA))
+ {
+ what = integer_zero_node;
+ endbit = parse_untyped_expr ();
+ }
+ else if (check_token (COLON))
+ {
+ what = integer_one_node;
+ endbit = parse_untyped_expr ();
+ }
+ }
+ require (RPRN);
+
+ /* build the tree as described above */
+ if (what != NULL_TREE)
+ what = tree_cons (what, endbit, NULL_TREE);
+ if (startbit != NULL_TREE)
+ startbit = tree_cons (startbit, what, NULL_TREE);
+ endbit = tree_cons (word, startbit, NULL_TREE);
+ return tree_cons (endbit, NULL_TREE, NULL_TREE);
+}
+
+/* parse layout STEP
+ returns a tree with the following layout
+
+ treelist
+ pupose=NULL_TREE value=treelist (to indicate STEP)
+ pupose=POS(see baove) value=stepsize | NULL_TREE
+*/
+static tree
+parse_step ()
+{
+ tree pos;
+ tree stepsize = NULL_TREE;
+
+ require (LPRN);
+ require (POS);
+ pos = parse_pos ();
+ if (check_token (COMMA))
+ stepsize = parse_untyped_expr ();
+ require (RPRN);
+ TREE_VALUE (pos) = stepsize;
+ return tree_cons (NULL_TREE, pos, NULL_TREE);
+}
+
+/* returns layout for fields or array elements.
+ NULL_TREE no layout specified
+ integer_one_node PACK specified
+ integer_zero_node NOPACK specified
+ tree_list PURPOSE POS
+ tree_list VALUE STEP
+*/
+static tree
+parse_opt_layout (in)
+ int in; /* 0 ... parse structure, 1 ... parse array */
+{
+ tree val = NULL_TREE;
+
+ if (check_token (PACK))
+ {
+ return integer_one_node;
+ }
+ else if (check_token (NOPACK))
+ {
+ return integer_zero_node;
+ }
+ else if (check_token (POS))
+ {
+ val = parse_pos ();
+ if (in == 1 && pass == 1)
+ {
+ error ("POS not allowed for ARRAY");
+ val = NULL_TREE;
+ }
+ return val;
+ }
+ else if (check_token (STEP))
+ {
+ val = parse_step ();
+ if (in == 0 && pass == 1)
+ {
+ error ("STEP not allowed in field definition");
+ val = NULL_TREE;
+ }
+ return val;
+ }
+ else
+ return NULL_TREE;
+}
+
+static tree
+parse_field_name_list ()
+{
+ tree chain = NULL_TREE;
+ tree name = parse_defining_occurrence ();
+ if (name == NULL_TREE)
+ {
+ error("missing field name");
+ return NULL_TREE;
+ }
+ chain = build_tree_list (NULL_TREE, name);
+ while (check_token (COMMA))
+ {
+ name = parse_defining_occurrence ();
+ if (name == NULL)
+ {
+ error ("bad field name following ','");
+ break;
+ }
+ if (! ignoring)
+ chain = tree_cons (NULL_TREE, name, chain);
+ }
+ return chain;
+}
+
+/* Matches: <fixed field> or <variant field>, i.e.:
+ <field name defining occurrence list> <mode> [ <field layout> ].
+ Returns: A chain of FIELD_DECLs.
+ NULL_TREE is returned if ignoring is true or an error is seen. */
+
+static tree
+parse_fixed_field ()
+{
+ tree field_names = parse_field_name_list ();
+ tree mode = parse_mode ();
+ tree layout = parse_opt_layout (0);
+ return ignoring ? NULL_TREE
+ : grok_chill_fixedfields (field_names, mode, layout);
+}
+
+
+/* Matches: [ <variant field> { "," <variant field> }* ]
+ Returns: A chain of FIELD_DECLs.
+ NULL_TREE is returned if ignoring is true or an error is seen. */
+
+static tree
+parse_variant_field_list ()
+{
+ tree fields = NULL_TREE;
+ if (PEEK_TOKEN () != NAME)
+ return NULL_TREE;
+ for (;;)
+ {
+ fields = chainon (fields, parse_fixed_field ());
+ if (PEEK_TOKEN () != COMMA || PEEK_TOKEN1 () != NAME)
+ break;
+ require (COMMA);
+ }
+ return fields;
+}
+
+/* Matches: <variant alternative>
+ Returns a TREE_LIST node, whose TREE_PURPOSE (if non-NULL) is the label,
+ and whose TREE_VALUE is the list of FIELD_DECLs. */
+
+static tree
+parse_variant_alternative ()
+{
+ tree labels, x;
+ tree variant_fields = NULL_TREE;
+ if (PEEK_TOKEN () == LPRN)
+ labels = parse_case_label_specification (NULL_TREE);
+ else
+ labels = NULL_TREE;
+ if (! check_token (COLON))
+ {
+ error ("expected ':' in structure variant alternative");
+ return NULL_TREE;
+ }
+
+ /* We now read a list a variant fields, until we come to the end
+ of the variant alternative. But since both variant fields
+ *and* variant alternatives are separated by COMMAs,
+ we will have to look ahead to distinguish the start of a variant
+ field from the start of a new variant alternative.
+ We use the fact that a variant alternative must start with
+ either a LPRN or a COLON, while a variant field must start with a NAME.
+ This look-ahead is handled by parse_simple_fields. */
+ return build_tree_list (labels, parse_variant_field_list ());
+}
+
+/* Parse <field> (which is <fixed field> or <alternative field>).
+ Returns: A chain of FIELD_DECLs (or NULL_TREE on error or if ignoring). */
+
+static tree
+parse_field ()
+{
+ if (check_token (CASE))
+ {
+ tree tag_list = NULL_TREE, variants, opt_variant_else;
+ if (PEEK_TOKEN () == NAME)
+ {
+ tag_list = nreverse (parse_field_name_list ());
+ if (pass == 1)
+ tag_list = lookup_tag_fields (tag_list, current_fieldlist);
+ }
+ expect (OF, "missing 'OF' in alternative structure field");
+
+ variants = parse_variant_alternative ();
+ while (check_token (COMMA))
+ variants = chainon (parse_variant_alternative (), variants);
+ variants = nreverse (variants);
+
+ if (check_token (ELSE))
+ opt_variant_else = parse_variant_field_list ();
+ else
+ opt_variant_else = NULL_TREE;
+ expect (ESAC, "missing 'ESAC' following alternative structure field");
+ if (ignoring)
+ return NULL_TREE;
+ return grok_chill_variantdefs (tag_list, variants, opt_variant_else);
+ }
+ else if (PEEK_TOKEN () == NAME)
+ return parse_fixed_field ();
+ else
+ {
+ if (pass == 1)
+ error ("missing field");
+ return NULL_TREE;
+ }
+}
+
+static tree
+parse_structure_mode ()
+{
+ tree save_fieldlist = current_fieldlist;
+ tree fields;
+ require (STRUCT);
+ expect (LPRN, "expected '(' after STRUCT");
+ current_fieldlist = fields = parse_field ();
+ while (check_token (COMMA))
+ fields = chainon (fields, parse_field ());
+ expect (RPRN, "expected ')' after STRUCT");
+ current_fieldlist = save_fieldlist;
+ return ignoring ? void_type_node : build_chill_struct_type (fields);
+}
+
+static tree
+parse_opt_queue_size ()
+{
+ if (check_token (LPRN))
+ {
+ tree size = parse_expression ();
+ expect (RPRN, "missing ')'");
+ return size;
+ }
+ else
+ return NULL_TREE;
+}
+
+static tree
+parse_procedure_mode ()
+{
+ tree param_types = NULL_TREE, result_spec, except_list, recursive;
+ require (PROC);
+ expect (LPRN, "missing '(' after PROC");
+ if (! check_token (RPRN))
+ {
+ for (;;)
+ {
+ tree pmode = parse_mode ();
+ tree paramattr = parse_param_attr ();
+ if (! ignoring)
+ {
+ pmode = get_type_of (pmode);
+ param_types = tree_cons (paramattr, pmode, param_types);
+ }
+ if (! check_token (COMMA))
+ break;
+ }
+ expect (RPRN, "missing ')' after PROC");
+ }
+ result_spec = parse_opt_result_spec ();
+ except_list = parse_opt_except ();
+ recursive = parse_opt_recursive ();
+ if (ignoring)
+ return void_type_node;
+ return build_chill_pointer_type (build_chill_function_type
+ (result_spec, nreverse (param_types),
+ except_list, recursive));
+}
+
+/* Matches: <mode>
+ A NAME will be assumed to be a <mode name>, and thus a <mode>.
+ Returns NULL_TREE if no mode is seen.
+ (If ignoring is true, the return value may be an arbitrary tree node,
+ but will be non-NULL if something that could be a mode is seen.) */
+
+static tree
+parse_opt_mode ()
+{
+ switch (PEEK_TOKEN ())
+ {
+ case ACCESS:
+ {
+ tree index_mode, record_mode;
+ int dynamic = 0;
+ require (ACCESS);
+ if (check_token (LPRN))
+ {
+ index_mode = parse_index_mode ();
+ expect (RPRN, "mssing ')'");
+ }
+ else
+ index_mode = NULL_TREE;
+ record_mode = parse_opt_mode ();
+ if (record_mode)
+ dynamic = check_token (DYNAMIC);
+ return ignoring ? void_type_node
+ : build_access_mode (index_mode, record_mode, dynamic);
+ }
+ case ARRAY:
+ {
+ tree index_list = NULL_TREE, base_mode;
+ int varying;
+ int num_index_modes = 0;
+ int i;
+ tree layouts = NULL_TREE;
+ FORWARD_TOKEN ();
+ expect (LPRN, "missing '(' after ARRAY");
+ for (;;)
+ {
+ tree index = parse_index_mode ();
+ num_index_modes++;
+ if (!ignoring)
+ index_list = tree_cons (NULL_TREE, index, index_list);
+ if (! check_token (COMMA))
+ break;
+ }
+ expect (RPRN, "missing ')' after ARRAY");
+ varying = check_token (VARYING);
+ base_mode = parse_mode ();
+ /* Allow a layout specification for each index mode */
+ for (i = 0; i < num_index_modes; ++i)
+ {
+ tree new_layout = parse_opt_layout (1);
+ if (new_layout == NULL_TREE)
+ break;
+ if (!ignoring)
+ layouts = tree_cons (NULL_TREE, new_layout, layouts);
+ }
+ if (ignoring)
+ return base_mode;
+ return build_chill_array_type (get_type_of (base_mode),
+ index_list, varying, layouts);
+ }
+ case ASSOCIATION:
+ require (ASSOCIATION);
+ return association_type_node;
+ case BIN:
+ { tree length;
+ FORWARD_TOKEN();
+ expect (LPRN, "missing left parenthesis after BIN");
+ length = parse_expression ();
+ expect (RPRN, "missing right parenthesis after BIN");
+ return ignoring ? void_type_node : build_chill_bin_type (length);
+ }
+ case BOOLS:
+ {
+ tree length;
+ FORWARD_TOKEN ();
+ expect (LPRN, "missing '(' after BOOLS");
+ length = parse_expression ();
+ expect (RPRN, "missing ')' after BOOLS");
+ if (check_token (VARYING))
+ error ("VARYING bit-strings not implemented");
+ return ignoring ? void_type_node : build_bitstring_type (length);
+ }
+ case BUFFER:
+ {
+ tree qsize, element_mode;
+ require (BUFFER);
+ qsize = parse_opt_queue_size ();
+ element_mode = parse_mode ();
+ return ignoring ? element_mode
+ : build_buffer_type (element_mode, qsize);
+ }
+ case CHARS:
+ {
+ tree length;
+ int varying;
+ tree type;
+ FORWARD_TOKEN ();
+ expect (LPRN, "missing '(' after CHARS");
+ length = parse_expression ();
+ expect (RPRN, "missing ')' after CHARS");
+ varying = check_token (VARYING);
+ if (ignoring)
+ return void_type_node;
+ type = build_string_type (char_type_node, length);
+ if (varying)
+ type = build_varying_struct (type);
+ return type;
+ }
+ case EVENT:
+ {
+ tree qsize;
+ require (EVENT);
+ qsize = parse_opt_queue_size ();
+ return ignoring ? void_type_node : build_event_type (qsize);
+ }
+ case NAME:
+ {
+ tree mode = get_type_of (parse_name ());
+ if (check_token (LPRN))
+ {
+ tree min_value = parse_expression ();
+ if (check_token (COLON))
+ {
+ tree max_value = parse_expression ();
+ expect (RPRN, "syntax error - expected ')'");
+ /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */
+ if (ignoring)
+ return mode;
+ else
+ return build_chill_range_type (mode, min_value, max_value);
+ }
+ if (check_token (RPRN))
+ {
+ int varying = check_token (VARYING);
+ if (! ignoring)
+ {
+ if (mode == char_type_node || varying)
+ {
+ if (mode != char_type_node
+ && mode != ridpointers[(int) RID_CHAR])
+ error ("strings must be composed of chars");
+ mode = build_string_type (char_type_node, min_value);
+ if (varying)
+ mode = build_varying_struct (mode);
+ }
+ else
+ {
+ /* Parameterized mode,
+ or old-fashioned CHAR(N) string declaration.. */
+ tree pmode = make_node (LANG_TYPE);
+ TREE_TYPE (pmode) = mode;
+ TYPE_DOMAIN (pmode) = min_value;
+ mode = pmode;
+ }
+ }
+ }
+ }
+ return mode;
+ }
+ case POWERSET:
+ { tree mode;
+ FORWARD_TOKEN ();
+ mode = parse_mode ();
+ if (ignoring || TREE_CODE (mode) == ERROR_MARK)
+ return mode;
+ return build_powerset_type (get_type_of (mode));
+ }
+ case PROC:
+ return parse_procedure_mode ();
+ case RANGE:
+ { tree low, high;
+ FORWARD_TOKEN();
+ expect (LPRN, "missing left parenthesis after RANGE");
+ low = parse_expression ();
+ expect (COLON, "missing colon");
+ high = parse_expression ();
+ expect (RPRN, "missing right parenthesis after RANGE");
+ return ignoring ? void_type_node
+ : build_chill_range_type (NULL_TREE, low, high);
+ }
+ case READ:
+ FORWARD_TOKEN ();
+ {
+ tree mode2 = get_type_of (parse_mode ());
+ if (ignoring || TREE_CODE (mode2) == ERROR_MARK)
+ return mode2;
+ if (mode2
+ && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd'
+ && CH_IS_BUFFER_MODE (mode2))
+ {
+ error ("BUFFER modes may not be readonly");
+ return mode2;
+ }
+ if (mode2
+ && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd'
+ && CH_IS_EVENT_MODE (mode2))
+ {
+ error ("EVENT modes may not be readonly");
+ return mode2;
+ }
+ return build_readonly_type (mode2);
+
+ }
+ case REF:
+ { tree mode;
+ FORWARD_TOKEN ();
+ mode = parse_mode ();
+ if (ignoring)
+ return mode;
+ mode = get_type_of (mode);
+ return (TREE_CODE (mode) == ERROR_MARK) ? mode
+ : build_chill_pointer_type (mode);
+ }
+ case SET:
+ return parse_set_mode ();
+ case SIGNAL:
+ if (pedantic)
+ error ("SIGNAL is not a valid mode");
+ return generic_signal_type_node;
+ case STRUCT:
+ return parse_structure_mode ();
+ case TEXT:
+ {
+ tree length, index_mode;
+ int dynamic;
+ require (TEXT);
+ expect (LPRN, "missing '('");
+ length = parse_expression ();
+ expect (RPRN, "missing ')'");
+ /* FIXME: This should actually look for an optional index_mode,
+ but that is tricky to do. */
+ index_mode = parse_opt_mode ();
+ dynamic = check_token (DYNAMIC);
+ return ignoring ? void_type_node
+ : build_text_mode (length, index_mode, dynamic);
+ }
+ case USAGE:
+ require (USAGE);
+ return usage_type_node;
+ case WHERE:
+ require (WHERE);
+ return where_type_node;
+ default:
+ return NULL_TREE;
+ }
+}
+
+static tree
+parse_mode ()
+{
+ tree mode = parse_opt_mode ();
+ if (mode == NULL_TREE)
+ {
+ if (pass == 1)
+ error ("syntax error - missing mode");
+ mode = error_mark_node;
+ }
+ return mode;
+}
+
+static void
+parse_program()
+{
+ /* Initialize global variables for current pass. */
+ int i;
+ expand_exit_needed = 0;
+ label = NULL_TREE; /* for statement labels */
+ current_module = NULL;
+ current_function_decl = NULL_TREE;
+ in_pseudo_module = 0;
+
+ for (i = 0; i <= MAX_LOOK_AHEAD; i++)
+ terminal_buffer[i] = TOKEN_NOT_READ;
+
+#if 0
+ /* skip some junk */
+ while (PEEK_TOKEN() == HEADEREL)
+ FORWARD_TOKEN();
+#endif
+
+ start_outer_function ();
+
+ for (;;)
+ {
+ tree label = parse_optlabel ();
+ if (PEEK_TOKEN() == MODULE || PEEK_TOKEN() == REGION)
+ parse_modulion (label);
+ else if (PEEK_TOKEN() == SPEC)
+ parse_spec_module (label);
+ else break;
+ }
+
+ finish_outer_function ();
+}
+
+void
+parse_pass_1_2()
+{
+ parse_program();
+ if (PEEK_TOKEN() != END_PASS_1)
+ {
+ error ("syntax error - expected a module or end of file");
+ serious_errors++;
+ }
+ chill_finish_compile ();
+ if (serious_errors)
+ exit (FATAL_EXIT_CODE);
+ switch_to_pass_2 ();
+ ch_parse_init ();
+ except_init_pass_2 ();
+ ignoring = 0;
+ parse_program();
+ chill_finish_compile ();
+}
+
+int yyparse ()
+{
+ parse_pass_1_2 ();
+ return 0;
+}
+
+/*
+ * We've had an error. Move the compiler's state back to
+ * the global binding level. This prevents the loop in
+ * compile_file in toplev.c from looping forever, since the
+ * CHILL poplevel() has *no* effect on the value returned by
+ * global_bindings_p().
+ */
+void
+to_global_binding_level ()
+{
+ while (! global_bindings_p ())
+ current_function_decl = DECL_CONTEXT (current_function_decl);
+ serious_errors++;
+}
+
+#if 1
+int yydebug;
+/* Sets the value of the 'yydebug' variable to VALUE.
+ This is a function so we don't have to have YYDEBUG defined
+ in order to build the compiler. */
+void
+set_yydebug (value)
+ int value;
+{
+#if YYDEBUG != 0
+ yydebug = value;
+#else
+ warning ("YYDEBUG not defined.");
+#endif
+}
+#endif
--- /dev/null
+/* Implement runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include <stdlib.h>
+#include "config.h"
+#include "rtltypes.h"
+
+extern void __cause_ex1 (char *exname, char *file, int lineno);
+
+/* define needed exceptions */
+EXCEPTION (protectionfail);
+EXCEPTION (rangefail);
+EXCEPTION (spacefail);
+
+/*
+ * function _allocate_memory
+ *
+ * parameters:
+ * ptr pointer to location where pointer should be written
+ * size number of bytes to allocate
+ * filename source file which issued the call
+ * linenumber line number within that source file
+ *
+ * returns:
+ * void
+ *
+ * exceptions:
+ * spacefail
+ * protectionfail
+ * rangefail
+ *
+ * abstract:
+ * allocate memory from heap
+ *
+*/
+
+void
+_allocate_memory (ptr, size, filename, linenumber)
+ void **ptr;
+ int size;
+ char *filename;
+ int linenumber;
+{
+ void *tmp;
+
+ if (!ptr)
+ __cause_ex1 ("protectionfail", filename, linenumber);
+ if (size < 0)
+ __cause_ex1 ("rangefail", filename, linenumber);
+ tmp = malloc (size);
+ if (!tmp)
+ __cause_ex1 ("spacefail", filename, linenumber);
+ *ptr = tmp;
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __andpowerset
+ *
+ * parameters:
+ * out return from __andpowerset
+ * left left powerset
+ * right right powerset
+ * bitlength length of powerset in bits
+ *
+ * returns:
+ * void
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * and's two powersets
+ *
+ */
+
+void
+__andpowerset (out, left, right, bitlength)
+ SET_WORD *out;
+ SET_WORD *left;
+ SET_WORD *right;
+ unsigned long bitlength;
+{
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ *((SET_CHAR *)out) = *((SET_CHAR *)left) &
+ *((SET_CHAR *)right);
+ MASK_UNUSED_CHAR_BITS((SET_CHAR *)out, bitlength);
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ *((SET_SHORT *)out) = *((SET_SHORT *)left) &
+ *((SET_SHORT *)right);
+ MASK_UNUSED_SHORT_BITS((SET_SHORT *)out, bitlength);
+ }
+ else
+ {
+ unsigned long len = BITS_TO_WORDS (bitlength);
+ register unsigned long i;
+
+ for (i = 0; i < len; i++)
+ out[i] = left[i] & right[i];
+ MASK_UNUSED_WORD_BITS ((out + len - 1),
+ bitlength % SET_WORD_SIZE);
+ }
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _auxtypes_h_
+#define _auxtypes_h_
+
+
+typedef enum { False, True } Boolean;
+
+#define VARYING_STRING(strlen) \
+ struct { unsigned short len; char body[strlen]; }
+
+typedef struct {
+ unsigned short len;
+ char body[1];
+} VarString;
+
+/* Macros for moving an (U)INT and (U)LONG without alignment worries */
+#define MOV2(tgt,src) \
+ *((char*)(tgt) ) = *((char*)(src) ), \
+ *((char*)(tgt)+1) = *((char*)(src)+1)
+#define MOV4(tgt,src) \
+ *((char*)(tgt) ) = *((char*)(src) ), \
+ *((char*)(tgt)+1) = *((char*)(src)+1), \
+ *((char*)(tgt)+2) = *((char*)(src)+2), \
+ *((char*)(tgt)+3) = *((char*)(src)+3)
+
+#endif
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+ This file is part of GNU CC.
+
+ GNU CC is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ GNU CC is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU CC; see the file COPYING. If not, write to
+ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <errno.h>
+
+#include <string.h>
+#include <stdlib.h>
+
+#include "fileio.h"
+
+#ifndef PATH_MAX
+#define PATH_MAX _POSIX_PATH_MAX
+#endif
+
+static
+void
+GetSetAttributes( Association_Mode* the_assoc )
+{
+ struct stat statbuf;
+ int retco;
+
+ if( (retco = stat( the_assoc->pathname, &statbuf )) )
+ return;
+
+ if( S_ISREG(statbuf.st_mode) )
+ {
+ SET_FLAG( the_assoc, IO_EXISTING );
+ if( !TEST_FLAG( the_assoc, IO_VARIABLE ) )
+ SET_FLAG( the_assoc, IO_INDEXABLE );
+ }
+ else
+ if( S_ISCHR(statbuf.st_mode) || S_ISFIFO(statbuf.st_mode) )
+ {
+ SET_FLAG( the_assoc, IO_EXISTING );
+ CLR_FLAG( the_assoc, IO_INDEXABLE );
+ }
+ SET_FLAG( the_assoc, IO_SEQUENCIBLE );
+
+ /* FIXME: File size and computation of number of records for outoffile ? */
+
+ if( !access( the_assoc->pathname, R_OK ) )
+ SET_FLAG( the_assoc, IO_READABLE );
+ if( !access( the_assoc->pathname, W_OK ) )
+ SET_FLAG( the_assoc, IO_WRITEABLE );
+}
+
+static
+void
+makeName( Association_Mode* the_assoc, char* the_path, int the_path_len,
+ char* file, int line)
+{
+ int namlen;
+ if( ! the_assoc->pathname &&
+ ! (the_assoc->pathname = (char*)malloc( PATH_MAX )) )
+ CHILLEXCEPTION( file, line, SPACEFAIL, PATHNAME_ALLOC );
+
+ if( the_path[0] != DIRSEP )
+ {
+ if( !getcwd( the_assoc->pathname, PATH_MAX ) )
+ {
+ the_assoc->syserrno = errno;
+ CHILLEXCEPTION( file, line, ASSOCIATEFAIL, GETCWD_FAILS );
+ }
+ namlen = strlen( the_assoc->pathname );
+ the_assoc->pathname[namlen++] = DIRSEP;
+ }
+ else
+ namlen = 0;
+
+ strncpy( the_assoc->pathname + namlen, the_path, the_path_len );
+ the_assoc->pathname[namlen+the_path_len] = '\0';
+}
+
+/*
+ * ASSOCIATE
+ */
+/* Caution: returns an Association mode location (!) */
+Association_Mode*
+__associate( Association_Mode* the_assoc,
+ char* the_path,
+ int the_path_len,
+ char* the_mode,
+ int the_mode_len,
+ char* file,
+ int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+ if( TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+ CHILLEXCEPTION( file, line, ASSOCIATEFAIL, IS_ASSOCIATED );
+
+ /* clear all flags */
+ the_assoc->flags = 0;
+
+ if( ! the_path_len )
+ CHILLEXCEPTION( file, line, ASSOCIATEFAIL, NO_PATH_NAME );
+
+ makeName( the_assoc, the_path, the_path_len, file, line );
+ GetSetAttributes( the_assoc );
+
+ CLR_FLAG( the_assoc, IO_VARIABLE );
+ if ( the_mode )
+ {
+ if( !strncmp( the_mode, "VARIABLE", 8 ) )
+ {
+ SET_FLAG( the_assoc, IO_VARIABLE );
+ CLR_FLAG( the_assoc, IO_INDEXABLE );
+ }
+ else
+ if( strlen( the_mode ) )
+ CHILLEXCEPTION( file, line, ASSOCIATEFAIL, INVALID_ASSOCIATION_MODE );
+ }
+
+ SET_FLAG( the_assoc, IO_ISASSOCIATED );
+ return the_assoc;
+}
+
+/*
+ * DISSOCIATE
+ */
+void
+__dissociate( Association_Mode* the_assoc, char* file, int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+ if( !TEST_FLAG( the_assoc, IO_ISASSOCIATED ) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+ if( the_assoc->access )
+ __disconnect( the_assoc->access, file, line );
+
+ the_assoc->access = NULL;
+ CLR_FLAG( the_assoc, IO_ISASSOCIATED );
+
+ /* free allocated memory */
+ if (the_assoc->pathname)
+ {
+ free (the_assoc->pathname);
+ the_assoc->pathname = 0;
+ }
+ if (the_assoc->bufptr)
+ {
+ free (the_assoc->bufptr);
+ the_assoc->bufptr = 0;
+ }
+}
+
+/*
+ * CREATE
+ */
+void __create( Association_Mode* the_assoc, char* file, int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+ if( !TEST_FLAG( the_assoc, IO_ISASSOCIATED ) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+ if( TEST_FLAG( the_assoc, IO_EXISTING ) )
+ CHILLEXCEPTION( file, line, CREATEFAIL, FILE_EXISTING );
+
+ if( (the_assoc->handle = open( the_assoc->pathname, O_CREAT+O_TRUNC+O_WRONLY, 0666 ))
+ == -1 )
+ CHILLEXCEPTION( file, line, CREATEFAIL, CREATE_FAILS );
+
+ the_assoc->usage = ReadWrite;
+ GetSetAttributes( the_assoc );
+
+ close( the_assoc->handle );
+}
+
+/*
+ * MODIFY
+ */
+void
+__modify( Association_Mode* the_assoc,
+ char* the_path,
+ int the_path_len,
+ char* the_mode,
+ int the_mode_len,
+ char* file,
+ int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+ if( !TEST_FLAG( the_assoc, IO_ISASSOCIATED ) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+ if( the_path_len )
+ {
+ char* oldname;
+
+ if( ! (oldname = (char*)malloc( PATH_MAX )) )
+ CHILLEXCEPTION( file, line, SPACEFAIL, PATHNAME_ALLOC );
+ strcpy( oldname, the_assoc->pathname );
+
+ makeName( the_assoc, the_path, the_path_len, file, line );
+
+ if( rename( oldname, the_assoc->pathname ) )
+ {
+ free( oldname );
+ CHILLEXCEPTION( file, line, MODIFYFAIL, RENAME_FAILS );
+ }
+ free( oldname );
+ }
+ else
+ {
+ /* FIXME: other options? */
+ }
+}
+
+static
+/*** char* DirMode[] = { "rb", "r+b", "r+b" }; ***/
+int DirMode[] = { O_RDONLY, O_RDWR, O_RDWR };
+
+static
+/*** char* SeqMode [] = { "rb", "r+b", "r+b" }; ***/
+int SeqMode[] = { O_RDONLY, O_RDWR, O_RDWR };
+
+/*
+ * CONNECT
+ */
+void
+__connect( void* the_transfer,
+ Association_Mode* the_assoc,
+ Usage_Mode the_usage,
+ Where_Mode the_where,
+ Boolean with_index,
+ signed long the_index,
+ char* file,
+ int line )
+{
+ Access_Mode* the_access;
+ off_t filepos;
+ off_t savepos;
+ char dummy;
+ unsigned long nbytes;
+ int oflag;
+
+ if( !the_transfer )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+ if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+ {
+ if( ! ((Text_Mode*)the_transfer)->access_sub )
+ CHILLEXCEPTION( file, line, EMPTY, NO_ACCESS_SUBLOCATION );
+ the_access = ((Text_Mode*)the_transfer)->access_sub;
+ SET_FLAG( the_access, IO_TEXTIO );
+ }
+ else
+ {
+ the_access = (Access_Mode*)the_transfer;
+ CLR_FLAG( the_access, IO_TEXTIO );
+ }
+
+ /* FIXME: This should be an (implementation-dependent) static check
+ if( with_index && the_access->rectype > Fixed )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, IMPL_RESTRICTION );
+ */
+
+ if( ! TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+ if( ! TEST_FLAG( the_assoc, IO_EXISTING ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_EXISTING );
+
+ if( ! TEST_FLAG( the_assoc, IO_READABLE ) &&
+ ( the_usage = ReadOnly || the_usage == ReadWrite ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_READABLE );
+
+ if( ! TEST_FLAG( the_assoc, IO_WRITEABLE ) &&
+ ( the_usage = WriteOnly || the_usage == ReadWrite ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_WRITEABLE );
+
+ if( ! TEST_FLAG( the_assoc, IO_INDEXABLE )
+ && TEST_FLAG( the_access, IO_INDEXED ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_INDEXABLE );
+
+ if( ! TEST_FLAG( the_assoc, IO_SEQUENCIBLE )
+ && ! TEST_FLAG( the_access, IO_INDEXED ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_SEQUENCIBLE );
+
+ if( the_where == Same && the_assoc->access == NULL )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NO_CURRENT_POS );
+
+ /* This dynamic condition is not checked for text connections. */
+ if( ! TEST_FLAG( the_access, IO_TEXTIO ) )
+ if( ! TEST_FLAG( the_assoc, IO_VARIABLE )
+ && the_access->rectype > Fixed
+ && ( the_usage == WriteOnly || the_usage == ReadWrite ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_VARIABLE );
+
+ if( TEST_FLAG( the_assoc, IO_VARIABLE )
+ && the_access->rectype == Fixed
+ && ( the_usage == ReadOnly || the_usage == ReadWrite ) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_FIXED );
+
+ if( ! TEST_FLAG( the_access, IO_INDEXED ) && the_usage == ReadWrite )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_INDEXED );
+
+ /* Access location may be connected to a different association. */
+ if( the_access->association && the_access->association != the_assoc )
+ __disconnect( the_access, file, line );
+
+ /* Is the association location already connected? */
+ if( the_assoc->access )
+ {
+ /* save position just in case we need it for the_where == Same */
+ if( (savepos = lseek( the_assoc->handle, 0L, SEEK_CUR )) == -1L )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+
+ /* text: read correction, flush buffer */
+ if( the_assoc->bufptr ){
+ savepos -= the_assoc->bufptr->len - the_assoc->bufptr->cur;
+ the_assoc->bufptr->len = the_assoc->bufptr->cur = 0;
+ }
+
+ /* implicit disconnect */
+ __disconnect( the_assoc->access, file, line );
+ }
+
+ the_assoc->usage = the_usage;
+ CLR_FLAG( the_access, IO_OUTOFFILE );
+
+ if( TEST_FLAG( the_access, IO_INDEXED ) )
+ {
+ if( (the_assoc->handle = open( the_assoc->pathname, DirMode[the_usage] )) == -1 )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, OPEN_FAILS );
+
+ /* Set base index. */
+ switch( the_where )
+ {
+ case First:
+ filepos = 0;
+ break;
+ case Same:
+ filepos = savepos;
+ break;
+ case Last:
+ if( lseek( the_assoc->handle, 0L, SEEK_END ) == -1L )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+ filepos = lseek( the_assoc->handle, 0L, SEEK_CUR );
+ break;
+ }
+
+ /* Set current index */
+ if( with_index )
+ {
+ if( the_index < the_access->lowindex
+ || the_access->highindex < the_index )
+ CHILLEXCEPTION( file, line, RANGEFAIL, BAD_INDEX );
+ filepos += (the_index - the_access->lowindex) * the_access->reclength;
+ }
+ if( lseek( the_assoc->handle, filepos, SEEK_SET ) == -1L )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+ the_access->base = filepos;
+ }
+ else
+ {
+ /* for association to text for reading: allocate buffer */
+ if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ) &&
+ the_usage == ReadOnly &&
+ !the_assoc->bufptr )
+ {
+ if( ! (the_assoc->bufptr = (readbuf_t*)malloc( sizeof(readbuf_t) )) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, BUFFER_ALLOC );
+ memset (the_assoc->bufptr, 0, sizeof (readbuf_t));
+ }
+ if( (the_assoc->handle = open( the_assoc->pathname, SeqMode[the_usage] )) == -1 )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, OPEN_FAILS );
+
+ /* Set base index. */
+ switch( the_where )
+ {
+ case First:
+ filepos = 0;
+ break;
+ case Same:
+ filepos = savepos;
+ break;
+ case Last:
+ if( lseek( the_assoc->handle, 0L, SEEK_END ) == -1L )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+ filepos = lseek( the_assoc->handle, 0L, SEEK_CUR );
+ break;
+ }
+
+ /* file truncation for sequential, Write Only */
+ /***************************** FIXME: cannot truncate at Same
+ if( the_usage == WriteOnly )
+ {
+ if( fseek( the_assoc->file_ptr, filepos, SEEK_SET ) == -1L )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, FSEEK_FAILS );
+ fclose( the_assoc->file_ptr );
+ if( !(the_assoc->file_ptr = fopen( the_assoc->pathname, "ab" )) )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, OPEN_FAILS );
+ }
+ else
+ ***************************/
+ if( (filepos = lseek( the_assoc->handle, filepos, SEEK_SET )) == -1L )
+ CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+ }
+
+ the_access->association = the_assoc;
+ the_assoc->access = the_access;
+ /* for text: set carriage control default */
+ if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ) ){
+ the_assoc->ctl_pre = '\0';
+ the_assoc->ctl_post = '\n';
+ }
+}
+
+void
+__disconnect( void* the_transfer, char* file, int line )
+{
+ Access_Mode* the_access;
+
+ if( !the_transfer )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+ if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+ {
+ the_access = ((Text_Mode*)the_transfer)->access_sub;
+ CLR_FLAG( the_access, IO_TEXTIO );
+ }
+ else
+ the_access = (Access_Mode*)the_transfer;
+
+ if( !the_access->association )
+ CHILLEXCEPTION( file, line, NOTCONNECTED, IS_NOT_CONNECTED );
+
+ close( the_access->association->handle );
+ /* FIXME: check result */
+
+ if( the_access->store_loc )
+ free( the_access->store_loc );
+ the_access->store_loc = NULL;
+ the_access->association->access = NULL;
+ the_access->association = NULL;
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _bitstring_h_
+#define _bitstring_h_
+
+int __inpowerset( int i, char* string, int strlen, int dummy );
+void __setbitpowerset (char *powerset, unsigned long bitlength,
+ long minval, long bitno, char newval,
+ char *filename, int lineno);
+
+#endif
--- /dev/null
+/* Implement runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+
+/*
+ * function cause_exception
+ *
+ * parameters:
+ * exname exception name
+ * file file name
+ * lineno line number
+ * user_arg user specified argument
+ *
+ * returns:
+ * void
+ *
+ * abstract:
+ * dummy for ChillLib but may be overwritten by the user
+ *
+ */
+void
+cause_exception (exname, file, lineno, user_arg)
+ char *exname;
+ char *file;
+ int lineno;
+ int user_arg;
+{
+}
--- /dev/null
+/* Implement powerset-related runtime actions for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+ Author: Bill Cox
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "powerset.h"
+
+extern void cause_exception (char *exname, char *file, int lineno);
+
+/*
+ * function __concatps
+ *
+ * parameters:
+ * OUT - pointer to output PS
+ * LEFT - pointer to left PS
+ * LEFTLEN - length of left PS in bits
+ * RIGHT - pointer to right PS
+ * RIGHTLEN - length of right PS in bits
+ *
+ * returns:
+ * void
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * concatenates two powersets into the output powerset.
+ *
+ */
+
+extern void
+__pscpy (SET_WORD *dps,
+ unsigned long dbl,
+ unsigned long doffset,
+ SET_WORD *sps,
+ unsigned long sbl,
+ unsigned long start,
+ unsigned long length);
+
+void
+__concatps (out, left, leftlen, right, rightlen)
+ SET_WORD *out;
+ SET_WORD *left;
+ unsigned long leftlen;
+ SET_WORD *right;
+ unsigned long rightlen;
+{
+ /* allocated sizes for each set involved */
+ unsigned long outall, leftall, rightall;
+
+ if (!out)
+ {
+ /* FIXME: cause an exception */
+ }
+ else if (leftlen == 0 || !left)
+ {
+ if (rightlen == 0 || !right)
+ return; /* no work to do */
+ __pscpy (out, rightlen, (unsigned long)0,
+ right, rightlen, (unsigned long)0, rightlen);
+ }
+ else if (rightlen == 0 || !right)
+ {
+ if (leftlen == 0 || !left)
+ return; /* no work to do */
+ __pscpy (out, leftlen, (unsigned long)0,
+ left, leftlen, (unsigned long)0, leftlen);
+ }
+ /* copy the left powerset into bits 0..leftlen - 1 */
+ __pscpy (out, leftlen + rightlen, (unsigned long)0,
+ left, leftlen, (unsigned long)0, leftlen);
+
+ /* copy the right powerset into bits leftlen..leftlen+rightlen-1 */
+ __pscpy (out, leftlen + rightlen, leftlen,
+ right, rightlen, (unsigned long)0, rightlen);
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __powerset_copy
+ * This is more general than __psslice, since it
+ * can be told where in the destination powerset (DOFFSET
+ * parameter) to start storing the slice.
+ *
+ * parameters:
+ * dps dest powerset
+ * dbl destination bit length
+ * doffset offset bit number (zero origin)
+ * sps sourcepowerset
+ * sbl source powerset length in bits
+ * start starting bit number
+ * end ending bit number
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * Extract into a powerset a slice of another powerset.
+ *
+ */
+void
+__pscpy (dps, dbl, doffset, sps, sbl, start, length)
+ SET_WORD *dps;
+ unsigned long dbl;
+ unsigned long doffset;
+ const SET_WORD*sps;
+ unsigned long sbl;
+ unsigned long start;
+ unsigned long length;
+{
+ unsigned long end = start + length - 1;
+ unsigned long src, dst;
+
+ /* assert end >= start;
+ assert end - start + 1 <= dbl;
+ assert "the sets don't overlap in memory" */
+
+ /* assert doffset >= 0 and < dbl */
+
+ for (src = start, dst = doffset; src <= end; src++, dst++)
+ {
+ char tmp;
+
+ if (sbl <= SET_CHAR_SIZE) /* fetch a bit */
+ tmp = GET_BIT_IN_CHAR (*((SET_CHAR *)sps), src);
+ else if (sbl <= SET_SHORT_SIZE)
+ tmp = GET_BIT_IN_SHORT (*((SET_SHORT *)sps), src);
+ else
+ tmp = GET_BIT_IN_WORD (sps[src / SET_WORD_SIZE], src % SET_WORD_SIZE);
+
+ if (tmp & 1)
+ {
+ if (dbl <= SET_CHAR_SIZE) /* store a 1-bit */
+ SET_BIT_IN_CHAR (*((SET_CHAR *)dps), dst);
+ else if (dbl <= SET_SHORT_SIZE)
+ SET_BIT_IN_SHORT (*((SET_SHORT *)dps), dst);
+ else
+ SET_BIT_IN_WORD (dps[dst / SET_WORD_SIZE], dst % SET_WORD_SIZE);
+ }
+ else
+ {
+ if (dbl <= SET_CHAR_SIZE) /* store a 0-bit */
+ CLEAR_BIT_IN_CHAR (*((SET_CHAR *)dps), dst);
+ else if (dbl <= SET_SHORT_SIZE)
+ CLEAR_BIT_IN_SHORT (*((SET_SHORT *)dps), dst);
+ else
+ CLEAR_BIT_IN_WORD (dps[dst / SET_WORD_SIZE], dst % SET_WORD_SIZE);
+ }
+ }
+ if (dbl <= SET_CHAR_SIZE) /* clear unused bits in output bitstring */
+ {
+ MASK_UNUSED_CHAR_BITS ((SET_CHAR *)dps, dbl);
+ }
+ else if (dbl <= SET_SHORT_SIZE)
+ {
+ MASK_UNUSED_SHORT_BITS ((SET_SHORT *)dps, dbl);
+ }
+ else
+ {
+ MASK_UNUSED_WORD_BITS ((SET_WORD *)(dps + (dbl/SET_WORD_SIZE)),
+ dbl % SET_WORD_SIZE);
+ }
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __eqpowerset
+ *
+ * parameters:
+ * left left powerset
+ * right right powerset
+ * bitlength length of powerset in bits
+ *
+ * returns:
+ * 1 if powersets are equal, bit for bit
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * compares two powersets for equality
+ *
+ */
+int
+__eqpowerset (left, right, bitlength)
+ SET_WORD *left;
+ SET_WORD *right;
+ unsigned long bitlength;
+{
+#ifndef USE_CHARS
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ SET_CHAR c = *(SET_CHAR *)left ^ *(SET_CHAR *)right;
+ MASK_UNUSED_CHAR_BITS (&c, bitlength);
+ return (c == 0) ? 1 : 0;
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ SET_SHORT c = *(SET_SHORT *)left ^ *(SET_SHORT *)right;
+ MASK_UNUSED_SHORT_BITS (&c, bitlength);
+ return (c == 0) ? 1 : 0;
+ }
+ else if (bitlength <= SET_WORD_SIZE)
+ {
+ SET_WORD c = *(SET_WORD *)left ^ *(SET_WORD *)right;
+ MASK_UNUSED_WORD_BITS (&c, bitlength % SET_WORD_SIZE);
+ return (c == 0) ? 1 : 0;
+ }
+ else
+#endif
+ {
+ SET_WORD c;
+ register unsigned long i;
+ unsigned long len = bitlength / SET_WORD_SIZE;
+
+ for (i = 0; i < len; i++) /* a word-oriented memcmp */
+ if (left[i] != right[i])
+ return 0;
+ /* do the last (possibly partial) word */
+ bitlength %= SET_WORD_SIZE;
+ if (bitlength == 0)
+ return 1;
+ c = left[i] ^ right[i];
+ MASK_UNUSED_WORD_BITS (&c, bitlength);
+ return (c == 0) ? 1 : 0;
+ }
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _fileio_h_
+#define _fileio_h_
+
+#include <stdio.h>
+
+#include "auxtypes.h"
+#include "ioerror.h"
+#include "iomodes.h"
+
+#define DIRSEP '/'
+
+#define TEST_FLAG(Xloc,Flag) (((Xloc)->flags) & (Flag))
+#define SET_FLAG(Xloc,Flag) (Xloc)->flags |= (Flag)
+#define CLR_FLAG(Xloc,Flag) (Xloc)->flags = ((Xloc)->flags & ~(Flag))
+
+Boolean
+__isassociated( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__existing( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__readable( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__writeable( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__indexable( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__sequencible( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__variable( Association_Mode* the_assoc, char* file, int line );
+
+typedef signed long int Index_t;
+
+Association_Mode*
+__associate( Association_Mode* the_assoc,
+ char* the_path,
+ int the_path_len,
+ char* the_mode,
+ int the_mode_len,
+ char* file,
+ int line );
+
+void
+__dissociate( Association_Mode* the_assoc, char* file, int line );
+
+void
+__create( Association_Mode* the_assoc, char* file, int line );
+
+void
+__delete( Association_Mode* the_assoc, char* file, int line );
+
+void
+__modify( Association_Mode* the_assoc,
+ char* the_path,
+ int the_path_len,
+ char* the_mode,
+ int the_mode_len,
+ char* file,
+ int line );
+
+void
+__connect( void* the_transfer,
+ Association_Mode* the_assoc,
+ Usage_Mode the_usage,
+ Where_Mode the_where,
+ Boolean with_index,
+ signed long the_index,
+ char* file,
+ int line );
+
+void
+__disconnect( void* the_transfer, char* file, int line );
+
+Association_Mode*
+__getassociation( void* the_transfer, char* file, int line );
+
+Usage_Mode
+__getusage( void* the_transfer, char* file, int line );
+
+Boolean
+__outoffile( void* the_transfer, char* file, int line );
+
+void*
+__readrecord( Access_Mode* the_access,
+ signed long the_index,
+ char* the_buf_addr,
+ char* file,
+ int line );
+
+void
+__writerecord( Access_Mode* the_access,
+ signed long the_index,
+ char* the_val_addr,
+ unsigned long the_val_len,
+ char* file,
+ int line );
+
+VarString*
+__gettextrecord( Text_Mode* the_text, char* file, int line );
+
+unsigned long
+__gettextindex( Text_Mode* the_text, char* file, int line );
+
+Access_Mode*
+__gettextaccess( Text_Mode* the_text, char* file, int line );
+
+Boolean
+__eoln( Text_Mode* the_text, char* file, int line );
+
+void
+__settextrecord( Text_Mode* the_text,
+ VarString* the_text_rec,
+ char* file,
+ int line );
+
+void
+__settextindex( Text_Mode* the_text,
+ signed long the_text_index,
+ char* file,
+ int line );
+
+void
+__settextaccess( Text_Mode* the_text,
+ Access_Mode* the_access,
+ char* file,
+ int line );
+
+#endif
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+extern void __cause_ex1 (char *exname, char *file, int lineno);
+
+/*
+ * function __flsetpowerset
+ *
+ * parameters:
+ * ps powerset
+ * bitlength length of powerset
+ * minval set low bound
+ * filename caller's file name
+ * lineno caller's line number
+ *
+ * returns:
+ * int largest enumeration value
+ * exceptions:
+ * "empty" if set is empty
+ *
+ * abstract:
+ * Find last bit set in a powerset and return the corresponding value.
+ *
+ */
+long
+__flsetpowerset (ps, bitlength, minval, filename, lineno)
+ SET_WORD *ps;
+ unsigned long bitlength;
+ long minval;
+ char *filename;
+ int lineno;
+{
+ unsigned long bitno;
+
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ SET_CHAR cset = *((SET_CHAR *)ps);
+ if (cset != 0)
+ {
+ /* found a bit set .. calculate which */
+ for (bitno = SET_CHAR_SIZE; bitno >= 1; bitno--)
+ if (GET_BIT_IN_CHAR (cset, bitno - 1))
+ break;
+ /* return its index */
+ return bitno + minval - 1;
+ }
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ SET_SHORT sset = *((SET_SHORT *)ps);
+ if (sset != 0)
+ {
+ /* found a bit set .. calculate which */
+ for (bitno = SET_SHORT_SIZE; bitno >= 1; bitno--)
+ if (GET_BIT_IN_SHORT (sset, bitno - 1))
+ break;
+ /* return its index */
+ return bitno + minval - 1;
+ }
+ }
+ else /* set composed of array of one or more WORDs */
+ {
+ SET_WORD *endp = ps;
+ SET_WORD *p = ps + BITS_TO_WORDS(bitlength) - 1;
+ unsigned long cnt;
+
+ /* FIXME: bitorder problems? */
+ for (cnt = ((bitlength - 1) / SET_WORD_SIZE) * SET_WORD_SIZE;
+ p >= endp; p--, cnt -= SET_WORD_SIZE)
+ {
+ SET_WORD c = *p;
+ if (c)
+ {
+ /* found a bit set .. calculate which */
+ for (bitno = SET_WORD_SIZE; bitno >= 1; bitno--)
+ if (GET_BIT_IN_WORD (c, bitno - 1))
+ break;
+ return cnt + bitno + minval - 1;
+ }
+ }
+ }
+ /* no bits found - raise exception */
+ __cause_ex1 ("empty", filename, lineno);
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _format_h_
+#define _format_h_
+
+#include "iomodes.h"
+#include "fileio.h"
+
+extern Text_Mode __stdin_text;
+extern Text_Mode __stdout_text;
+extern Text_Mode __stderr_text;
+
+void
+__readtext_f( Text_Mode* TextLoc,
+ signed long Index,
+ char* fmtptr,
+ int fmtlen,
+ __tmp_IO_list* ioptr,
+ int iolen,
+ char* file,
+ int line );
+
+void
+__readtext_s( void* string_ptr,
+ int string_len,
+ char* fmtptr,
+ int fmtlen,
+ __tmp_IO_list* ioptr,
+ int iolen,
+ char* file,
+ int line );
+
+void
+__writetext_f( Text_Mode* Text_Loc,
+ signed long Index,
+ char* fmtptr,
+ int fmtlen,
+ __tmp_IO_list* ioptr,
+ int iolen,
+ char* file,
+ int line );
+
+void
+__writetext_s( void* string_ptr,
+ int string_len,
+ char* fmtptr,
+ int fmtlen,
+ __tmp_IO_list* ioptr,
+ int iolen,
+ char* file,
+ int line );
+
+#endif _format_h_
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+Association_Mode*
+__getassociation( void* the_transfer, char* file, int line )
+{
+ Access_Mode* the_access;
+
+ if( !the_transfer )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+ if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+ the_access = ((Text_Mode*)the_transfer)->access_sub;
+ else
+ the_access = (Access_Mode*)the_transfer;
+
+ return the_access->association;
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+Access_Mode*
+__gettextaccess( Text_Mode* the_text, char* file, int line )
+{
+ if( !the_text )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_TEXT );
+
+ return the_text->access_sub;
+}
+
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+Usage_Mode
+__getusage( void* the_transfer, char* file, int line )
+{
+ Access_Mode* the_access;
+
+ if( !the_transfer )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+ if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+ the_access = ((Text_Mode*)the_transfer)->access_sub;
+ else
+ the_access = (Access_Mode*)the_transfer;
+
+ if( !the_access->association )
+ CHILLEXCEPTION( file, line, NOTCONNECTED, IS_NOT_CONNECTED );
+ return the_access->association->usage;
+}
+
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __inpowerset
+ *
+ * parameters:
+ * bitno bit number within set
+ * powerset the powerset
+ * bitlength length of powerset in bits
+ * minval number of lowest bit stored
+ *
+ * returns:
+ * int 1 .. found
+ * 0 .. not found
+ *
+ * exceptions:
+ * rangefail
+ *
+ * abstract:
+ * checks if a given value is included in a powerset
+ *
+ */
+int
+__inpowerset (bitno, powerset, bitlength, minval)
+ unsigned long bitno;
+ SET_WORD *powerset;
+ unsigned long bitlength;
+ long minval;
+{
+ if (bitno < minval || (bitno - minval) >= bitlength)
+ return 0;
+
+ bitno -= minval;
+ if (bitlength <= SET_CHAR_SIZE)
+ return GET_BIT_IN_CHAR (*((SET_CHAR *)powerset), bitno);
+ else if (bitlength <= SET_SHORT_SIZE)
+ return GET_BIT_IN_SHORT (*((SET_SHORT *)powerset), bitno);
+ else
+ return GET_BIT_IN_WORD (powerset[bitno / SET_WORD_SIZE],
+ bitno % SET_WORD_SIZE);
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <setjmp.h>
+
+/* define names of IO-exceptions */
+
+char * __IO_exception_names[] =
+{
+ "UNUSED",
+ "notassociated",
+ "associatefail",
+ "createfail",
+ "deletefail",
+ "modifyfail",
+ "connectfail",
+ "notconnected",
+ "empty",
+ "rangefail",
+ "spacefail",
+ "readfail",
+ "writefail",
+ "textfail",
+};
+
+jmp_buf __io_exception;
+
+jmp_buf __rw_exception;
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _ioerror_h_
+#define _ioerror_h_
+
+#include <setjmp.h>
+
+/* Note: numbers must be in the same order as
+ strings in ioerror.c */
+typedef enum
+{ NOTASSOCIATED = 1,
+ ASSOCIATEFAIL,
+ CREATEFAIL,
+ DELETEFAIL,
+ MODIFYFAIL,
+ CONNECTFAIL,
+ NOTCONNECTED,
+ EMPTY,
+ RANGEFAIL,
+ SPACEFAIL,
+ READFAIL,
+ WRITEFAIL,
+ TEXTFAIL
+} io_exceptions_t;
+
+#ifndef FIRST_IO_ERROR_NUMBER
+#define FIRST_IO_ERROR_NUMBER 0
+#endif
+
+typedef enum {
+ FIRST_AND_UNUSED = FIRST_IO_ERROR_NUMBER,
+ INTERNAL_ERROR,
+ INVALID_IO_LIST,
+ REPFAC_OVERFLOW,
+ CLAUSE_WIDTH_OVERFLOW,
+ UNMATCHED_CLOSING_PAREN,
+ UNMATCHED_OPENING_PAREN,
+ BAD_FORMAT_SPEC_CHAR,
+ NO_PAD_CHAR,
+ IO_CONTROL_NOT_VALID,
+ DUPLICATE_QUALIFIER,
+ NO_FRACTION_WIDTH,
+ NO_EXPONENT_WIDTH,
+ FRACTION_WIDTH_OVERFLOW,
+ EXPONENT_WIDTH_OVERFLOW,
+ NO_FRACTION,
+ NO_EXPONENT,
+ NEGATIVE_FIELD_WIDTH,
+ TEXT_LOC_OVERFLOW,
+ IOLIST_EXHAUSTED,
+ CONVCODE_MODE_MISFIT,
+ SET_CONVERSION_ERROR,
+ BOOL_CONVERSION_ERROR,
+ NON_INT_FIELD_WIDTH,
+ EXCESS_IOLIST_ELEMENTS,
+ NOT_ENOUGH_CHARS,
+ NO_CHARS_FOR_INT,
+ NO_CHARS_FOR_FLOAT,
+ NO_EXPONENT_VAL,
+ INT_VAL_OVERFLOW,
+ REAL_OVERFLOW,
+ NO_DIGITS_FOR_INT,
+ NO_DIGITS_FOR_FLOAT,
+ NO_CHARS_FOR_SET,
+ NO_CHARS_FOR_CHAR,
+ NO_CHARS_FOR_BOOLS,
+ NO_CHARS_FOR_CHARS,
+ NO_CHARS_FOR_TEXT,
+ NO_CHARS_FOR_EDIT,
+ NO_SPACE_TO_SKIP,
+ FORMAT_TEXT_MISMATCH,
+ INTEGER_RANGE_ERROR,
+ SET_RANGE_ERROR,
+ CHAR_RANGE_ERROR,
+ INVALID_CHAR,
+/* end of formatting errors */
+ NULL_ASSOCIATION,
+ NULL_ACCESS,
+ NULL_TEXT,
+ IS_NOT_ASSOCIATED,
+ IS_ASSOCIATED,
+ GETCWD_FAILS,
+ INVALID_ASSOCIATION_MODE,
+ FILE_EXISTING,
+ CREATE_FAILS,
+ DELETE_FAILS,
+ RENAME_FAILS,
+ IMPL_RESTRICTION,
+ NOT_EXISTING,
+ NOT_READABLE,
+ NOT_WRITEABLE,
+ NOT_INDEXABLE,
+ NOT_SEQUENCIBLE,
+ NO_CURRENT_POS,
+ NOT_VARIABLE,
+ NOT_FIXED,
+ NOT_INDEXED,
+ LENGTH_CHANGE,
+ LSEEK_FAILS,
+ BUFFER_ALLOC,
+ OPEN_FAILS,
+ NO_ACCESS_SUBLOCATION,
+ BAD_INDEX,
+ IS_NOT_CONNECTED,
+ NO_PATH_NAME,
+ PATHNAME_ALLOC,
+ BAD_USAGE,
+ OUT_OF_FILE,
+ NULL_STORE_LOC,
+ STORE_LOC_ALLOC,
+ OS_IO_ERROR,
+ RECORD_TOO_LONG,
+ RECORD_TOO_SHORT,
+ BAD_TEXTINDEX,
+ NULL_TEXTREC
+} io_info_word_t;
+
+
+extern
+char* io_info_text [];
+
+extern
+char* exc_text [];
+
+extern
+jmp_buf __io_exception;
+
+extern
+jmp_buf __rw_exception;
+
+void __cause_exception (char *ex, char* f, int line, int info);
+extern char * __IO_exception_names[];
+
+#define IOEXCEPTION(EXC,INFO) \
+ longjmp( __io_exception, (EXC<<16) + INFO )
+
+#define RWEXCEPTION(EXC,INFO) \
+ longjmp( __rw_exception, (EXC<<16) + INFO )
+
+#define CHILLEXCEPTION(FILE,LINE,EXC,INFO) \
+ __cause_exception (__IO_exception_names[EXC], FILE, LINE, INFO);
+
+#endif
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _iomodes_h_
+#define _iomodes_h_
+
+#include "auxtypes.h"
+
+typedef enum { ReadOnly, WriteOnly, ReadWrite
+} Usage_Mode;
+
+typedef enum { First, Same, Last
+} Where_Mode;
+
+typedef enum { None, Fixed, VaryingChars
+} Record_t;
+
+/* association flags */
+#define IO_ISASSOCIATED 0x00000001
+#define IO_EXISTING 0x00000002
+#define IO_READABLE 0x00000004
+#define IO_WRITEABLE 0x00000008
+#define IO_INDEXABLE 0x00000010
+#define IO_SEQUENCIBLE 0x00000020
+#define IO_VARIABLE 0x00000040
+#define IO_FIRSTLINE 0x00000100
+#define IO_FORCE_PAGE 0x00000200
+
+struct Access_Mode;
+
+#define READBUFLEN 512
+typedef struct
+{
+ unsigned long len;
+ unsigned long cur;
+ char buf[READBUFLEN];
+} readbuf_t;
+
+typedef struct Association_Mode {
+ unsigned long flags; /* INIT = 0 */
+ char* pathname;
+ struct Access_Mode* access;
+ int handle;
+ readbuf_t* bufptr;
+ long syserrno;
+ char usage;
+ char ctl_pre;
+ char ctl_post;
+} Association_Mode;
+
+/*
+ rectype indexed max. reclength act. reclength
+ ---------------------------------------------------
+ None T/F 0
+ Fixed T/F SIZE(recmode) = SIZE(recmode)
+ Varying F SIZE(recmode) >= length
+*/
+
+/* access/text flags */
+#define IO_TEXTLOCATION 0x80000000
+#define IO_INDEXED 0x00000001
+#define IO_TEXTIO 0x00000002
+#define IO_OUTOFFILE 0x00010000
+
+typedef struct Access_Mode {
+ unsigned long flags; /* INIT */
+ unsigned long reclength; /* INIT */
+ signed long lowindex; /* INIT */
+ signed long highindex; /* INIT */
+ Association_Mode* association;
+ unsigned long base;
+ char* store_loc;
+ Record_t rectype; /* INIT */
+} Access_Mode;
+
+typedef struct Text_Mode {
+ unsigned long flags; /* INIT */
+ VarString* text_record; /* INIT */
+ Access_Mode* access_sub; /* INIT */
+ unsigned long actual_index;
+} Text_Mode;
+
+typedef enum
+{
+ __IO_UNUSED,
+
+ __IO_ByteVal,
+ __IO_UByteVal,
+ __IO_IntVal,
+ __IO_UIntVal,
+ __IO_LongVal,
+ __IO_ULongVal,
+
+ __IO_ByteLoc,
+ __IO_UByteLoc,
+ __IO_IntLoc,
+ __IO_UIntLoc,
+ __IO_LongLoc,
+ __IO_ULongLoc,
+
+ __IO_ByteRangeLoc,
+ __IO_UByteRangeLoc,
+ __IO_IntRangeLoc,
+ __IO_UIntRangeLoc,
+ __IO_LongRangeLoc,
+ __IO_ULongRangeLoc,
+
+ __IO_BoolVal,
+ __IO_BoolLoc,
+ __IO_BoolRangeLoc,
+
+ __IO_SetVal,
+ __IO_SetLoc,
+ __IO_SetRangeLoc,
+
+ __IO_CharVal,
+ __IO_CharLoc,
+ __IO_CharRangeLoc,
+
+ __IO_CharStrLoc,
+
+ __IO_CharVaryingLoc,
+
+ __IO_BitStrLoc,
+
+ __IO_RealVal,
+ __IO_RealLoc,
+ __IO_LongRealVal,
+ __IO_LongRealLoc
+} __tmp_IO_enum;
+
+typedef struct
+{
+ long value;
+ char* name;
+} __tmp_IO_enum_table_type;
+
+typedef struct
+{
+ long value;
+ __tmp_IO_enum_table_type* name_table;
+} __tmp_WIO_set;
+
+typedef struct
+{
+ char* ptr;
+ long lower;
+ long upper;
+} __tmp_IO_charrange;
+
+typedef union
+{
+ signed long slong;
+ unsigned long ulong;
+} __tmp_IO_long;
+
+typedef struct
+{
+ void* ptr;
+ __tmp_IO_long lower;
+ __tmp_IO_long upper;
+} __tmp_IO_intrange;
+
+typedef struct
+{
+ void* ptr;
+ unsigned long lower;
+ unsigned long upper;
+} __tmp_RIO_boolrange;
+
+typedef struct
+{
+ void* ptr;
+ long length;
+ __tmp_IO_enum_table_type* name_table;
+} __tmp_RIO_set;
+
+typedef struct
+{
+ void* ptr;
+ long length;
+ __tmp_IO_enum_table_type* name_table;
+ unsigned long lower;
+ unsigned long upper;
+} __tmp_RIO_setrange;
+
+typedef struct
+{
+ char* string;
+ long string_length;
+} __tmp_IO_charstring;
+
+typedef union
+{
+ char __valbyte;
+ unsigned char __valubyte;
+ short __valint;
+ unsigned short __valuint;
+ long __vallong;
+ unsigned long __valulong;
+ void* __locint;
+ __tmp_IO_intrange __locintrange;
+
+ unsigned char __valbool;
+ unsigned char* __locbool;
+ __tmp_RIO_boolrange __locboolrange;
+
+ __tmp_WIO_set __valset;
+ __tmp_RIO_set __locset;
+ __tmp_RIO_setrange __locsetrange;
+
+ unsigned char __valchar;
+ unsigned char* __locchar;
+ __tmp_IO_charrange __loccharrange;
+
+ __tmp_IO_charstring __loccharstring;
+
+ float __valreal;
+ float* __locreal;
+ double __vallongreal;
+ double* __loclongreal;
+} __tmp_IO_union;
+
+/*
+ * CAUTION: The longest variant of __tmp_IO_union is 5 words long.
+ * Together with __descr this caters for double alignment where required.
+ */
+typedef struct
+{
+ __tmp_IO_union __t;
+ __tmp_IO_enum __descr;
+} __tmp_IO_list;
+
+#endif
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __ltpowerset
+ *
+ * parameters:
+ * left powerset
+ * right powerset
+ * bitlength length of powerset
+ *
+ * returns:
+ * int 1 .. left is proper subset of right
+ * (excludes case where left == right)
+ * 0 .. not
+ *
+ * abstract:
+ * check if one powerset is included in another
+ *
+ */
+int
+__ltpowerset (left, right, bitlength)
+ SET_WORD *left;
+ SET_WORD *right;
+ unsigned long bitlength;
+{
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ if ((*((SET_CHAR *)left) & *((SET_CHAR *)right))
+ != *((SET_CHAR *)left))
+ return 0;
+ if (*((SET_CHAR *)left) != *((SET_CHAR *)right))
+ return 1;
+ return 0;
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ if ((*((SET_SHORT *)left) & *((SET_SHORT *)right))
+ != *((SET_SHORT *)left))
+ return 0;
+ if (*((SET_SHORT *)left) != *((SET_SHORT *)right))
+ return 1;
+ return 0;
+ }
+ else
+ {
+ SET_WORD *endp = left + BITS_TO_WORDS(bitlength);
+ int all_equal = 1; /* assume all bits are equal */
+
+ while (left < endp)
+ {
+ if ((*right & *left) != *left)
+ return 0;
+ if (*left != *right)
+ all_equal = 0;
+ left++;
+ right++;
+ }
+ if (left == endp && all_equal) /* exclude TRUE return for == case */
+ return 0;
+ return 1;
+ }
+}
--- /dev/null
+/* Implement string-related runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Bill Cox
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define MIN(a, b) ((a) < (b) ? (a) : (b))
+
+/*
+ * function __ltstring
+ *
+ * parameters:
+ * S1 - pointer to left string
+ * LEN1 - length of left string
+ * S2 - pointer to right string
+ * LEN2 - length of right string
+ *
+ * returns:
+ * 1 if left string is a proper subset of the right string, 0 otherwise
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * compares two character strings for subset relationship
+ *
+ */
+
+int __ltstring (s1, len1, s2, len2)
+ char *s1;
+ int len1;
+ char *s2;
+ int len2;
+{
+ int i;
+
+ i = memcmp (s1, s2, MIN (len1, len2));
+ if (i)
+ return (i < 0);
+ return (len1 < len2);
+}
--- /dev/null
+/* GNU CHILL compiler regression test file
+ Copyright (C) 1992, 1993 Free Software Foundation, Inc.
+
+ This file is part of GNU CC.
+
+ GNU CC is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ GNU CC is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU CC; see the file COPYING. If not, write to
+ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef __rts_h_
+#define __rts_h_
+
+typedef enum
+{
+ UNUSED,
+ Process,
+ Signal,
+ Buffer,
+ Event,
+ Synonym,
+ Exception,
+ LAST_AND_UNUSED,
+} TaskingEnum;
+
+typedef void (*EntryPoint) ();
+
+typedef struct
+{
+ char *name;
+ short *value;
+ int value_defined;
+ EntryPoint entry;
+ unsigned char /*TaskingEnum*/ type;
+} TaskingStruct;
+
+typedef struct
+{
+ short ptype;
+ short pcopy;
+} INSTANCE;
+
+#endif /* __rts_h_ */
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __powerset_slice
+ *
+ * parameters:
+ * dps dest powerset
+ * dbl destination bit length
+ * sps sourcepowerset
+ * sbl source powerset length in bits
+ * start starting bit number
+ * end ending bit number
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * Extract into a powerset a slice of another powerset.
+ *
+ */
+extern void
+__pscpy (SET_WORD *dps,
+ unsigned long dbl,
+ unsigned long doffset,
+ SET_WORD *sps,
+ unsigned long sbl,
+ unsigned long start,
+ unsigned long length);
+
+void
+__psslice (dps, dbl, sps, sbl, start, length)
+ SET_WORD *dps;
+ unsigned long dbl;
+ SET_WORD *sps;
+ unsigned long sbl;
+ unsigned long start;
+ unsigned long length;
+{
+ /* simply supply a zero destination offset and copy the slice */
+ __pscpy (dps, dbl, (unsigned long)0, sps, sbl, start, length);
+}
--- /dev/null
+/* Implement runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+
+/*
+ * function unhandled_exception
+ *
+ * parameter:
+ * exname name of exception
+ * file filename
+ * lineno line number
+ * user_arg user specified argument
+ *
+ * returns:
+ * never
+ *
+ * abstract:
+ * print an error message about unhandled exception and call abort
+ *
+ */
+
+void
+unhandled_exception (exname, file, lineno, user_arg)
+ char *exname;
+ char *file;
+ int lineno;
+ int user_arg;
+{
+ sleep (1); /* give previous output a chance to finish */
+ fprintf (stderr, "ChillLib: unhandled exception `%s' in file %s at line %d\n",
+ exname, file, lineno);
+ fflush (stderr);
+ abort ();
+} /* unhandled_exception */
--- /dev/null
+/* Implement runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+
+extern void cause_exception (char *ex, char *file, int lineno, int arg);
+extern void unhandled_exception (char *ex, char *file, int lineno, int arg);
+
+/*
+ * function __unhandled_ex
+ *
+ * parameter:
+ * exname name of exception
+ * file filename
+ * lineno line number
+ *
+ * returns:
+ * never
+ *
+ * abstract:
+ * This function gets called by compiler generated code when an unhandled
+ * exception occures.
+ * First cause_exception gets called (which may be user defined) and
+ * then the standard unhandled exception routine gets called.
+ *
+ */
+
+void
+__unhandled_ex (exname, file, lineno)
+ char *exname;
+ char *file;
+ int lineno;
+{
+ cause_exception (exname, file, lineno, 0);
+ unhandled_exception (exname, file, lineno, 0);
+} /* unhandled_exception */
--- /dev/null
+/* Name-satisfaction for GNU Chill compiler.
+ Copyright (C) 1993 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+#include "config.h"
+#include "tree.h"
+#include "flags.h"
+#include "ch-tree.h"
+#include "lex.h"
+
+#define SATISFY(ARG) ((ARG) = satisfy(ARG, chain))
+
+extern void error PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern void expand_decl PROTO((tree));
+extern void layout_enum PROTO((tree));
+
+struct decl_chain
+{
+ struct decl_chain *prev;
+ /* DECL can be a decl, or a POINTER_TYPE or a REFERENCE_TYPE. */
+ tree decl;
+};
+
+/* forward declaration */
+tree satisfy PROTO((tree, struct decl_chain *));
+
+static struct decl_chain dummy_chain;
+#define LOOKUP_ONLY (chain==&dummy_chain)
+
+/* Recursive helper routine to logically reverse the chain. */
+static void
+cycle_error_print (chain, decl)
+ struct decl_chain *chain;
+ tree decl;
+{
+ if (chain->decl != decl)
+ {
+ cycle_error_print (chain->prev, decl);
+ if (TREE_CODE_CLASS (TREE_CODE (chain->decl)) == 'd')
+ error_with_decl (chain->decl, " `%s', which depends on ...");
+ }
+}
+
+tree
+safe_satisfy_decl (decl, prev_chain)
+ tree decl;
+ struct decl_chain *prev_chain;
+{
+ struct decl_chain new_link;
+ struct decl_chain *link;
+ struct decl_chain *chain = prev_chain;
+ char *save_filename = input_filename;
+ int save_lineno = lineno;
+ tree result = decl;
+
+ if (decl == NULL_TREE)
+ return decl;
+
+ if (!LOOKUP_ONLY)
+ {
+ int pointer_type_breaks_cycle = 0;
+ /* Look for a cycle.
+ We could do this test more efficiently by setting a flag. FIXME */
+ for (link = prev_chain; link != NULL; link = link->prev)
+ {
+ if (TREE_CODE_CLASS (TREE_CODE (link->decl)) != 'd')
+ pointer_type_breaks_cycle = 1;
+ if (link->decl == decl)
+ {
+ if (!pointer_type_breaks_cycle)
+ {
+ error_with_decl (decl, "Cycle: `%s' depends on ...");
+ cycle_error_print (prev_chain, decl);
+ error_with_decl (decl, " `%s'");
+ return error_mark_node;
+ }
+ /* There is a cycle, but it includes a pointer type,
+ so we're OK. However, we still have to continue
+ the satisfy (for example in case this is a TYPE_DECL
+ that points to a LANG_DECL). The cycle-check for
+ POINTER_TYPE/REFERENCE_TYPE should stop the recursion. */
+ break;
+ }
+ }
+
+ new_link.decl = decl;
+ new_link.prev = prev_chain;
+ chain = &new_link;
+ }
+
+ input_filename = DECL_SOURCE_FILE (decl);
+ lineno = DECL_SOURCE_LINE (decl);
+
+ switch ((enum chill_tree_code)TREE_CODE (decl))
+ {
+ case ALIAS_DECL:
+ if (!LOOKUP_ONLY && !DECL_POSTFIX_ALL(decl))
+ result = safe_satisfy_decl (DECL_ABSTRACT_ORIGIN (decl), chain);
+ break;
+ case BASED_DECL:
+ SATISFY (TREE_TYPE (decl));
+ SATISFY (DECL_ABSTRACT_ORIGIN (decl));
+ break;
+ case CONST_DECL:
+ SATISFY (TREE_TYPE (decl));
+ SATISFY (DECL_INITIAL (decl));
+ if (!LOOKUP_ONLY)
+ {
+ if (DECL_SIZE (decl) == 0)
+ {
+ tree init_expr = DECL_INITIAL (decl);
+ tree init_type;
+ tree specified_mode = TREE_TYPE (decl);
+
+ if (init_expr == NULL_TREE
+ || TREE_CODE (init_expr) == ERROR_MARK)
+ goto bad_const;
+ init_type = TREE_TYPE (init_expr);
+ if (specified_mode == NULL_TREE)
+ {
+ if (init_type == NULL_TREE)
+ {
+ check_have_mode (init_expr, "SYN without mode");
+ goto bad_const;
+ }
+ TREE_TYPE (decl) = init_type;
+ CH_DERIVED_FLAG (decl) = CH_DERIVED_FLAG (init_expr);
+ }
+ else if (CH_IS_ASSOCIATION_MODE (specified_mode) ||
+ CH_IS_ACCESS_MODE (specified_mode) || CH_IS_TEXT_MODE (specified_mode) ||
+ CH_IS_BUFFER_MODE (specified_mode) || CH_IS_EVENT_MODE (specified_mode))
+ {
+ error ("SYN of this mode not allowed");
+ goto bad_const;
+ }
+ else if (!CH_COMPATIBLE (init_expr, specified_mode))
+ {
+ error ("mode of SYN incompatible with value");
+ goto bad_const;
+ }
+ else if (discrete_type_p (specified_mode)
+ && TREE_CODE (init_expr) == INTEGER_CST
+ && (compare_int_csts (LT_EXPR, init_expr,
+ TYPE_MIN_VALUE (specified_mode))
+ || compare_int_csts (GT_EXPR, init_expr,
+ TYPE_MAX_VALUE(specified_mode))
+ ))
+ {
+ error ("SYN value outside range of its mode");
+ /* set an always-valid initial value to prevent
+ other errors. */
+ DECL_INITIAL (decl) = TYPE_MIN_VALUE (specified_mode);
+ }
+ else if (CH_STRING_TYPE_P (specified_mode)
+ && (init_type && CH_STRING_TYPE_P (init_type))
+ && integer_zerop (string_assignment_condition (specified_mode, init_expr)))
+ {
+ error ("INIT string too large for mode");
+ DECL_INITIAL (decl) = error_mark_node;
+ }
+ else
+ {
+ struct ch_class class;
+ class.mode = TREE_TYPE (decl);
+ class.kind = CH_VALUE_CLASS;
+ DECL_INITIAL (decl)
+ = convert_to_class (class, DECL_INITIAL (decl));
+ }
+ /* DECL_SIZE is set to prevent re-doing this stuff. */
+ DECL_SIZE (decl) = TYPE_SIZE (TREE_TYPE (decl));
+ if (! TREE_CONSTANT (DECL_INITIAL (decl))
+ && TREE_CODE (DECL_INITIAL (decl)) != ERROR_MARK)
+ {
+ error_with_decl (decl,
+ "value of %s is not a valid constant");
+ DECL_INITIAL (decl) = error_mark_node;
+ }
+ }
+ result = DECL_INITIAL (decl);
+ }
+ break;
+ bad_const:
+ DECL_INITIAL (decl) = error_mark_node;
+ TREE_TYPE (decl) = error_mark_node;
+ return error_mark_node;
+ case FUNCTION_DECL:
+ SATISFY (TREE_TYPE (decl));
+ if (CH_DECL_PROCESS (decl))
+ safe_satisfy_decl (DECL_TASKING_CODE_DECL (decl),
+ prev_chain);
+ break;
+ case PARM_DECL:
+ SATISFY (TREE_TYPE (decl));
+ break;
+ /* RESULT_DECL doesn't need to be satisfied;
+ it's only built internally in pass 2 */
+ case TYPE_DECL:
+ SATISFY (TREE_TYPE (decl));
+ if (CH_DECL_SIGNAL (decl))
+ safe_satisfy_decl (DECL_TASKING_CODE_DECL (decl),
+ prev_chain);
+ if (!LOOKUP_ONLY)
+ {
+ if (TYPE_NAME (TREE_TYPE (decl)) == NULL_TREE)
+ TYPE_NAME (TREE_TYPE (decl)) = decl;
+ layout_decl (decl, 0);
+ if (CH_DECL_SIGNAL (decl) && CH_TYPE_NONVALUE_P (TREE_TYPE (decl)))
+ error ("mode with non-value property in signal definition");
+ result = TREE_TYPE (decl);
+ }
+ break;
+ case VAR_DECL:
+ SATISFY (TREE_TYPE (decl));
+ if (!LOOKUP_ONLY)
+ {
+ layout_decl (decl, 0);
+ if (TREE_READONLY (TREE_TYPE (decl)))
+ TREE_READONLY (decl) = 1;
+ }
+ break;
+ default:
+ ;
+ }
+
+ /* Now set the DECL_RTL, if needed. */
+ if (!LOOKUP_ONLY && DECL_RTL (decl) == 0
+ && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL
+ || TREE_CODE (decl) == CONST_DECL))
+ {
+ if (TREE_CODE (decl) == FUNCTION_DECL && decl_function_context (decl))
+ make_function_rtl (decl);
+ else if (!TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
+ expand_decl (decl);
+ else
+ { char * asm_name;
+ if (current_module == 0 || TREE_PUBLIC (decl)
+ || current_function_decl)
+ asm_name = NULL;
+ else
+ {
+ asm_name = (char*)
+ alloca (IDENTIFIER_LENGTH (current_module->prefix_name)
+ + IDENTIFIER_LENGTH (DECL_NAME (decl)) + 3);
+ sprintf (asm_name, "%s__%s",
+ IDENTIFIER_POINTER (current_module->prefix_name),
+ IDENTIFIER_POINTER (DECL_NAME (decl)));
+ }
+ make_decl_rtl (decl, asm_name, TREE_PUBLIC (decl));
+ }
+ }
+
+ input_filename = save_filename;
+ lineno = save_lineno;
+
+ return result;
+}
+
+tree
+satisfy_decl (decl, lookup_only)
+ tree decl;
+ int lookup_only;
+{
+ return safe_satisfy_decl (decl, lookup_only ? &dummy_chain : NULL);
+}
+
+static void
+satisfy_list (exp, chain)
+ register tree exp;
+ struct decl_chain *chain;
+{
+ for (; exp != NULL_TREE; exp = TREE_CHAIN (exp))
+ {
+ SATISFY (TREE_VALUE (exp));
+ SATISFY (TREE_PURPOSE (exp));
+ }
+}
+
+static void
+satisfy_list_values (exp, chain)
+ register tree exp;
+ struct decl_chain *chain;
+{
+ for (; exp != NULL_TREE; exp = TREE_CHAIN (exp))
+ {
+ SATISFY (TREE_VALUE (exp));
+ }
+}
+
+tree
+satisfy (exp, chain)
+ tree exp;
+ struct decl_chain *chain;
+{
+ int arg_length;
+ int i;
+ tree decl;
+
+ if (exp == NULL_TREE)
+ return NULL_TREE;
+
+#if 0
+ if (!UNSATISFIED (exp))
+ return exp;
+#endif
+
+ switch (TREE_CODE_CLASS (TREE_CODE (exp)))
+ {
+ case 'd':
+ if (!LOOKUP_ONLY)
+ return safe_satisfy_decl (exp, chain);
+ break;
+ case 'r':
+ case 's':
+ case '<':
+ case 'e':
+ switch ((enum chill_tree_code)TREE_CODE (exp))
+ {
+ case REPLICATE_EXPR:
+ goto binary_op;
+ case TRUTH_NOT_EXPR:
+ goto unary_op;
+ case COMPONENT_REF:
+ SATISFY (TREE_OPERAND (exp, 0));
+ if (!LOOKUP_ONLY && TREE_TYPE (exp) == NULL_TREE)
+ return resolve_component_ref (exp);
+ return exp;
+ case CALL_EXPR:
+ SATISFY (TREE_OPERAND (exp, 0));
+ SATISFY (TREE_OPERAND (exp, 1));
+ if (!LOOKUP_ONLY && TREE_TYPE (exp) == NULL_TREE)
+ return build_generalized_call (TREE_OPERAND (exp, 0),
+ TREE_OPERAND (exp, 1));
+ return exp;
+ case CONSTRUCTOR:
+ { tree link = TREE_OPERAND (exp, 1);
+ int expand_needed = TREE_TYPE (exp)
+ && TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (exp))) != 't';
+ for (; link != NULL_TREE; link = TREE_CHAIN (link))
+ {
+ SATISFY (TREE_VALUE (link));
+ if (!TUPLE_NAMED_FIELD (link))
+ SATISFY (TREE_PURPOSE (link));
+ }
+ SATISFY (TREE_TYPE (exp));
+ if (expand_needed && !LOOKUP_ONLY)
+ {
+ tree type = TREE_TYPE (exp);
+ TREE_TYPE (exp) = NULL_TREE; /* To force expansion. */
+ return chill_expand_tuple (type, exp);
+ }
+ return exp;
+ }
+ default:
+ ;
+ }
+ arg_length = tree_code_length[TREE_CODE (exp)];
+ for (i = 0; i < arg_length; i++)
+ SATISFY (TREE_OPERAND (exp, i));
+ return exp;
+ case '1':
+ unary_op:
+ SATISFY (TREE_OPERAND (exp, 0));
+ if ((enum chill_tree_code)TREE_CODE (exp) == PAREN_EXPR)
+ return TREE_OPERAND (exp, 0);
+ if (!LOOKUP_ONLY)
+ return finish_chill_unary_op (exp);
+ break;
+ case '2':
+ binary_op:
+ SATISFY (TREE_OPERAND (exp, 0));
+ SATISFY (TREE_OPERAND (exp, 1));
+ if (!LOOKUP_ONLY && TREE_CODE (exp) != RANGE_EXPR)
+ return finish_chill_binary_op (exp);
+ break;
+ case 'x':
+ switch ((enum chill_tree_code)TREE_CODE (exp))
+ {
+ case IDENTIFIER_NODE:
+ decl = lookup_name (exp);
+ if (decl == NULL)
+ {
+ if (LOOKUP_ONLY)
+ return exp;
+ error ("undeclared identifier `%s'", IDENTIFIER_POINTER (exp));
+ return error_mark_node;
+ }
+ if (LOOKUP_ONLY)
+ return decl;
+ return safe_satisfy_decl (decl, chain);
+ case TREE_LIST:
+ satisfy_list (exp, chain);
+ break;
+ default:
+ ;
+ }
+ break;
+ case 't':
+ /* If TYPE_SIZE is non-NULL, exp and its subfields has already been
+ satified and laid out. The exception is pointer and reference types,
+ which we layout before we lay out their TREE_TYPE. */
+ if (TYPE_SIZE (exp) && TREE_CODE (exp) != POINTER_TYPE
+ && TREE_CODE (exp) != REFERENCE_TYPE)
+ return exp;
+ if (TYPE_MAIN_VARIANT (exp) != exp)
+ SATISFY (TYPE_MAIN_VARIANT (exp));
+ switch ((enum chill_tree_code)TREE_CODE (exp))
+ {
+ case LANG_TYPE:
+ {
+ tree d = TYPE_DOMAIN (exp);
+ tree t = satisfy (TREE_TYPE (exp), chain);
+ SATISFY (d);
+ /* It is possible that one of the above satisfy calls recursively
+ caused exp to be satisfied, in which case we're done. */
+ if (TREE_CODE (exp) != LANG_TYPE)
+ return exp;
+ TREE_TYPE (exp) = t;
+ TYPE_DOMAIN (exp) = d;
+ if (!LOOKUP_ONLY)
+ exp = smash_dummy_type (exp);
+ }
+ break;
+ case ARRAY_TYPE:
+ SATISFY (TREE_TYPE (exp));
+ SATISFY (TYPE_DOMAIN (exp));
+ SATISFY (TYPE_ATTRIBUTES (exp));
+ if (!LOOKUP_ONLY)
+ CH_TYPE_NONVALUE_P (exp) = CH_TYPE_NONVALUE_P (TREE_TYPE (exp));
+ if (!TYPE_SIZE (exp) && !LOOKUP_ONLY)
+ exp = layout_chill_array_type (exp);
+ break;
+ case FUNCTION_TYPE:
+ SATISFY (TREE_TYPE (exp));
+ if (TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (exp))) != 't'
+ && !LOOKUP_ONLY && TREE_CODE (TREE_TYPE (exp)) != ERROR_MARK)
+ {
+ error ("RETURNS spec with invalid mode");
+ TREE_TYPE (exp) = error_mark_node;
+ }
+ satisfy_list_values (TYPE_ARG_TYPES (exp), chain);
+ if (!TYPE_SIZE (exp) && !LOOKUP_ONLY)
+ layout_type (exp);
+ break;
+ case ENUMERAL_TYPE:
+ if (TYPE_SIZE (exp) == NULL_TREE && !LOOKUP_ONLY)
+ { tree pair;
+ /* FIXME: Should this use satisfy_decl? */
+ for (pair = TYPE_VALUES (exp); pair; pair = TREE_CHAIN (pair))
+ SATISFY (DECL_INITIAL (TREE_VALUE (pair)));
+ layout_enum (exp);
+ }
+ break;
+ case INTEGER_TYPE:
+ SATISFY (TYPE_MIN_VALUE (exp));
+ SATISFY (TYPE_MAX_VALUE (exp));
+ if (TREE_TYPE (exp) != NULL_TREE)
+ { /* A range type */
+ if (TREE_TYPE (exp) != ridpointers[(int) RID_RANGE]
+ && TREE_TYPE (exp) != ridpointers[(int) RID_BIN]
+ && TREE_TYPE (exp) != string_index_type_dummy)
+ SATISFY (TREE_TYPE (exp));
+ if (!TYPE_SIZE (exp) && !LOOKUP_ONLY)
+ exp = layout_chill_range_type (exp, 1);
+ }
+ break;
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ if (LOOKUP_ONLY)
+ SATISFY (TREE_TYPE (exp));
+ else
+ {
+ struct decl_chain *link;
+ int already_seen = 0;
+ for (link = chain; ; link = link->prev)
+ {
+ if (link == NULL)
+ {
+ struct decl_chain new_link;
+ new_link.decl = exp;
+ new_link.prev = chain;
+ TREE_TYPE (exp) = satisfy (TREE_TYPE (exp), &new_link);
+ break;
+ }
+ else if (link->decl == exp)
+ {
+ already_seen = 1;
+ break;
+ }
+ }
+ if (!TYPE_SIZE (exp))
+ {
+ layout_type (exp);
+ if (TREE_CODE (exp) == REFERENCE_TYPE)
+ CH_NOVELTY (exp) = CH_NOVELTY (TREE_TYPE (exp));
+ if (! already_seen)
+ {
+ tree valtype = TREE_TYPE (exp);
+ if (TREE_CODE_CLASS (TREE_CODE (valtype)) != 't')
+ {
+ if (TREE_CODE (valtype) != ERROR_MARK)
+ error ("operand to REF is not a mode");
+ TREE_TYPE (exp) = error_mark_node;
+ return error_mark_node;
+ }
+ else if (TREE_CODE (exp) == POINTER_TYPE
+ && TYPE_POINTER_TO (valtype) == NULL)
+ TYPE_POINTER_TO (valtype) = exp;
+ }
+ }
+ }
+ break;
+ case RECORD_TYPE:
+ {
+ /* FIXME: detected errors in here will be printed as
+ often as this sequence runs. Find another way or
+ place to print the errors. */
+ /* if we have an ACCESS or TEXT mode we have to set
+ maximum_field_alignment to 0 to fit with runtime
+ system, even when we compile with -fpack. */
+ extern int maximum_field_alignment;
+ int save_maximum_field_alignment = maximum_field_alignment;
+
+ if (CH_IS_ACCESS_MODE (exp) || CH_IS_TEXT_MODE (exp))
+ maximum_field_alignment = 0;
+
+ for (decl = TYPE_FIELDS (exp); decl; decl = TREE_CHAIN (decl))
+ {
+ SATISFY (TREE_TYPE (decl));
+ if (!LOOKUP_ONLY)
+ {
+ /* if we have a UNION_TYPE here (variant structure), check for
+ non-value mode in it. This is not allowed (Z.200/pg. 33) */
+ if (TREE_CODE (TREE_TYPE (decl)) == UNION_TYPE &&
+ CH_TYPE_NONVALUE_P (TREE_TYPE (decl)))
+ {
+ error ("field with non-value mode in variant structure not allowed");
+ TREE_TYPE (decl) = error_mark_node;
+ }
+ /* RECORD_TYPE gets the non-value property if one of the
+ fields has the non-value property */
+ CH_TYPE_NONVALUE_P (exp) |= CH_TYPE_NONVALUE_P (TREE_TYPE (decl));
+ }
+ if (TREE_CODE (decl) == CONST_DECL)
+ {
+ SATISFY (DECL_INITIAL (decl));
+ if (!LOOKUP_ONLY)
+ {
+ if (CH_IS_BUFFER_MODE (exp) || CH_IS_EVENT_MODE (exp))
+ DECL_INITIAL (decl)
+ = check_queue_size (exp, DECL_INITIAL (decl));
+ else if (CH_IS_TEXT_MODE (exp) &&
+ DECL_NAME (decl) == get_identifier ("__textlength"))
+ DECL_INITIAL (decl)
+ = check_text_length (exp, DECL_INITIAL (decl));
+ }
+ }
+ else if (TREE_CODE (decl) == FIELD_DECL)
+ {
+ SATISFY (DECL_INITIAL (decl));
+ }
+ }
+ satisfy_list (TYPE_TAG_VALUES (exp), chain);
+ if (!TYPE_SIZE (exp) && !LOOKUP_ONLY)
+ exp = layout_chill_struct_type (exp);
+ maximum_field_alignment = save_maximum_field_alignment;
+
+ /* perform some checks on nonvalue modes, they are record_mode's */
+ if (!LOOKUP_ONLY)
+ {
+ if (CH_IS_BUFFER_MODE (exp))
+ {
+ tree elemmode = buffer_element_mode (exp);
+ if (elemmode != NULL_TREE && CH_TYPE_NONVALUE_P (elemmode))
+ {
+ error ("buffer element mode must not have non-value property");
+ invalidate_buffer_element_mode (exp);
+ }
+ }
+ else if (CH_IS_ACCESS_MODE (exp))
+ {
+ tree recordmode = access_recordmode (exp);
+ if (recordmode != NULL_TREE && CH_TYPE_NONVALUE_P (recordmode))
+ {
+ error ("recordmode must not have the non-value property");
+ invalidate_access_recordmode (exp);
+ }
+ }
+ }
+ }
+ break;
+ case SET_TYPE:
+ SATISFY (TYPE_DOMAIN (exp));
+ if (!TYPE_SIZE (exp) && !LOOKUP_ONLY)
+ exp = layout_powerset_type (exp);
+ break;
+ case UNION_TYPE:
+ for (decl = TYPE_FIELDS (exp); decl; decl = TREE_CHAIN (decl))
+ {
+ SATISFY (TREE_TYPE (decl));
+ if (!LOOKUP_ONLY)
+ CH_TYPE_NONVALUE_P (exp) |= CH_TYPE_NONVALUE_P (TREE_TYPE (decl));
+ }
+ if (!TYPE_SIZE (exp) && !LOOKUP_ONLY)
+ exp = layout_chill_variants (exp);
+ break;
+ default:
+ ;
+ }
+ }
+ return exp;
+}
--- /dev/null
+/* Implement tasking-related actions for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+#include <limits.h>
+#include <string.h>
+#include "config.h"
+#include "tree.h"
+#include "rtl.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "input.h"
+#include "obstack.h"
+#include "assert.h"
+#include "tasking.h"
+#include "lex.h"
+
+/* external functions */
+extern void emit_jump PROTO((rtx));
+extern void error PROTO((char *, ...));
+extern void error_with_decl PVPROTO ((tree, char *, ...));
+extern void push_obstacks PROTO((struct obstack *, struct obstack *));
+extern void warning PROTO((char *, ...));
+
+/* from ch-lex.l, from compiler directives */
+extern tree process_type;
+extern tree send_signal_prio;
+extern tree send_buffer_prio;
+
+tree tasking_message_type;
+tree instance_type_node;
+tree generic_signal_type_node;
+
+/* the type a tasking code variable has */
+tree chill_taskingcode_type_node;
+
+/* forward declarations */
+void validate_process_parameters PROTO((tree));
+tree make_process_struct PROTO((tree, tree));
+
+/* list of this module's process, buffer, etc. decls.
+ This is a list of TREE_VECs, chain by their TREE_CHAINs. */
+tree tasking_list = NULL_TREE;
+/* The parts of a tasking_list element. */
+#define TASK_INFO_PDECL(NODE) TREE_VEC_ELT(NODE,0)
+#define TASK_INFO_ENTRY(NODE) TREE_VEC_ELT(NODE,1)
+#define TASK_INFO_CODE_DECL(NODE) TREE_VEC_ELT(NODE,2)
+#define TASK_INFO_STUFF_NUM(NODE) TREE_VEC_ELT(NODE,3)
+#define TASK_INFO_STUFF_TYPE(NODE) TREE_VEC_ELT(NODE,4)
+
+/* name template for process argument type */
+static char * struct_name = "__tmp_%s_arg_type";
+
+/* name template for process arguments for debugging type */
+static char * struct_debug_name = "__tmp_%s_debug_type";
+
+/* name template for process argument variable */
+static char * data_name = "__tmp_%s_arg_variable";
+
+/* name template for process wrapper */
+static char * wrapper_name = "__tmp_%s_wrapper";
+
+extern int ignoring;
+static tree void_ftype_void;
+static tree pointer_to_instance;
+static tree infinite_buffer_event_length_node;
+\f
+tree
+get_struct_type_name (name)
+ tree name;
+{
+ char *idp = IDENTIFIER_POINTER (name); /* process name */
+ char *tmpname = xmalloc (strlen (idp) + strlen (struct_name) + 1);
+
+ sprintf (tmpname, struct_name, idp);
+ return get_identifier (tmpname);
+}
+
+tree
+get_struct_debug_type_name (name)
+ tree name;
+{
+ char *idp = IDENTIFIER_POINTER (name); /* process name */
+ char *tmpname = xmalloc (strlen (idp) + strlen (struct_debug_name) + 1);
+
+ sprintf (tmpname, struct_debug_name, idp);
+ return get_identifier (tmpname);
+}
+
+
+tree
+get_tasking_code_name (name)
+ tree name;
+{
+ char *skelname = "__tmp_%s_code";
+ char *name_str = IDENTIFIER_POINTER (name);
+ char *tmpname = (char *)alloca (IDENTIFIER_LENGTH (name) +
+ strlen (skelname) + 1);
+
+ sprintf (tmpname, skelname, name_str);
+ return get_identifier (tmpname);
+}
+
+
+static tree
+get_struct_variable_name (name)
+ tree name;
+{
+ char *idp = IDENTIFIER_POINTER (name); /* process name */
+ char *tmpname = xmalloc (strlen (idp) + strlen (data_name) + 1);
+
+ sprintf (tmpname, data_name, idp);
+ return get_identifier (tmpname);
+}
+
+static tree
+get_process_wrapper_name (name)
+ tree name;
+{
+ char *idp = IDENTIFIER_POINTER (name);
+ char *tmpname = xmalloc (strlen (idp) + strlen (wrapper_name) + 1);
+
+ sprintf (tmpname, wrapper_name, idp);
+ return get_identifier (tmpname);
+}
+\f
+/*
+ * If this is a quasi declaration - parsed within a SPEC MODULE,
+ * QUASI_FLAG is TRUE, to indicate that the variable should not
+ * be initialized. The other module will do that.
+ */
+tree
+generate_tasking_code_variable (name, tasking_code_ptr, quasi_flag)
+ tree name, *tasking_code_ptr;
+ int quasi_flag;
+{
+
+ tree decl;
+ tree tasking_code_name = get_tasking_code_name (name);
+
+ if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE)
+ {
+ /* check for value should be assigned is out of range */
+ if (TREE_INT_CST_LOW (*tasking_code_ptr) >
+ TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_taskingcode_type_node)))
+ error ("Tasking code %d out of range for `%s'.",
+ TREE_INT_CST_LOW (*tasking_code_ptr),
+ IDENTIFIER_POINTER (name));
+ }
+
+ decl = do_decl (tasking_code_name,
+ chill_taskingcode_type_node, 1, 1,
+ quasi_flag ? NULL_TREE : *tasking_code_ptr,
+ 0);
+
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE)
+ *tasking_code_ptr = fold (build (PLUS_EXPR, chill_taskingcode_type_node,
+ integer_one_node,
+ *tasking_code_ptr));
+ return decl;
+}
+
+
+/*
+ * If this is a quasi declaration - parsed within a SPEC MODULE,
+ * QUASI_FLAG is TRUE, to indicate that the variable should not
+ * be initialized. The other module will do that. This is just
+ * for BUFFERs and EVENTs.
+ */
+tree
+decl_tasking_code_variable (name, tasking_code_ptr, quasi_flag)
+ tree name, *tasking_code_ptr;
+ int quasi_flag;
+{
+ extern struct obstack permanent_obstack;
+ tree tasking_code_name = get_tasking_code_name (name);
+ tree decl;
+
+ /* guarantee that RTL for the code_variable resides in
+ the permanent obstack. The BUFFER or EVENT may be
+ declared in a PROC, not at global scope... */
+ push_obstacks (&permanent_obstack, &permanent_obstack);
+ push_obstacks_nochange ();
+
+ if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE)
+ {
+ /* check for value should be assigned is out of range */
+ if (TREE_INT_CST_LOW (*tasking_code_ptr) >
+ TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_taskingcode_type_node)))
+ error ("Tasking code %d out of range for `%s'.",
+ TREE_INT_CST_LOW (*tasking_code_ptr),
+ IDENTIFIER_POINTER (name));
+ }
+
+ decl = decl_temp1 (tasking_code_name,
+ chill_taskingcode_type_node, 1,
+ quasi_flag ? NULL_TREE : *tasking_code_ptr,
+ 0, 0);
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ /* Return to the ambient context. */
+ pop_obstacks ();
+
+ if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE)
+ *tasking_code_ptr = fold (build (PLUS_EXPR, chill_taskingcode_type_node,
+ integer_one_node,
+ *tasking_code_ptr));
+ return decl;
+}
+\f
+/*
+ * Transmute a process parameter list into an argument structure
+ * TYPE_DECL for the start_process call to reference. Create a
+ * proc_type variable for later. Returns the new struct type.
+ */
+tree
+make_process_struct (name, processparlist)
+ tree name, processparlist;
+{
+ tree temp;
+ tree a_parm;
+ tree field_decls = NULL_TREE;
+
+ if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
+ return error_mark_node;
+
+ if (processparlist == NULL_TREE)
+ return tree_cons (NULL_TREE, NULL_TREE, void_list_node);
+
+ if (TREE_CODE (processparlist) == ERROR_MARK)
+ return error_mark_node;
+
+ /* build list of field decls for build_chill_struct_type */
+ for (a_parm = processparlist; a_parm != NULL_TREE;
+ a_parm = TREE_CHAIN (a_parm))
+ {
+ tree parnamelist = TREE_VALUE (a_parm);
+ tree purpose = TREE_PURPOSE (a_parm);
+ tree mode = TREE_VALUE (purpose);
+ tree parm_attr = TREE_PURPOSE (purpose);
+ tree field;
+
+ /* build a FIELD_DECL node */
+ if (parm_attr != NULL_TREE)
+ {
+ if (parm_attr == ridpointers[(int)RID_LOC])
+ mode = build_chill_reference_type (mode);
+ else if (parm_attr == ridpointers[(int)RID_IN])
+ ;
+ else if (pass == 1)
+ {
+ for (field = parnamelist; field != NULL_TREE;
+ field = TREE_CHAIN (field))
+ error ("invalid attribute for argument `%s' (only IN or LOC allowed).",
+ IDENTIFIER_POINTER (TREE_VALUE (field)));
+ }
+ }
+
+ field = grok_chill_fixedfields (parnamelist, mode, NULL_TREE);
+
+ /* chain the fields in reverse */
+ if (field_decls == NULL_TREE)
+ field_decls = field;
+ else
+ chainon (field_decls, field);
+ }
+
+ temp = build_chill_struct_type (field_decls);
+ return temp;
+}
+\f
+/* Build a function for a PROCESS and define some
+ types for the process arguments.
+ After the PROCESS a wrapper function will be
+ generated which gets the PROCESS arguments via a pointer
+ to a structure having the same layout as the arguments.
+ This wrapper function then will call the PROCESS.
+ The advantage in doing it this way is, that PROCESS
+ arguments may be displayed by gdb without any change
+ to gdb.
+*/
+tree
+build_process_header (plabel, paramlist)
+ tree plabel, paramlist;
+{
+ tree struct_ptr_type = NULL_TREE;
+ tree new_param_list = NULL_TREE;
+ tree struct_decl = NULL_TREE;
+ tree process_struct = NULL_TREE;
+ tree struct_debug_type = NULL_TREE;
+ tree code_decl;
+
+ if (! global_bindings_p ())
+ {
+ error ("PROCESS may only be declared at module level");
+ return error_mark_node;
+ }
+
+ if (paramlist)
+ {
+ /* must make the structure OUTSIDE the parameter scope */
+ if (pass == 1)
+ {
+ process_struct = make_process_struct (plabel, paramlist);
+ struct_ptr_type = build_chill_pointer_type (process_struct);
+ }
+ else
+ {
+ process_struct = NULL_TREE;
+ struct_ptr_type = NULL_TREE;
+ }
+
+ struct_decl = push_modedef (get_struct_type_name (plabel),
+ struct_ptr_type, -1);
+ DECL_SOURCE_LINE (struct_decl) = 0;
+ struct_debug_type = push_modedef (get_struct_debug_type_name (plabel),
+ process_struct, -1);
+ DECL_SOURCE_LINE (struct_debug_type) = 0;
+
+ if (pass == 2)
+ {
+ /* build a list of PARM_DECL's */
+ tree wrk = paramlist;
+ tree tmp, list = NULL_TREE;
+
+ while (wrk != NULL_TREE)
+ {
+ tree wrk1 = TREE_VALUE (wrk);
+
+ while (wrk1 != NULL_TREE)
+ {
+ tmp = make_node (PARM_DECL);
+ DECL_ASSEMBLER_NAME (tmp) = DECL_NAME (tmp) = TREE_VALUE (wrk1);
+ if (list == NULL_TREE)
+ new_param_list = list = tmp;
+ else
+ {
+ TREE_CHAIN (list) = tmp;
+ list = tmp;
+ }
+ wrk1 = TREE_CHAIN (wrk1);
+ }
+ wrk = TREE_CHAIN (wrk);
+ }
+ }
+ else
+ {
+ /* build a list of modes */
+ tree wrk = paramlist;
+
+ while (wrk != NULL_TREE)
+ {
+ tree wrk1 = TREE_VALUE (wrk);
+
+ while (wrk1 != NULL_TREE)
+ {
+ new_param_list = tree_cons (TREE_PURPOSE (TREE_PURPOSE (wrk)),
+ TREE_VALUE (TREE_PURPOSE (wrk)),
+ new_param_list);
+ wrk1 = TREE_CHAIN (wrk1);
+ }
+ wrk = TREE_CHAIN (wrk);
+ }
+ new_param_list = nreverse (new_param_list);
+ }
+ }
+
+ /* declare the code variable outside the process */
+ code_decl = generate_tasking_code_variable (plabel,
+ &process_type, 0);
+
+ /* start the parameter scope */
+ push_chill_function_context ();
+
+ if (! start_chill_function (plabel, void_type_node,
+ new_param_list, NULL_TREE, NULL_TREE))
+ return error_mark_node;
+
+ current_module->procedure_seen = 1;
+ CH_DECL_PROCESS (current_function_decl) = 1;
+ /* remember the code variable in the function decl */
+ DECL_TASKING_CODE_DECL (current_function_decl) =
+ (struct lang_decl *)code_decl;
+ if (paramlist == NULL_TREE)
+ /* do it here, cause we don't have a wrapper */
+ add_taskstuff_to_list (code_decl, "_TT_Process", process_type,
+ current_function_decl, NULL_TREE);
+
+ return perm_tree_cons (code_decl, struct_decl, NULL_TREE);
+}
+\f
+/* Generate a function which gets a pointer
+ to an argument block and call the corresponding
+ PROCESS
+*/
+void
+build_process_wrapper (plabel, processdata)
+ tree plabel;
+ tree processdata;
+{
+ tree args = NULL_TREE;
+ tree wrapper = NULL_TREE;
+ tree parammode = TREE_VALUE (processdata);
+ tree code_decl = TREE_PURPOSE (processdata);
+ tree func = lookup_name (plabel);
+
+ /* check the mode. If it is an ERROR_MARK there was an error
+ in build_process_header, if it is a NULL_TREE the process
+ don't have parameters, so we must not generate a wrapper */
+ if (parammode == NULL_TREE ||
+ TREE_CODE (parammode) == ERROR_MARK)
+ return;
+
+ /* get the function name */
+ wrapper = get_process_wrapper_name (plabel);
+
+ /* build the argument */
+ if (pass == 2)
+ {
+ /* build a PARM_DECL */
+ args = make_node (PARM_DECL);
+ DECL_ASSEMBLER_NAME (args) = DECL_NAME (args) = get_identifier ("x");
+ }
+ else
+ {
+ /* build a tree list with the mode */
+ args = tree_cons (NULL_TREE,
+ TREE_TYPE (parammode),
+ NULL_TREE);
+ }
+
+ /* start the function */
+ push_chill_function_context ();
+
+ if (! start_chill_function (wrapper, void_type_node,
+ args, NULL_TREE, NULL_TREE))
+ return;
+
+ /* to avoid granting */
+ DECL_SOURCE_LINE (current_function_decl) = 0;
+
+ if (! ignoring)
+ {
+ /* make the call to the PROCESS */
+ tree wrk;
+ tree x = lookup_name (get_identifier ("x"));
+ /* no need to check this pointer to be NULL */
+ tree indref = build_chill_indirect_ref (x, NULL_TREE, 0);
+
+ args = NULL_TREE;
+ wrk = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (x)));
+ while (wrk != NULL_TREE)
+ {
+ args = tree_cons (NULL_TREE,
+ build_component_ref (indref, DECL_NAME (wrk)),
+ args);
+ wrk = TREE_CHAIN (wrk);
+ }
+ CH_DECL_PROCESS (func) = 0;
+ expand_expr_stmt (
+ build_chill_function_call (func, nreverse (args)));
+ CH_DECL_PROCESS (func) = 1;
+ }
+
+ add_taskstuff_to_list (code_decl, "_TT_Process", process_type,
+ func, current_function_decl);
+
+ /* finish the function */
+ finish_chill_function ();
+ pop_chill_function_context ();
+}
+\f
+/* Generate errors for INOUT, OUT parameters.
+
+ "Only if LOC is specified may the mode have the non-value
+ property"
+ */
+
+void
+validate_process_parameters (parms)
+ tree parms;
+{
+}
+\f
+/*
+ * build the tree for a start process action. Loop through the
+ * actual parameters, making a constructor list, which we use to
+ * initialize the argument structure. NAME is the process' name.
+ * COPYNUM is its copy number, whatever that is. EXPRLIST is the
+ * list of actual parameters passed by the start call. They must
+ * match. EXPRLIST must still be in reverse order; we'll reverse it here.
+ *
+ * Note: the OPTSET name is not now used - it's here for
+ * possible future support for the optional 'SET instance-var'
+ * clause.
+ */
+void
+build_start_process (process_name, copynum,
+ exprlist, optset)
+ tree process_name, copynum, exprlist, optset;
+{
+ tree process_decl, struct_type_node;
+ tree result;
+ tree valtail, typetail;
+ tree tuple, actuallist = NULL_TREE;
+ tree typelist;
+ int parmno = 2;
+ tree args;
+ tree filename, linenumber;
+
+ if (exprlist != NULL_TREE && TREE_CODE (exprlist) == ERROR_MARK)
+ process_decl = NULL_TREE;
+ else if (! ignoring)
+ {
+ process_decl = lookup_name (process_name);
+ if (process_decl == NULL_TREE)
+ error ("process name %s never declared",
+ IDENTIFIER_POINTER (process_name));
+ else if (TREE_CODE (process_decl) != FUNCTION_DECL
+ || ! CH_DECL_PROCESS (process_decl))
+ {
+ error ("You may only START a process, not a proc");
+ process_decl = NULL_TREE;
+ }
+ else if (DECL_EXTERNAL (process_decl))
+ {
+ args = TYPE_ARG_TYPES (TREE_TYPE (process_decl));
+ if (TREE_VALUE (args) != void_type_node)
+ struct_type_node = TREE_TYPE (TREE_VALUE (args));
+ else
+ struct_type_node = NULL_TREE;
+ }
+ else
+ {
+ tree debug_type = lookup_name (
+ get_struct_debug_type_name (DECL_NAME (process_decl)));
+
+ if (debug_type == NULL_TREE)
+ /* no debug type, no arguments */
+ struct_type_node = NULL_TREE;
+ else
+ struct_type_node = TREE_TYPE (debug_type);
+ }
+ }
+
+ /* begin a new name scope */
+ pushlevel (1);
+ clear_last_expr ();
+ push_momentary ();
+ if (pass == 2)
+ expand_start_bindings (0);
+
+ if (! ignoring && process_decl != NULL_TREE)
+ {
+ if (optset == NULL_TREE) ;
+ else if (!CH_REFERABLE (optset))
+ {
+ error ("SET expression not a location.");
+ optset = NULL_TREE;
+ }
+ else if (!CH_IS_INSTANCE_MODE (TREE_TYPE (optset)))
+ {
+ error ("SET location must be INSTANCE mode");
+ optset = NULL_TREE;
+ }
+ if (optset)
+ optset = force_addr_of (optset);
+ else
+ optset = convert (ptr_type_node, integer_zero_node);
+
+ if (struct_type_node != NULL_TREE)
+ {
+ typelist = TYPE_FIELDS (struct_type_node);
+
+ for (valtail = nreverse (exprlist), typetail = typelist;
+ valtail != NULL_TREE && typetail != NULL_TREE; parmno++,
+ valtail = TREE_CHAIN (valtail), typetail = TREE_CHAIN (typetail))
+ {
+ register tree actual = valtail ? TREE_VALUE (valtail) : 0;
+ register tree type = typetail ? TREE_TYPE (typetail) : 0;
+ char place[30];
+ sprintf (place, "signal field %d", parmno);
+ actual = chill_convert_for_assignment (type, actual, place);
+ actuallist = tree_cons (NULL_TREE, actual,
+ actuallist);
+ }
+
+ tuple = build_nt (CONSTRUCTOR, NULL_TREE,
+ nreverse (actuallist));
+ }
+ else
+ {
+ valtail = NULL_TREE;
+ typetail = NULL_TREE;
+ }
+
+ if (valtail != 0 && TREE_VALUE (valtail) != void_type_node)
+ {
+ char *errstr = "too many arguments to process";
+ if (process_name)
+ error ("%s `%s'", errstr, IDENTIFIER_POINTER (process_name));
+ else
+ error (errstr);
+ }
+ else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node)
+ {
+ char *errstr = "too few arguments to process";
+ if (process_name)
+ error ("%s `%s'", errstr, IDENTIFIER_POINTER (process_name));
+ else
+ error (errstr);
+ }
+ else
+ {
+ tree process_decl = lookup_name (process_name);
+ tree process_type = (tree)DECL_TASKING_CODE_DECL (process_decl);
+ tree struct_size, struct_pointer;
+
+ if (struct_type_node != NULL_TREE)
+ {
+ result =
+ decl_temp1 (get_unique_identifier ("START_ARG"),
+ struct_type_node, 0, tuple, 0, 0);
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (result) = 0;
+
+ mark_addressable (result);
+ struct_pointer
+ = build1 (ADDR_EXPR,
+ build_chill_pointer_type (struct_type_node),
+ result);
+ struct_size = size_in_bytes (struct_type_node);
+ }
+ else
+ {
+ struct_size = integer_zero_node;
+ struct_pointer = null_pointer_node;
+ }
+
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (get_identifier ("__start_process")),
+ tree_cons (NULL_TREE, process_type,
+ tree_cons (NULL_TREE, convert (integer_type_node, copynum),
+ tree_cons (NULL_TREE, struct_size,
+ tree_cons (NULL_TREE, struct_pointer,
+ tree_cons (NULL_TREE, optset,
+ tree_cons (NULL_TREE, filename,
+ build_tree_list (NULL_TREE, linenumber)))))))));
+ }
+ }
+ /* end of scope */
+
+ if (pass == 2)
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 0, 0);
+ pop_momentary ();
+}
+\f
+/*
+ * A CHILL SET which represents all of the possible tasking
+ * elements.
+ */
+static tree
+build_tasking_enum ()
+{
+ tree result, decl1;
+ tree enum1;
+ tree list = NULL_TREE;
+ tree value = integer_zero_node;
+
+ enum1 = start_enum (NULL_TREE);
+ result = build_enumerator (get_identifier ("_TT_UNUSED"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = build_enumerator (get_identifier ("_TT_Process"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = build_enumerator (get_identifier ("_TT_Signal"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = build_enumerator (get_identifier ("_TT_Buffer"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = build_enumerator (get_identifier ("_TT_Event"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = build_enumerator (get_identifier ("_TT_Synonym"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = build_enumerator (get_identifier ("_TT_Exception"),
+ value);
+ list = chainon (result, list);
+ value = fold (build (PLUS_EXPR, integer_type_node,
+ value, integer_one_node));
+
+ result = finish_enum (enum1, list);
+
+ decl1 = build_decl (TYPE_DECL,
+ get_identifier ("__tmp_TaskingEnum"),
+ result);
+ pushdecl (decl1);
+ satisfy_decl (decl1, 0);
+ return decl1;
+}
+\f
+tree
+build_tasking_struct ()
+{
+ tree listbase, decl1, decl2, result;
+ tree enum_type = TREE_TYPE (build_tasking_enum ());
+ /* We temporarily reset the maximum_field_alignment to zero so the
+ compiler's init data structures can be compatible with the
+ run-time system, even when we're compiling with -fpack. */
+ extern int maximum_field_alignment;
+ int save_maximum_field_alignment = maximum_field_alignment;
+ maximum_field_alignment = 0;
+
+ decl1 = build_decl (FIELD_DECL, get_identifier ("TaskName"),
+ build_chill_pointer_type (char_type_node));
+ DECL_INITIAL (decl1) = NULL_TREE;
+ listbase = decl1;
+
+ decl2 = build_decl (FIELD_DECL, get_identifier ("TaskValue"),
+ build_chill_pointer_type (chill_taskingcode_type_node));
+ TREE_CHAIN (decl1) = decl2;
+ DECL_INITIAL (decl2) = NULL_TREE;
+ decl1 = decl2;
+
+ decl2 = build_decl (FIELD_DECL, get_identifier ("TaskValueDefined"),
+ integer_type_node);
+ TREE_CHAIN (decl1) = decl2;
+ DECL_INITIAL (decl2) = NULL_TREE;
+ decl1 = decl2;
+
+ decl2 = build_decl (FIELD_DECL, get_identifier ("TaskEntry"),
+ build_chill_pointer_type (void_ftype_void));
+ TREE_CHAIN (decl1) = decl2;
+ DECL_INITIAL (decl2) = NULL_TREE;
+ decl1 = decl2;
+
+ decl2 = build_decl (FIELD_DECL, get_identifier ("TaskType"),
+ enum_type);
+ TREE_CHAIN (decl1) = decl2;
+ DECL_INITIAL (decl2) = NULL_TREE;
+ decl1 = decl2;
+
+ TREE_CHAIN (decl2) = NULL_TREE;
+ result = build_chill_struct_type (listbase);
+ satisfy_decl (result, 0);
+ maximum_field_alignment = save_maximum_field_alignment;
+ return result;
+}
+\f
+/*
+ * build data structures describing each task/signal, etc.
+ * in current module.
+ */
+void
+tasking_setup ()
+{
+ tree tasknode;
+ tree struct_type;
+
+ if (pass == 1)
+ return;
+
+ struct_type = TREE_TYPE (lookup_name (
+ get_identifier ("__tmp_TaskingStruct")));
+
+ for (tasknode = tasking_list; tasknode != NULL_TREE;
+ tasknode = TREE_CHAIN (tasknode))
+ {
+ /* This is the tasking_code_variable's decl */
+ tree stuffnumber = TASK_INFO_STUFF_NUM (tasknode);
+ tree code_decl = TASK_INFO_CODE_DECL (tasknode);
+ tree proc_decl = TASK_INFO_PDECL (tasknode);
+ tree entry = TASK_INFO_ENTRY (tasknode);
+ tree name = DECL_NAME (proc_decl);
+ char *init_struct = (char *) alloca (IDENTIFIER_LENGTH(name) + 20);
+ /* take care of zero termination */
+ tree task_name;
+ /* these are the fields of the struct, in declaration order */
+ tree init_flag = (stuffnumber == NULL_TREE) ?
+ integer_zero_node : integer_one_node;
+ tree type = DECL_INITIAL (TASK_INFO_STUFF_TYPE (tasknode));
+ tree int_addr;
+ tree entry_point;
+ tree name_ptr;
+ tree decl;
+ tree struct_id;
+ tree initializer;
+
+ if (TREE_CODE (proc_decl) == FUNCTION_DECL
+ && CH_DECL_PROCESS (proc_decl)
+ && ! DECL_EXTERNAL (proc_decl))
+ {
+ if (entry == NULL_TREE)
+ entry = proc_decl;
+ mark_addressable (entry);
+ entry_point = build1 (ADDR_EXPR,
+ build_chill_pointer_type (void_ftype_void),
+ entry);
+ }
+ else
+ entry_point = build1 (NOP_EXPR,
+ build_chill_pointer_type (void_ftype_void),
+ null_pointer_node);
+
+ /* take care of zero termination */
+ task_name =
+ build_chill_string (IDENTIFIER_LENGTH (name) + 1,
+ IDENTIFIER_POINTER (name));
+
+ mark_addressable (code_decl);
+ int_addr = build1 (ADDR_EXPR,
+ build_chill_pointer_type (chill_integer_type_node),
+ code_decl);
+
+ mark_addressable (task_name);
+ name_ptr = build1 (ADDR_EXPR,
+ build_chill_pointer_type (char_type_node),
+ task_name);
+
+ sprintf (init_struct, "__tmp_%s_struct",
+ IDENTIFIER_POINTER (name));
+
+ struct_id = get_identifier (init_struct);
+ initializer = build (CONSTRUCTOR, struct_type, NULL_TREE,
+ tree_cons (NULL_TREE, name_ptr,
+ tree_cons (NULL_TREE, int_addr,
+ tree_cons (NULL_TREE, init_flag,
+ tree_cons (NULL_TREE, entry_point,
+ tree_cons (NULL_TREE, type, NULL_TREE))))));
+ TREE_CONSTANT (initializer) = 1;
+ decl = decl_temp1 (struct_id, struct_type, 1, initializer, 0, 0);
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ /* pass the decl to tasking_registry() in the symbol table */
+ IDENTIFIER_LOCAL_VALUE (struct_id) = decl;
+ }
+}
+
+
+/*
+ * Generate code to register the tasking-related stuff
+ * with the runtime. Only in pass 2.
+ */
+void
+tasking_registry ()
+{
+ tree tasknode, fn_decl;
+
+ if (pass == 1)
+ return;
+
+ fn_decl = lookup_name (get_identifier ("__register_tasking"));
+
+ for (tasknode = tasking_list; tasknode != NULL_TREE;
+ tasknode = TREE_CHAIN (tasknode))
+ {
+ tree proc_decl = TASK_INFO_PDECL (tasknode);
+ tree name = DECL_NAME (proc_decl);
+ tree arg_decl;
+ char *init_struct = (char *) alloca (IDENTIFIER_LENGTH (name) + 20);
+
+ sprintf (init_struct, "__tmp_%s_struct",
+ IDENTIFIER_POINTER (name));
+ arg_decl = lookup_name (get_identifier (init_struct));
+
+ expand_expr_stmt (
+ build_chill_function_call (fn_decl,
+ build_tree_list (NULL_TREE, force_addr_of (arg_decl))));
+ }
+}
+\f
+/*
+ * Put a tasking entity (a PROCESS, or SIGNAL) onto
+ * the list for tasking_setup (). CODE_DECL is the integer code
+ * variable's DECL, which describes the shadow integer which
+ * accompanies each tasking entity. STUFFTYPE is a string
+ * representing the sort of tasking entity we have here (i.e.
+ * process, signal, etc.). STUFFNUMBER is an enumeration
+ * value saying the same thing. PROC_DECL is the declaration of
+ * the entity. It's a FUNCTION_DECL if the entity is a PROCESS, it's
+ * a TYPE_DECL if the entity is a SIGNAL.
+ */
+void
+add_taskstuff_to_list (code_decl, stufftype, stuffnumber,
+ proc_decl, entry)
+ tree code_decl;
+ char *stufftype;
+ tree stuffnumber, proc_decl, entry;
+{
+ if (pass == 1)
+ /* tell chill_finish_compile that there's
+ task-level code to be processed. */
+ tasking_list = integer_one_node;
+
+ /* do only in pass 2 so we know in chill_finish_compile whether
+ to generate a constructor function, and to avoid double the
+ correct number of entries. */
+ else /* pass == 2 */
+ {
+ tree task_node = make_tree_vec (5);
+ TASK_INFO_PDECL (task_node) = proc_decl;
+ TASK_INFO_ENTRY (task_node) = entry;
+ TASK_INFO_CODE_DECL (task_node) = code_decl;
+ TASK_INFO_STUFF_NUM (task_node) = stuffnumber;
+ TASK_INFO_STUFF_TYPE (task_node)
+ = lookup_name (get_identifier (stufftype));
+ TREE_CHAIN (task_node) = tasking_list;
+ tasking_list = task_node;
+ }
+}
+\f
+/*
+ * These next routines are called out of build_generalized_call
+ */
+tree
+build_copy_number (instance_expr)
+ tree instance_expr;
+{
+ tree result;
+
+ if (instance_expr == NULL_TREE
+ || TREE_CODE (instance_expr) == ERROR_MARK)
+ return error_mark_node;
+ if (! CH_IS_INSTANCE_MODE (TREE_TYPE (instance_expr)))
+ {
+ error ("COPY_NUMBER argument must be INSTANCE expression");
+ return error_mark_node;
+ }
+ result = build_component_ref (instance_expr,
+ get_identifier (INS_COPY));
+ CH_DERIVED_FLAG (result) = 1;
+ return result;
+}
+
+
+tree
+build_gen_code (decl)
+ tree decl;
+{
+ tree result;
+
+ if (decl == NULL_TREE || TREE_CODE (decl) == ERROR_MARK)
+ return error_mark_node;
+
+ if ((TREE_CODE (decl) == FUNCTION_DECL && CH_DECL_PROCESS (decl))
+ || (TREE_CODE (decl) == TYPE_DECL && CH_DECL_SIGNAL (decl)))
+ result = (tree)(DECL_TASKING_CODE_DECL (decl));
+ else
+ {
+ error ("GEN_CODE argument must be a process or signal name.");
+ return error_mark_node;
+ }
+ CH_DERIVED_FLAG (result) = 1;
+ return (result);
+}
+
+
+tree
+build_gen_inst (process, copyn)
+ tree process, copyn;
+{
+ tree ptype;
+ tree result;
+
+ if (copyn == NULL_TREE || TREE_CODE (copyn) == ERROR_MARK)
+ return error_mark_node;
+ if (process == NULL_TREE || TREE_CODE (process) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (TREE_TYPE (copyn)) != INTEGER_TYPE)
+ {
+ error ("GEN_INST parameter 2 must be an integer mode");
+ copyn = integer_zero_node;
+ }
+
+ copyn = check_range (copyn, copyn,
+ TYPE_MIN_VALUE (chill_taskingcode_type_node),
+ TYPE_MAX_VALUE (chill_taskingcode_type_node));
+
+ if (TREE_CODE (process) == FUNCTION_DECL
+ && CH_DECL_PROCESS (process))
+ ptype = (tree)DECL_TASKING_CODE_DECL (process);
+ else if (TREE_TYPE (process) != NULL_TREE
+ && TREE_CODE (TREE_TYPE (process)) == INTEGER_TYPE)
+ {
+ process = check_range (process, process,
+ TYPE_MIN_VALUE (chill_taskingcode_type_node),
+ TYPE_MAX_VALUE (chill_taskingcode_type_node));
+ ptype = convert (chill_taskingcode_type_node, process);
+ }
+ else
+ {
+ error ("GEN_INST parameter 1 must be a PROCESS or an integer expression");
+ return (error_mark_node);
+ }
+
+ result = convert (instance_type_node,
+ build_nt (CONSTRUCTOR, NULL_TREE,
+ tree_cons (NULL_TREE, ptype,
+ tree_cons (NULL_TREE,
+ convert (chill_taskingcode_type_node, copyn), NULL_TREE))));
+ CH_DERIVED_FLAG (result) = 1;
+ return result;
+}
+
+
+tree
+build_gen_ptype (process_decl)
+ tree process_decl;
+{
+ tree result;
+
+ if (process_decl == NULL_TREE || TREE_CODE (process_decl) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (process_decl) != FUNCTION_DECL
+ || ! CH_DECL_PROCESS (process_decl))
+ {
+ error_with_decl (process_decl, "%s is not a declared process");
+ return error_mark_node;
+ }
+
+ result = (tree)DECL_TASKING_CODE_DECL (process_decl);
+ CH_DERIVED_FLAG (result) = 1;
+ return result;
+}
+
+
+tree
+build_proc_type (instance_expr)
+ tree instance_expr;
+{
+ tree result;
+
+ if (instance_expr == NULL_TREE || TREE_CODE (instance_expr) == ERROR_MARK)
+ return error_mark_node;
+
+ if (! CH_IS_INSTANCE_MODE (TREE_TYPE (instance_expr)))
+ {
+ error ("PROC_TYPE argument must be INSTANCE expression");
+ return error_mark_node;
+ }
+ result = build_component_ref (instance_expr,
+ get_identifier (INS_PTYPE));
+ CH_DERIVED_FLAG (result) = 1;
+ return result;
+}
+
+tree
+build_queue_length (buf_ev)
+ tree buf_ev;
+{
+ if (buf_ev == NULL_TREE || TREE_CODE (buf_ev) == ERROR_MARK)
+ return error_mark_node;
+ if (TREE_TYPE (buf_ev) == NULL_TREE ||
+ TREE_CODE (TREE_TYPE (buf_ev)) == ERROR_MARK)
+ return error_mark_node;
+
+ if (CH_IS_BUFFER_MODE (TREE_TYPE (buf_ev)) ||
+ CH_IS_EVENT_MODE (TREE_TYPE (buf_ev)))
+ {
+ char *field_name;
+ tree arg1, arg2;
+
+ if (CH_IS_EVENT_MODE (TREE_TYPE (buf_ev)))
+ {
+ field_name = "__event_data";
+ arg2 = integer_one_node;
+ }
+ else
+ {
+ field_name = "__buffer_data";
+ arg2 = integer_zero_node;
+ }
+ arg1 = build_component_ref (buf_ev, get_identifier (field_name));
+ return build_chill_function_call (
+ lookup_name (get_identifier ("__queue_length")),
+ tree_cons (NULL_TREE, arg1,
+ tree_cons (NULL_TREE, arg2, NULL_TREE)));
+ }
+
+ error ("QUEUE_LENGTH argument must be a BUFFER/EVENT location.");
+ return error_mark_node;
+}
+\f
+tree
+build_signal_struct_type (signame, sigmodelist, optsigdest)
+ tree signame, sigmodelist, optsigdest;
+{
+ tree decl, temp;
+
+ if (pass == 1)
+ {
+ int fldcnt = 0;
+ tree mode, field_decls = NULL_TREE;
+
+ for (mode = sigmodelist; mode != NULL_TREE; mode = TREE_CHAIN (mode))
+ {
+ tree field;
+ char fldname[20];
+
+ if (TREE_VALUE (mode) == NULL_TREE)
+ continue;
+ sprintf (fldname, "fld%03d", fldcnt++);
+ field = build_decl (FIELD_DECL,
+ get_identifier (fldname),
+ TREE_VALUE (mode));
+ if (field_decls == NULL_TREE)
+ field_decls = field;
+ else
+ chainon (field_decls, field);
+ }
+ if (field_decls == NULL_TREE)
+ field_decls = build_decl (FIELD_DECL,
+ get_identifier ("__tmp_empty"),
+ boolean_type_node);
+ temp = build_chill_struct_type (field_decls);
+
+ /* save the destination process name of the signal */
+ IDENTIFIER_SIGNAL_DEST (signame) = optsigdest;
+ IDENTIFIER_SIGNAL_DATA (signame) = fldcnt;
+ }
+ else
+ {
+ /* optsigset is only valid in pass 2, so we have to save it now */
+ IDENTIFIER_SIGNAL_DEST (signame) = optsigdest;
+ temp = NULL_TREE; /* Actually, don't care. */
+ }
+
+ decl = push_modedef (signame, temp, -1);
+ if (decl != NULL_TREE)
+ CH_DECL_SIGNAL (decl) = 1;
+ return decl;
+}
+\f
+/*
+ * An instance type is a unique process identifier in the CHILL
+ * tasking arena. It consists of a process type and a copy number.
+ */
+void
+build_instance_type ()
+{
+ tree decl1, decl2, tdecl;
+
+ decl1 = build_decl (FIELD_DECL, get_identifier (INS_PTYPE),
+ chill_taskingcode_type_node);
+
+ TREE_CHAIN (decl1) = decl2 =
+ build_decl (FIELD_DECL, get_identifier (INS_COPY),
+ chill_taskingcode_type_node);
+ TREE_CHAIN (decl2) = NULL_TREE;
+
+ instance_type_node = build_chill_struct_type (decl1);
+ tdecl = build_decl (TYPE_DECL, ridpointers[(int) RID_INSTANCE],
+ instance_type_node);
+ TYPE_NAME (instance_type_node) = tdecl;
+ CH_NOVELTY (instance_type_node) = tdecl;
+ DECL_SOURCE_LINE (tdecl) = 0;
+ pushdecl (tdecl);
+
+ pointer_to_instance = build_chill_pointer_type (instance_type_node);
+}
+\f
+#if 0
+ *
+ * The tasking message descriptor looks like this C structure:
+ *
+ * typedef struct
+ * {
+ * short *sc; /* ptr to code integer */
+ * int data_len; /* length of signal/buffer data msg */
+ * void *data; /* ptr to signal/buffer data */
+ * } SignalDescr;
+ *
+ *
+#endif
+
+void
+build_tasking_message_type ()
+{
+ tree type_name;
+ tree temp;
+ /* We temporarily reset maximum_field_alignment to deal with
+ the runtime system. */
+ extern int maximum_field_alignment;
+ int save_maximum_field_alignment = maximum_field_alignment;
+ tree field1, field2, field3;
+
+ maximum_field_alignment = 0;
+ field1 = build_decl (FIELD_DECL,
+ get_identifier ("_SD_code_ptr"),
+ build_pointer_type (chill_integer_type_node));
+ field2 = build_decl (FIELD_DECL,
+ get_identifier ("_SD_data_len"),
+ integer_type_node);
+ field3 = build_decl (FIELD_DECL,
+ get_identifier ("_SD_data_ptr"),
+ ptr_type_node);
+ TREE_CHAIN (field1) = field2;
+ TREE_CHAIN (field2) = field3;
+ temp = build_chill_struct_type (field1);
+
+ type_name = get_identifier ("__tmp_SD_struct");
+ tasking_message_type = build_decl (TYPE_DECL, type_name, temp);
+
+ /* This won't get seen in pass 2, so lay it out now. */
+ layout_chill_struct_type (temp);
+ pushdecl (tasking_message_type);
+ maximum_field_alignment = save_maximum_field_alignment;
+}
+\f
+tree
+build_signal_descriptor (sigdef, exprlist)
+ tree sigdef, exprlist;
+{
+ tree fieldlist, typetail, valtail;
+ tree actuallist = NULL_TREE;
+ tree signame = DECL_NAME (sigdef);
+ tree dataptr, datalen;
+ int parmno = 1;
+
+ if (sigdef == NULL_TREE
+ || TREE_CODE (sigdef) == ERROR_MARK)
+ return error_mark_node;
+
+ if (exprlist != NULL_TREE
+ && TREE_CODE (exprlist) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (sigdef) != TYPE_DECL
+ || ! CH_DECL_SIGNAL (sigdef))
+ {
+ error ("SEND requires a SIGNAL; %s is not a SIGNAL name",
+ signame);
+ return error_mark_node;
+ }
+ if (CH_TYPE_NONVALUE_P (TREE_TYPE (sigdef)))
+ return error_mark_node;
+
+ fieldlist = TYPE_FIELDS (TREE_TYPE (sigdef));
+ if (IDENTIFIER_SIGNAL_DATA (signame) == 0)
+ fieldlist = TREE_CHAIN (fieldlist);
+
+ for (valtail = exprlist, typetail = fieldlist;
+ valtail != NULL_TREE && typetail != NULL_TREE;
+ parmno++, valtail = TREE_CHAIN (valtail),
+ typetail = TREE_CHAIN (typetail))
+ {
+ register tree actual = valtail ? TREE_VALUE (valtail) : 0;
+ register tree type = typetail ? TREE_TYPE (typetail) : 0;
+ char place[30];
+ sprintf (place, "signal field %d", parmno);
+ actual = chill_convert_for_assignment (type, actual, place);
+ actuallist = tree_cons (NULL_TREE, actual, actuallist);
+ }
+ if (valtail != 0 && TREE_VALUE (valtail) != void_type_node)
+ {
+ error ("too many values for SIGNAL `%s'",
+ IDENTIFIER_POINTER (signame));
+ return error_mark_node;
+ }
+ else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node)
+ {
+ error ("too few values for SIGNAL `%s'",
+ IDENTIFIER_POINTER (signame));
+ return error_mark_node;
+ }
+
+ {
+ /* build signal data structure */
+ tree sigdataname = get_unique_identifier (
+ IDENTIFIER_POINTER (signame));
+ if (exprlist == NULL_TREE)
+ {
+ dataptr = null_pointer_node;
+ datalen = integer_zero_node;
+ }
+ else
+ {
+ tree tuple = build_nt (CONSTRUCTOR,
+ NULL_TREE, nreverse (actuallist));
+ tree decl = decl_temp1 (sigdataname, TREE_TYPE (sigdef),
+ 0, tuple, 0, 0);
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ dataptr = force_addr_of (decl);
+ datalen = size_in_bytes (TREE_TYPE (decl));
+ }
+
+ /* build descriptor pointing to signal data */
+ {
+ tree decl, tuple;
+ tree tasking_message_var = get_unique_identifier (
+ IDENTIFIER_POINTER (signame));
+
+ tree tasking_code =
+ (tree)DECL_TASKING_CODE_DECL (lookup_name (signame));
+
+ mark_addressable (tasking_code);
+ tuple = build_nt (CONSTRUCTOR, NULL_TREE,
+ tree_cons (NULL_TREE,
+ build1 (ADDR_EXPR,
+ build_chill_pointer_type (chill_integer_type_node),
+ tasking_code),
+ tree_cons (NULL_TREE, datalen,
+ tree_cons (NULL_TREE, dataptr, NULL_TREE))));
+
+ decl = decl_temp1 (tasking_message_var,
+ TREE_TYPE (tasking_message_type), 0,
+ tuple, 0, 0);
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ tuple = force_addr_of (decl);
+ return tuple;
+ }
+ }
+}
+\f
+void
+expand_send_signal (sigmsgbuffer, optroutinginfo, optsendto,
+ optpriority, signame)
+ tree sigmsgbuffer;
+ tree optroutinginfo;
+ tree optsendto;
+ tree optpriority;
+ tree signame;
+{
+ tree routing_size, routing_addr;
+ tree filename, linenumber;
+ tree sigdest = IDENTIFIER_SIGNAL_DEST (signame);
+
+ /* check the presence of priority */
+ if (optpriority == NULL_TREE)
+ {
+ if (send_signal_prio == NULL_TREE)
+ {
+ /* issue a warning in case of -Wall */
+ if (extra_warnings)
+ {
+ warning ("Signal sent without priority");
+ warning (" and no default priority was set.");
+ warning (" PRIORITY defaulted to 0");
+ }
+ optpriority = integer_zero_node;
+ }
+ else
+ optpriority = send_signal_prio;
+ }
+
+ /* check the presence of a destination.
+ optdest either may be an instance location
+ or a process declaration */
+ if (optsendto == NULL_TREE)
+ {
+ if (sigdest == NULL_TREE)
+ {
+ error ("SEND without a destination instance");
+ error (" and no destination process specified");
+ error (" for the signal");
+ optsendto = convert (instance_type_node,
+ null_pointer_node);
+ }
+ else
+ {
+ /* build an instance [sigdest; -1] */
+ tree process_name = DECL_NAME (sigdest);
+ tree copy_number = fold (build (MINUS_EXPR, integer_type_node,
+ integer_zero_node,
+ integer_one_node));
+ tree tasking_code = (tree)DECL_TASKING_CODE_DECL (
+ lookup_name (process_name));
+
+ optsendto = build (CONSTRUCTOR, instance_type_node, NULL_TREE,
+ tree_cons (NULL_TREE, tasking_code,
+ tree_cons (NULL_TREE, copy_number, NULL_TREE)));
+ /* as our system doesn't allow that and Z.200 specifies it,
+ we issue a warning */
+ warning ("SEND to ANY copy of process `%s'.", IDENTIFIER_POINTER (process_name));
+ }
+ }
+ else if (! CH_IS_INSTANCE_MODE (TREE_TYPE (optsendto)))
+ {
+ error ("SEND TO must be an INSTANCE mode");
+ optsendto = convert (instance_type_node, null_pointer_node);
+ }
+ else
+ optsendto = check_non_null (convert (instance_type_node, optsendto));
+
+ /* check the routing stuff */
+ if (optroutinginfo != NULL_TREE)
+ {
+ tree routing_name;
+ tree decl;
+
+ if (TREE_TYPE (optroutinginfo) == NULL_TREE)
+ {
+ error ("SEND WITH must have a mode");
+ optroutinginfo = integer_zero_node;
+ }
+ routing_name = get_unique_identifier ("RI");
+ decl = decl_temp1 (routing_name,
+ TREE_TYPE (optroutinginfo), 0,
+ optroutinginfo, 0, 0);
+ /* prevent granting of this type */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ routing_addr = force_addr_of (decl);
+ routing_size = size_in_bytes (TREE_TYPE (decl));
+ }
+ else
+ {
+ routing_size = integer_zero_node;
+ routing_addr = null_pointer_node;
+ }
+ /* get filename and linenumber */
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+
+ /* Now (at last!) we can call the runtime */
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (get_identifier ("__send_signal")),
+ tree_cons (NULL_TREE, sigmsgbuffer,
+ tree_cons (NULL_TREE, optsendto,
+ tree_cons (NULL_TREE, optpriority,
+ tree_cons (NULL_TREE, routing_size,
+ tree_cons (NULL_TREE, routing_addr,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))));
+}
+\f
+#if 0
+ * The following code builds a RECEIVE CASE action, which actually
+ * has 2 different functionalities:
+ *
+ * 1) RECEIVE signal CASE action
+ * which looks like this:
+ *
+ * SIGNAL advance;
+ * SIGNAL terminate = (CHAR);
+ * SIGNAL sig1 = (CHAR);
+ *
+ * DCL user, system INSTANCE;
+ * DCL count INT, char_code CHAR;
+ * DCL instance_loc INSTANCE;
+ *
+ * workloop:
+ * RECEIVE CASE SET instance_loc;
+ * (advance):
+ * count + := 1;
+ * (terminate IN char_code):
+ * SEND sig1(char_code) TO system;
+ * EXIT workloop;
+ * ELSE
+ * STOP;
+ * ESAC;
+ *
+ * Because we don''t know until we get to the ESAC how
+ * many signals need processing, we generate the following
+ * C-equivalent code:
+ *
+ * /* define the codes for the signals */
+ * static short __tmp_advance_code;
+ * static short __tmp_terminate_code;
+ * static short __tmp_sig1_code;
+ *
+ * /* define the types of the signals */
+ * typedef struct
+ * {
+ * char fld0;
+ * } __tmp_terminate_struct;
+ *
+ * typedef struct
+ * {
+ * char fld0;
+ * } __tmp_sig1_struct;
+ *
+ * static INSTANCE user, system, instance_loc;
+ * static short count;
+ * static char char_code;
+ *
+ * { /* start a new symbol context */
+ * int number_of_sigs;
+ * short *sig_code [];
+ * void *sigdatabuf;
+ * int sigdatalen;
+ * short sigcode;
+ *
+ * goto __rcsetup;
+ *
+ * __rcdoit: ;
+ * int timedout = __wait_signal (&sigcode
+ * number_of_sigs,
+ * sig_code,
+ * sigdatabuf,
+ * sigdatalen,
+ * &instance_loc);
+ * if (sigcode == __tmp_advance_code)
+ * {
+ * /* code for advance alternative's action_statement_list */
+ * count++;
+ * }
+ * else if (sigcode == __tmp_terminate_code)
+ * {
+ * /* copy signal's data to where they belong,
+ * with range-check, if enabled */
+ * char_code = ((__tmp_terminate_struct *)sigdatabuf)->fld0;
+ *
+ * /* code for terminate alternative's action_statement_list */
+ * __send_signal (sig1 ..... );
+ * goto __workloop_end;
+ * }
+ * else
+ * {
+ * /* code here for the ELSE action_statement_list */
+ * __stop_process ();
+ * }
+ * goto __rc_done;
+ *
+ * __rcsetup:
+ * union { __tmp_terminate_struct terminate;
+ * __tmp_sig1_struct } databuf;
+ * short *sig_code_ptr [2] = { &__tmp_advance_code,
+ * &__tmp_terminate_code };
+ * sigdatabuf = &databuf;
+ * sigdatalen = sizeof (databuf);
+ * sig_code = &sig_code_ptr[0];
+ * number_of_sigs = 2;
+ * goto __rcdoit;
+ *
+ * __rc_done: ;
+ * } /* end the new symbol context */
+ * __workloop_end: ;
+ *
+ *
+ * 2) RECEIVE buffer CASE action:
+ * which looks like this:
+ *
+ * NEWMODE m_s = STRUCT (mini INT, maxi INT);
+ * DCL b1 BUFFER INT;
+ * DCL b2 BUFFER (30) s;
+ *
+ * DCL i INT, s m_s, ins INSTANCE;
+ * DCL count INT;
+ *
+ * workloop:
+ * RECEIVE CASE SET ins;
+ * (b1 IN i):
+ * count +:= i;
+ * (b2 in s):
+ * IF count < s.mini OR count > s.maxi THEN
+ * EXIT workloop;
+ * FI;
+ * ELSE
+ * STOP;
+ * ESAC;
+ *
+ * Because we don''t know until we get to the ESAC how
+ * many buffers need processing, we generate the following
+ * C-equivalent code:
+ *
+ * typedef struct
+ * {
+ * short mini;
+ * short maxi;
+ * } m_s;
+ *
+ * static void *b1;
+ * static void *b2;
+ * static short i;
+ * static m_s s;
+ * static INSTANCE ins;
+ * static short count;
+ *
+ * workloop:
+ * { /* start a new symbol context */
+ * int number_of_sigs;
+ * void *sig_code [];
+ * void *sigdatabuf;
+ * int sigdatalen;
+ * void *buflocation;
+ * int timedout;
+ *
+ * goto __rcsetup;
+ *
+ * __rcdoit:
+ * timedout = __wait_buffer (&buflocation,
+ * number_of_sigs,
+ * sig_code,
+ * sigdatabuf,
+ * sigdatalen,
+ * &ins, ...);
+ * if (buflocation == &b1)
+ * {
+ * i = ((short *)sigdatabuf)->fld0;
+ * count += i;
+ * }
+ * else if (buflocation == &b2)
+ * {
+ * s = ((m_s)*sigdatabuf)->fld1;
+ * if (count < s.mini || count > s.maxi)
+ * goto __workloop_end;
+ * }
+ * else
+ * __stop_process ();
+ * goto __rc_done;
+ *
+ * __rcsetup:
+ * typedef struct
+ * {
+ * void *p;
+ * unsigned maxqueuesize;
+ * } Buffer_Descr;
+ * union { short b1,
+ * m_s b2 } databuf;
+ * Buffer_Descr bufptr [2] =
+ * {
+ * { &b1, -1 },
+ * { &b2, 30 },
+ * };
+ * void * bufarray[2] = { &bufptr[0],
+ * &bufptr[1] };
+ * sigdatabuf = &databuf;
+ * sigdatalen = sizeof (databuf);
+ * sig_code = &bufarray[0];
+ * number_of_sigs = 2;
+ * goto __rcdoit;
+ *
+ * __rc_done;
+ * } /* end of symbol context */
+ * __workloop_end:
+ *
+#endif
+\f
+struct rc_state_type
+{
+ struct rc_state_type *enclosing;
+ rtx rcdoit;
+ rtx rcsetup;
+ tree n_sigs;
+ tree sig_code;
+ tree databufp;
+ tree datalen;
+ tree else_clause;
+ tree received_signal;
+ tree received_buffer;
+ tree to_loc;
+ int sigseen;
+ int bufseen;
+ tree actuallist;
+ int call_generated;
+ int if_generated;
+ int bufcnt;
+};
+
+struct rc_state_type *current_rc_state = NULL;
+
+/*
+ * this function tells if there is an if to terminate
+ * or not
+ */
+int
+build_receive_case_if_generated()
+{
+ if (!current_rc_state)
+ {
+ error ("internal error: RECEIVE CASE stack invalid.");
+ abort ();
+ }
+ return current_rc_state->if_generated;
+}
+
+/* build_receive_case_start returns an INTEGER_CST node
+ containing the case-label number to be used by
+ build_receive_case_end to generate correct labels */
+tree
+build_receive_case_start (optset)
+ tree optset;
+{
+ /* counter to generate unique receive_case labels */
+ static int rc_lbl_count = 0;
+ tree current_label_value =
+ build_int_2 ((HOST_WIDE_INT)rc_lbl_count, 0);
+ tree sigcodename, filename, linenumber;
+
+ struct rc_state_type *rc_state
+ = (struct rc_state_type*) xmalloc (sizeof (struct rc_state_type));
+ rc_state->rcdoit = gen_label_rtx ();
+ rc_state->rcsetup = gen_label_rtx ();
+ rc_state->enclosing = current_rc_state;
+ current_rc_state = rc_state;
+ rc_state->sigseen = 0;
+ rc_state->bufseen = 0;
+ rc_state->call_generated = 0;
+ rc_state->if_generated = 0;
+ rc_state->bufcnt = 0;
+
+ rc_lbl_count++;
+ if (optset == NULL_TREE || TREE_CODE (optset) == ERROR_MARK)
+ optset = null_pointer_node;
+ else
+ {
+ if (CH_IS_INSTANCE_MODE (TREE_TYPE (optset)) && CH_LOCATION_P (optset))
+ optset = force_addr_of (optset);
+ else
+ {
+ error ("SET requires INSTANCE location");
+ optset = null_pointer_node;
+ }
+ }
+
+ rc_state->to_loc = build_timeout_preface ();
+
+ rc_state->n_sigs =
+ decl_temp1 (get_identifier ("number_of_sigs"),
+ integer_type_node, 0, integer_zero_node, 0, 0);
+
+ rc_state->sig_code =
+ decl_temp1 (get_identifier ("sig_codep"),
+ ptr_type_node, 0, null_pointer_node, 0, 0);
+
+ rc_state->databufp =
+ decl_temp1 (get_identifier ("databufp"),
+ ptr_type_node, 0, null_pointer_node, 0, 0);
+
+ rc_state->datalen =
+ decl_temp1 (get_identifier ("datalen"),
+ integer_type_node, 0, integer_zero_node, 0, 0);
+
+ rc_state->else_clause =
+ decl_temp1 (get_identifier ("else_clause"),
+ integer_type_node, 0, integer_zero_node, 0, 0);
+
+ /* wait_signal will store the signal number in here */
+ sigcodename = get_identifier ("received_signal");
+ rc_state->received_signal =
+ decl_temp1 (sigcodename, chill_integer_type_node, 0,
+ NULL_TREE, 0, 0);
+
+ /* wait_buffer will store the buffer address in here */
+ sigcodename = get_unique_identifier ("received_buffer");
+ rc_state->received_buffer =
+ decl_temp1 (sigcodename, ptr_type_node, 0,
+ NULL_TREE, 0, 0);
+
+ /* now jump to the end of RECEIVE CASE actions, to
+ set up variables for them. */
+ emit_jump (rc_state->rcsetup);
+
+ /* define the __rcdoit label. We come here after
+ initialization of all variables, to execute the
+ actions. */
+ emit_label (rc_state->rcdoit);
+
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+
+ /* Argument list for calling the runtime routine. We'll call it
+ the first time we call build_receive_case_label, when we know
+ whether to call wait_signal or wait_buffer. NOTE: at this time
+ the first argument will be set. */
+ rc_state->actuallist =
+ tree_cons (NULL_TREE, NULL_TREE,
+ tree_cons (NULL_TREE, rc_state->n_sigs,
+ tree_cons (NULL_TREE, rc_state->sig_code,
+ tree_cons (NULL_TREE, rc_state->databufp,
+ tree_cons (NULL_TREE, rc_state->datalen,
+ tree_cons (NULL_TREE, optset,
+ tree_cons (NULL_TREE, rc_state->else_clause,
+ tree_cons (NULL_TREE, rc_state->to_loc,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE))))))))));
+ return current_label_value;
+}
+\f
+static tree
+build_receive_signal_case_label (sigdecl, loclist)
+ tree sigdecl, loclist;
+{
+ struct rc_state_type *rc_state = current_rc_state;
+ tree signame = DECL_NAME (sigdecl);
+ tree expr;
+
+ if (rc_state->bufseen != 0)
+ {
+ error ("SIGNAL in RECEIVE CASE alternative follows");
+ error (" a BUFFER name on line %d", rc_state->bufseen);
+ return error_mark_node;
+ }
+ rc_state->sigseen = lineno;
+ rc_state->bufseen = 0;
+
+ if (!IDENTIFIER_SIGNAL_DATA (signame) && loclist != NULL_TREE)
+ {
+ error ("SIGNAL `%s' has no data fields", IDENTIFIER_POINTER (signame));
+ return error_mark_node;
+ }
+ if (IDENTIFIER_SIGNAL_DATA (signame) && loclist == NULL_TREE)
+ {
+ error ("SIGNAL `%s' requires data fields", IDENTIFIER_POINTER (signame));
+ return error_mark_node;
+ }
+
+ if (!rc_state->call_generated)
+ {
+ tree wait_call;
+
+ TREE_VALUE (rc_state->actuallist) = force_addr_of (rc_state->received_signal);
+ wait_call = build_chill_function_call (lookup_name
+ (get_identifier ("__wait_signal_timed")),
+ rc_state->actuallist);
+#if 0
+ chill_expand_assignment (rc_state->received_signal,
+ NOP_EXPR, wait_call);
+#endif
+ build_timesupervised_call (wait_call, rc_state->to_loc);
+
+ rc_state->call_generated = 1;
+ }
+
+ /* build the conditional expression */
+ expr = build (EQ_EXPR, boolean_type_node,
+ rc_state->received_signal,
+ (tree)DECL_TASKING_CODE_DECL (sigdecl));
+
+ if (!rc_state->if_generated)
+ {
+ expand_start_cond (expr, 0);
+ rc_state->if_generated = 1;
+ }
+ else
+ expand_start_elseif (expr);
+
+ if (IDENTIFIER_SIGNAL_DATA (signame))
+ {
+ /* copy data from signal buffer to user's variables */
+ tree typelist = TYPE_FIELDS (TREE_TYPE (sigdecl));
+ tree valtail, typetail;
+ int parmno = 1;
+ tree pointer_type = build_chill_pointer_type (TREE_TYPE (sigdecl));
+ tree pointer = convert (pointer_type, rc_state->databufp);
+
+ for (valtail = nreverse (loclist), typetail = typelist;
+ valtail != NULL_TREE && typetail != NULL_TREE;
+ parmno++, valtail = TREE_CHAIN (valtail),
+ typetail = TREE_CHAIN (typetail))
+ {
+ register tree actual = valtail ? TREE_VALUE (valtail) : 0;
+ register tree type = typetail ? TREE_TYPE (typetail) : 0;
+ register tree assgn;
+ char place[30];
+ sprintf (place, "signal field %d", parmno);
+
+ assgn = build_component_ref (build1 (INDIRECT_REF,
+ TREE_TYPE (sigdecl),
+ pointer),
+ DECL_NAME (typetail));
+ if (!CH_TYPE_NONVALUE_P (type))
+ /* don't assign to non-value type. Error printed at signal definition */
+ chill_expand_assignment (actual, NOP_EXPR, assgn);
+ }
+
+ if (valtail == NULL_TREE && typetail != NULL_TREE)
+ error ("too few data fields provided for `%s'",
+ IDENTIFIER_POINTER (signame));
+ if (valtail != NULL_TREE && typetail == NULL_TREE)
+ error ("too many data fields provided for `%s'",
+ IDENTIFIER_POINTER (signame));
+ }
+
+ /* last action here */
+ emit_line_note (input_filename, lineno);
+
+ return build_tree_list (loclist, signame);
+}
+
+static tree
+build_receive_buffer_case_label (buffer, loclist)
+ tree buffer, loclist;
+{
+ struct rc_state_type *rc_state = current_rc_state;
+ tree buftype = buffer_element_mode (TREE_TYPE (buffer));
+ tree expr, var;
+ tree pointer_type, pointer, assgn;
+ int had_errors = 0;
+ tree x, y, z, bufaddr;
+
+ if (rc_state->sigseen != 0)
+ {
+ error ("BUFFER in RECEIVE CASE alternative follows");
+ error (" a SIGNAL name on line %d", rc_state->sigseen);
+ return error_mark_node;
+ }
+ rc_state->bufseen = lineno;
+ rc_state->sigseen = 0;
+
+ if (! CH_REFERABLE (buffer))
+ {
+ error ("BUFFER in RECEIVE CASE alternative must be a location.");
+ return error_mark_node;
+ }
+
+ if (TREE_CHAIN (loclist) != NULL_TREE)
+ {
+ error ("buffer receive alternative requires only 1 defining occurence.");
+ return error_mark_node;
+ }
+
+ if (!rc_state->call_generated)
+ {
+ tree wait_call;
+
+ /* here we change the mode of rc_state->sig_code to
+ REF ARRAY (0:65535) REF __tmp_DESCR_type.
+ This is neccesary, cause we cannot evaluate the buffer twice
+ (once here where we compare against the address of the buffer
+ and second in build_receive_buffer_case_end, where we use the
+ address build the descriptor, which gets passed to __wait_buffer).
+ So we change the comparison from
+ if (rc_state->received_buffer == &buffer)
+ to
+ if (rc_state->received_buffer ==
+ rc_state->sig_codep->[rc_state->bufcnt]->datap).
+
+ This will evaluate the buffer location only once
+ (in build_receive_buffer_case_end) and therefore doesn't confuse
+ our machinery. */
+
+ tree reftmpdescr = build_chill_pointer_type (
+ TREE_TYPE (lookup_name (
+ get_identifier ("__tmp_DESCR_type"))));
+ tree idxtype = build_chill_range_type (NULL_TREE,
+ integer_zero_node,
+ build_int_2 (65535, 0)); /* should be enough, probably use ULONG */
+ tree arrtype = build_chill_array_type (reftmpdescr,
+ tree_cons (NULL_TREE, idxtype, NULL_TREE),
+ 0, NULL_TREE);
+ tree refarrtype = build_chill_pointer_type (arrtype);
+
+ TREE_VALUE (rc_state->actuallist) = force_addr_of (rc_state->received_buffer);
+ wait_call = build_chill_function_call (
+ lookup_name (get_identifier ("__wait_buffer")),
+ rc_state->actuallist);
+#if 0
+ chill_expand_assignment (rc_state->received_buffer,
+ NOP_EXPR, wait_call);
+#endif
+ build_timesupervised_call (wait_call, rc_state->to_loc);
+
+ /* do this after the call, otherwise there will be a mode mismatch */
+ TREE_TYPE (rc_state->sig_code) = refarrtype;
+
+ /* now we are ready to generate the call */
+ rc_state->call_generated = 1;
+ }
+
+ x = build_chill_indirect_ref (rc_state->sig_code, NULL_TREE, 0);
+ y = build_chill_array_ref (x,
+ tree_cons (NULL_TREE, build_int_2 (rc_state->bufcnt, 0), NULL_TREE));
+ z = build_chill_indirect_ref (y, NULL_TREE, 0);
+ bufaddr = build_chill_component_ref (z, get_identifier ("datap"));
+
+ /* build the conditional expression */
+ expr = build (EQ_EXPR, boolean_type_node,
+ rc_state->received_buffer,
+ bufaddr);
+
+ /* next buffer in list */
+ rc_state->bufcnt++;
+
+ if (!rc_state->if_generated)
+ {
+ expand_start_cond (expr, 0);
+ rc_state->if_generated = 1;
+ }
+ else
+ expand_start_elseif (expr);
+
+ /* copy buffer's data to destination */
+ var = TREE_VALUE (loclist);
+
+ if (buftype != NULL_TREE && TREE_CODE (buftype) == ERROR_MARK)
+ had_errors = 1;
+ else if (! CH_COMPATIBLE (var, buftype))
+ {
+ error ("incompatible modes in receive buffer alternative.");
+ had_errors = 1;
+ }
+
+ if (! CH_LOCATION_P (var))
+ {
+ error ("defining occurence in receive buffer alternative must be a location.");
+ had_errors = 1;
+ }
+
+ if (! had_errors)
+ {
+ pointer_type = build_chill_pointer_type (TREE_TYPE (var));
+ pointer = convert (pointer_type,
+ rc_state->databufp);
+ /* no need to check this pointer being NULL */
+ assgn = build_chill_indirect_ref (pointer, NULL_TREE, 0);
+
+ chill_expand_assignment (var, NOP_EXPR, assgn);
+ }
+
+ /* last action here */
+ emit_line_note (input_filename, lineno);
+
+ return build_tree_list (loclist, buffer);
+}
+/*
+ * SIGNAME is the signal name or buffer location,
+ * LOCLIST is a list of possible locations to store data in
+ */
+tree
+build_receive_case_label (signame, loclist)
+ tree signame, loclist;
+{
+ /* now see what we have got and do some checks */
+ if (TREE_CODE (signame) == TYPE_DECL && CH_DECL_SIGNAL (signame))
+ return build_receive_signal_case_label (signame, loclist);
+
+ if (TREE_TYPE (signame) != NULL_TREE
+ && CH_IS_BUFFER_MODE (TREE_TYPE (signame)))
+ {
+ if (loclist == NULL_TREE)
+ {
+ error ("buffer receive alternative without `IN location'.");
+ return error_mark_node;
+ }
+ return build_receive_buffer_case_label (signame, loclist);
+ }
+
+ error ("RECEIVE CASE alternative must specify a SIGNAL name or BUFFER location.");
+ return error_mark_node;
+}
+\f
+/*
+ * LABEL_CNT is the case-label counter passed from build_receive_case_start.
+ * ELSE_CLAUSE defines if the RECEIVE CASE action had an ELSE(1) or not(0).
+ * BUF_LIST is a tree-list of tree-lists, where TREE_VALUE defines the
+ * BUFFER location and TREE_PURPOSE defines the defining occurence.
+ */
+static void
+build_receive_buffer_case_end (label_cnt, buf_list, else_clause)
+ tree label_cnt, buf_list, else_clause;
+{
+ struct rc_state_type *rc_state = current_rc_state;
+ tree alist;
+ tree field_decls = NULL_TREE; /* list of all buffer types, for the union */
+ int buffer_cnt = 0;
+ tree descr_type = lookup_name (get_identifier ("__tmp_DESCR_type"));
+ tree tuple = NULL_TREE; /* constructors for array of ptrs */
+ tree union_type_node = NULL_TREE;
+
+ /* walk thru all the buffers */
+ for (alist = buf_list; alist != NULL_TREE;
+ buffer_cnt++, alist = TREE_CHAIN (alist))
+ {
+ tree value = TREE_VALUE (alist);
+ tree buffer = TREE_VALUE (value); /* this is the buffer */
+ tree data = TREE_VALUE (TREE_PURPOSE (value)); /* the location to receive in */
+ tree buffer_descr;
+ tree buffer_descr_init;
+ tree buffer_length;
+ tree buffer_ptr;
+ tree field;
+ char fldname[20];
+
+ /* build descriptor for buffer */
+ buffer_length = max_queue_size (TREE_TYPE (buffer));
+ if (buffer_length == NULL_TREE)
+ buffer_length = infinite_buffer_event_length_node;
+ buffer_descr_init = build_nt (CONSTRUCTOR, NULL_TREE,
+ tree_cons (NULL_TREE, force_addr_of (buffer),
+ tree_cons (NULL_TREE, buffer_length, NULL_TREE)));
+ buffer_descr = decl_temp1 (get_unique_identifier ("RCbuffer"),
+ TREE_TYPE (descr_type), 0,
+ buffer_descr_init, 0, 0);
+ tuple = tree_cons (NULL_TREE,
+ force_addr_of (buffer_descr),
+ tuple);
+
+ /* make a field for the union */
+ sprintf (fldname, "fld%03d", buffer_cnt);
+ field = grok_chill_fixedfields (
+ tree_cons (NULL_TREE, get_identifier (fldname), NULL_TREE),
+ TREE_TYPE (data), NULL_TREE);
+ if (field_decls == NULL_TREE)
+ field_decls = field;
+ else
+ chainon (field_decls, field);
+ }
+
+ /* generate the union */
+ if (field_decls != NULL_TREE)
+ {
+ tree data_id = get_identifier ("databuffer");
+ tree data_decl;
+
+ union_type_node = finish_struct (
+ start_struct (UNION_TYPE, NULL_TREE),
+ field_decls);
+ data_decl = decl_temp1 (data_id, union_type_node, 0, NULL_TREE, 0, 0);
+
+ chill_expand_assignment (rc_state->databufp, NOP_EXPR,
+ force_addr_of (data_decl));
+
+ chill_expand_assignment (rc_state->datalen, NOP_EXPR,
+ size_in_bytes (TREE_TYPE (data_decl)));
+ }
+
+ /* tell runtime system if we had an else or not */
+ chill_expand_assignment (rc_state->else_clause, NOP_EXPR, else_clause);
+
+ /* generate the array of pointers to all buffers */
+ {
+ tree array_id = get_identifier ("buf_ptr_array");
+ tree array_type_node =
+ build_chill_array_type (ptr_type_node,
+ tree_cons (NULL_TREE,
+ build_chill_range_type (NULL_TREE,
+ integer_one_node,
+ build_int_2 (buffer_cnt, 0)),
+ NULL_TREE),
+ 0, NULL_TREE);
+ tree constr = build_nt (CONSTRUCTOR, NULL_TREE, nreverse (tuple));
+ tree array_decl = decl_temp1 (array_id, array_type_node, 0,
+ constr, 0, 0);
+
+ chill_expand_assignment (build_chill_cast (ptr_type_node, rc_state->sig_code),
+ NOP_EXPR,
+ force_addr_of (array_decl));
+ chill_expand_assignment (rc_state->n_sigs, NOP_EXPR,
+ build_int_2 (buffer_cnt, 0));
+ }
+}
+
+/*
+ * SIG_LIST is a tree list. The TREE_VALUEs are VAR_DECLs of
+ * __tmp_%s_code variables, and the TREE_PURPOSEs are the
+ * TYPE_DECLs of the __tmp_%s_struct types. LABEL_CNT is the
+ * case-label counter passed from build_receive_case_start.
+ */
+static void
+build_receive_signal_case_end (label_cnt, sig_list, else_clause)
+ tree label_cnt, sig_list, else_clause;
+{
+ struct rc_state_type *rc_state = current_rc_state;
+ tree alist, temp1;
+ tree union_type_node = NULL_TREE;
+ tree field_decls = NULL_TREE; /* list of signal
+ structure, for the union */
+ tree tuple = NULL_TREE; /* constructor for array of ptrs */
+ int signal_cnt = 0;
+ int fldcnt = 0;
+
+ /* for each list of locations, validate it against the
+ corresponding signal's list of fields. */
+ {
+ for (alist = sig_list; alist != NULL_TREE;
+ signal_cnt++, alist = TREE_CHAIN (alist))
+ {
+ tree value = TREE_VALUE (alist);
+ tree signame = TREE_VALUE (value); /* signal's ID node */
+ tree sigdecl = lookup_name (signame);
+ tree sigtype = TREE_TYPE (sigdecl);
+ tree field;
+ char fldname[20];
+
+ if (IDENTIFIER_SIGNAL_DATA (signame))
+ {
+ sprintf (fldname, "fld%03d", fldcnt++);
+ field = grok_chill_fixedfields (
+ tree_cons (NULL_TREE,
+ get_identifier (fldname),
+ NULL_TREE),
+ sigtype, NULL_TREE);
+ if (field_decls == NULL_TREE)
+ field_decls = field;
+ else
+ chainon (field_decls, field);
+
+ }
+
+ temp1 = (tree)DECL_TASKING_CODE_DECL (sigdecl);
+ mark_addressable (temp1);
+ tuple = tree_cons (NULL_TREE,
+ build1 (ADDR_EXPR,
+ build_chill_pointer_type (chill_integer_type_node),
+ temp1),
+ tuple);
+ }
+ }
+
+ /* generate the union of all of the signal data types */
+ if (field_decls != NULL_TREE)
+ {
+ tree data_id = get_identifier ("databuffer");
+ tree data_decl;
+ union_type_node = finish_struct (start_struct (UNION_TYPE,
+ NULL_TREE),
+ field_decls);
+ data_decl =
+ decl_temp1 (data_id, union_type_node, 0, NULL_TREE, 0, 0);
+
+ chill_expand_assignment (rc_state->databufp, NOP_EXPR,
+ force_addr_of (data_decl));
+
+ chill_expand_assignment (rc_state->datalen, NOP_EXPR,
+ size_in_bytes (TREE_TYPE (data_decl)));
+ }
+
+ /* tell runtime system if we had an else or not */
+ chill_expand_assignment (rc_state->else_clause, NOP_EXPR, else_clause);
+
+ /* generate the array of all signal codes */
+ {
+ tree array_id = get_identifier ("sig_code_array");
+ tree array_type_node
+ = build_chill_array_type (
+ build_chill_pointer_type (chill_integer_type_node),
+ tree_cons (NULL_TREE,
+ build_chill_range_type (NULL_TREE,
+ integer_one_node,
+ build_int_2 (signal_cnt, 0)),
+ NULL_TREE),
+ 0, NULL_TREE);
+ tree constr = build_nt (CONSTRUCTOR, NULL_TREE,
+ nreverse (tuple));
+ tree array_decl =
+ decl_temp1 (array_id, array_type_node, 0, constr, 0, 0);
+
+ chill_expand_assignment (rc_state->sig_code, NOP_EXPR,
+ force_addr_of (array_decl));
+
+ /* give number of signals to runtime system */
+ chill_expand_assignment (rc_state->n_sigs, NOP_EXPR,
+ build_int_2 (signal_cnt, 0));
+ }
+}
+
+/* General function for the end of a RECEIVE CASE action */
+
+void
+build_receive_case_end (label_cnt, alist, else_clause)
+ tree label_cnt, alist, else_clause;
+{
+ rtx rcdone = gen_label_rtx ();
+ struct rc_state_type *rc_state = current_rc_state;
+ tree tmp;
+ int had_errors = 0;
+
+ /* finish the if's, if generated */
+ if (rc_state->if_generated)
+ expand_end_cond ();
+
+ /* check alist for errors */
+ for (tmp = alist; tmp != NULL_TREE; tmp = TREE_CHAIN (tmp))
+ {
+ if (TREE_CODE (TREE_VALUE (tmp)) == ERROR_MARK)
+ had_errors++;
+ }
+
+ /* jump to the end of RECEIVE CASE processing */
+ emit_jump (rcdone);
+
+ /* define the __rcsetup label. We come here to initialize
+ all variables */
+ emit_label (rc_state->rcsetup);
+
+ if (alist == NULL_TREE && !had_errors)
+ {
+ error ("RECEIVE CASE without alternatives");
+ goto gen_rcdoit;
+ }
+
+ if (TREE_CODE (alist) == ERROR_MARK || had_errors)
+ goto gen_rcdoit;
+
+ /* now call the actual end function */
+ if (rc_state->bufseen)
+ build_receive_buffer_case_end (label_cnt, alist, else_clause);
+ else
+ build_receive_signal_case_end (label_cnt, alist, else_clause);
+
+ /* now jump to the beginning of RECEIVE CASE processing */
+gen_rcdoit: ;
+ emit_jump (rc_state->rcdoit);
+
+ /* define the __rcdone label. We come here when the whole
+ receive case is done. */
+ emit_label (rcdone);
+
+ current_rc_state = rc_state->enclosing;
+ free(rc_state);
+}
+\f
+/* build a CONTINUE action */
+
+void expand_continue_event (evloc)
+ tree evloc;
+{
+ tree filename, linenumber, evaddr;
+
+ /* do some checks */
+ if (evloc == NULL_TREE || TREE_CODE (evloc) == ERROR_MARK)
+ return;
+
+ if (! CH_REFERABLE (evloc) || ! CH_IS_EVENT_MODE (TREE_TYPE (evloc)))
+ {
+ error ("CONTINUE requires an event location.");
+ return;
+ }
+
+ evaddr = force_addr_of (evloc);
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (get_identifier ("__continue")),
+ tree_cons (NULL_TREE, evaddr,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE)))));
+}
+\f
+#if 0
+ * The following code builds a DELAY CASE statement,
+ * which looks like this in CHILL:
+ *
+ * DCL ev1, ev2 EVENT, ins INSTANCE;
+ * DCL ev3 EVENT (10);
+ * DCL count1 INT := 0, count2 INT := 0;
+ *
+ * DELAY CASE SET ins;
+ * (ev1): count1 +:= 1;
+ * (ev2, ev3): count2 +:= 1;
+ * ESAC;
+ *
+ * Because we don''t know until we get to the ESAC how
+ * many events need processing, we generate the following
+ * C-equivalent code:
+ *
+ *
+ * { /* start a new symbol context */
+ * typedef struct
+ * {
+ * void *p;
+ * unsigned long len;
+ * } Descr;
+ * int number_of_events;
+ * Descr *event_codes;
+ *
+ * goto __dlsetup;
+ *
+ * __dldoit:
+ * void *whatevent = __delay_event (number_of_events,
+ * event_codes,
+ * priority,
+ * &instance_loc,
+ * filename,
+ * linenumber);
+ * if (whatevent == &ev1)
+ * {
+ * /* code for ev1 alternative's action_statement_list */
+ * count1 += 1;
+ * }
+ * else if (whatevent == &ev2 || whatevent == &ev3)
+ * {
+ * /* code for ev2 and ev3 alternative's action_statement_list */
+ * count2 += 1;
+ * }
+ * goto __dl_done;
+ *
+ * __dlsetup:
+ * Descr event_code_ptr [3] = {
+ * { &ev1, -1 },
+ * { &ev2, -1 },
+ * { &ev3, 10 } };
+ * event_codes = &event_code_ptr[0];
+ * number_of_events = 3;
+ * goto __dldoit;
+ *
+ * __dl_done:
+ * ;
+ * } /* end the new symbol context */
+ *
+#endif
+\f
+struct dl_state_type
+{
+ struct dl_state_type *enclosing;
+ rtx dldoit;
+ rtx dlsetup;
+ tree n_events;
+ tree event_codes;
+ tree received_event;
+};
+
+struct dl_state_type *current_dl_state = NULL;
+
+/* build_receive_case_start returns an INTEGER_CST node
+ containing the case-label number to be used by
+ build_receive_case_end to generate correct labels */
+tree
+build_delay_case_start (optset, optpriority)
+ tree optset, optpriority;
+{
+ /* counter to generate unique delay case labels */
+ static int dl_lbl_count = 0;
+ tree current_label_value =
+ build_int_2 ((HOST_WIDE_INT)dl_lbl_count, 0);
+ tree wait_call;
+ tree actuallist = NULL_TREE;
+ tree filename, linenumber;
+ tree to_loc;
+
+ struct dl_state_type *dl_state
+ = (struct dl_state_type*) xmalloc (sizeof (struct dl_state_type));
+ dl_state->enclosing = current_dl_state;
+ current_dl_state = dl_state;
+ dl_state->dldoit = gen_label_rtx ();
+ dl_state->dlsetup = gen_label_rtx ();
+
+ dl_lbl_count++;
+
+ /* check the optional SET location */
+ if (optset == NULL_TREE
+ || TREE_CODE (optset) == ERROR_MARK)
+ optset = null_pointer_node;
+ else if (CH_IS_INSTANCE_MODE (TREE_TYPE (optset)) && CH_LOCATION_P (optset))
+ optset = force_addr_of (optset);
+ else
+ {
+ error ("SET requires INSTANCE location");
+ optset = null_pointer_node;
+ }
+
+ /* check the presence of the PRIORITY expression */
+ if (optpriority == NULL_TREE)
+ optpriority = integer_zero_node;
+ else if (TREE_CODE (optpriority) == ERROR_MARK)
+ optpriority = integer_zero_node;
+ else if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE)
+ {
+ error ("PRIORITY must be of integer type.");
+ optpriority = integer_zero_node;
+ }
+
+ /* check for time supervised */
+ to_loc = build_timeout_preface ();
+
+ dl_state->n_events =
+ decl_temp1 (get_identifier ("number_of_events"),
+ integer_type_node, 0, integer_zero_node, 0, 0);
+
+ dl_state->event_codes =
+ decl_temp1 (get_identifier ("event_codes"),
+ ptr_type_node, 0, null_pointer_node, 0, 0);
+
+ /* wait_event will store the signal number in here */
+ dl_state->received_event =
+ decl_temp1 (get_identifier ("received_event"),
+ ptr_type_node, 0, NULL_TREE, 0, 0);
+
+ /* now jump to the end of RECEIVE CASE actions, to
+ set up variables for them. */
+ emit_jump (dl_state->dlsetup);
+
+ /* define the __rcdoit label. We come here after
+ initialization of all variables, to execute the
+ actions. */
+ emit_label (dl_state->dldoit);
+
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+
+ /* here we go, call the runtime routine */
+ actuallist = tree_cons (NULL_TREE, force_addr_of (dl_state->received_event),
+ tree_cons (NULL_TREE, dl_state->n_events,
+ tree_cons (NULL_TREE, dl_state->event_codes,
+ tree_cons (NULL_TREE, optpriority,
+ tree_cons (NULL_TREE, to_loc,
+ tree_cons (NULL_TREE, optset,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE))))))));
+
+ wait_call = build_chill_function_call (
+ lookup_name (get_identifier ("__delay_event")),
+ actuallist);
+
+#if 0
+ chill_expand_assignment (dl_state->received_event, NOP_EXPR, wait_call);
+#endif
+ build_timesupervised_call (wait_call, to_loc);
+ return current_label_value;
+}
+\f
+/*
+ EVENTLIST is the list of this alternative's events
+ and IF_OR_ELSEIF indicates what action (1 for if and
+ 0 for else if) should be generated.
+*/
+void
+build_delay_case_label (eventlist, if_or_elseif)
+ tree eventlist;
+ int if_or_elseif;
+{
+ tree eventp, expr = NULL_TREE;
+
+ if (eventlist == NULL_TREE || TREE_CODE (eventlist) == ERROR_MARK)
+ return;
+
+ for (eventp = eventlist; eventp != NULL_TREE;
+ eventp = TREE_CHAIN (eventp))
+ {
+ tree event = TREE_VALUE (eventp);
+ tree temp1;
+
+ if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK)
+ temp1 = null_pointer_node;
+ else if (! CH_IS_EVENT_MODE (TREE_TYPE (event)) || ! CH_REFERABLE (event))
+ {
+ error ("delay alternative must be an EVENT location.");
+ temp1 = null_pointer_node;
+ }
+ else
+ temp1 = force_addr_of (event);
+
+ /* build the conditional expression */
+ if (expr == NULL_TREE)
+ expr = build (EQ_EXPR, boolean_type_node,
+ current_dl_state->received_event, temp1);
+ else
+ expr =
+ build (TRUTH_ORIF_EXPR, boolean_type_node, expr,
+ build (EQ_EXPR, boolean_type_node,
+ current_dl_state->received_event, temp1));
+ }
+ if (if_or_elseif)
+ expand_start_cond (expr, 0);
+ else
+ expand_start_elseif (expr);
+
+ /* last action here */
+ emit_line_note (input_filename, lineno);
+}
+\f
+/*
+ * EVENT_LIST is a tree list. The TREE_VALUEs are VAR_DECLs of
+ * EVENT variables. LABEL_CNT is the case-label counter
+ * passed from build_delay_case_start.
+ */
+void
+build_delay_case_end (label_cnt, event_list)
+ tree label_cnt, event_list;
+{
+ struct dl_state_type *dl_state = current_dl_state;
+ rtx dldone = gen_label_rtx ();
+ tree tuple = NULL_TREE; /* constructor for array of descrs */
+ tree acode;
+ int event_cnt = 0;
+
+ /* if we have an empty event_list, there was no alternatives and we
+ havn't started an if therefor don't run expand_end_cond */
+ if (event_list != NULL_TREE)
+ /* finish the if's */
+ expand_end_cond ();
+
+ /* jump to the end of RECEIVE CASE processing */
+ emit_jump (dldone);
+
+ /* define the __dlsetup label. We come here to initialize
+ all variables */
+ emit_label (dl_state->dlsetup);
+
+ if (event_list == NULL_TREE)
+ {
+ error ("DELAY CASE without alternatives");
+ goto gen_dldoit;
+ }
+
+ if (event_list == NULL_TREE
+ || TREE_CODE (event_list) == ERROR_MARK)
+ goto gen_dldoit;
+
+ /* make a list of pointers (in reverse order)
+ to the event code variables */
+ for (acode = event_list; acode != NULL_TREE;
+ acode = TREE_CHAIN (acode))
+ {
+ tree event = TREE_VALUE (acode);
+ tree event_length;
+ tree descr_init;
+
+ if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK)
+ {
+ descr_init =
+ tree_cons (NULL_TREE, null_pointer_node,
+ tree_cons (NULL_TREE, integer_zero_node, NULL_TREE));
+ }
+ else
+ {
+ event_length = max_queue_size (TREE_TYPE (event));
+ if (event_length == NULL_TREE)
+ event_length = infinite_buffer_event_length_node;
+ descr_init =
+ tree_cons (NULL_TREE, force_addr_of (event),
+ tree_cons (NULL_TREE, event_length, NULL_TREE));
+ }
+ tuple = tree_cons (NULL_TREE,
+ build_nt (CONSTRUCTOR, NULL_TREE, descr_init),
+ tuple);
+ event_cnt++;
+ }
+
+ /* generate the array of all event code pointers */
+ {
+ tree descr_type = TREE_TYPE (lookup_name (get_identifier ("__tmp_DESCR_type")));
+ tree array_id = get_identifier ("event_code_array");
+ tree array_type_node
+ = build_chill_array_type (descr_type,
+ tree_cons (NULL_TREE,
+ build_chill_range_type (NULL_TREE,
+ integer_one_node,
+ build_int_2 (event_cnt, 0)),
+ NULL_TREE),
+ 0, NULL_TREE);
+ tree constr = build_nt (CONSTRUCTOR, NULL_TREE,
+ nreverse (tuple));
+ tree array_decl =
+ decl_temp1 (array_id, array_type_node, 0, constr, 0, 0);
+
+ chill_expand_assignment (dl_state->event_codes, NOP_EXPR,
+ force_addr_of (array_decl));
+
+ /* give number of signals to runtime system */
+ chill_expand_assignment (dl_state->n_events, NOP_EXPR,
+ build_int_2 (event_cnt, 0));
+ }
+
+ /* now jump to the beginning of DELAY CASE processing */
+gen_dldoit:
+ emit_jump (dl_state->dldoit);
+
+ /* define the __dldone label. We come here when the whole
+ DELAY CASE is done. */
+ emit_label (dldone);
+
+ current_dl_state = dl_state->enclosing;
+ free(dl_state);
+}
+\f
+#if 0
+ * The following code builds a simple delay statement,
+ * which looks like this in CHILL:
+ *
+ * DCL ev1 EVENT(5), ins INSTANCE;
+ *
+ * DELAY ev1 PRIORITY 7;
+ *
+ * This statement unconditionally delays the current
+ * PROCESS, until some other process CONTINUEs it.
+ *
+ * Here is the generated C code:
+ *
+ * typedef struct
+ * {
+ * void *p;
+ * unsigned long len;
+ * } Descr;
+ *
+ * static short __tmp_ev1_code;
+ *
+ * { /* start a new symbol context */
+ *
+ * Descr __delay_array[1] = { { ev1, 5 } };
+ *
+ * __delay_event (1, &__delay_array, 7, NULL,
+ * filename, linenumber);
+ *
+ * } /* end of symbol scope */
+ */
+#endif
+void
+build_delay_action (event, optpriority)
+ tree event, optpriority;
+{
+ int had_errors = 0;
+ tree to_loc = NULL_TREE;
+ /* we discard the return value of __delay_event, cause in
+ a normal DELAY action no selections have to be made */
+ tree ev_got = null_pointer_node;
+
+ /* check the event */
+ if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK)
+ had_errors = 1;
+ else if (! CH_IS_EVENT_MODE (TREE_TYPE (event)) || ! CH_REFERABLE (event))
+ {
+ error ("DELAY action requires an event location.");
+ had_errors = 1;
+ }
+
+ /* check the presence of priority */
+ if (optpriority != NULL_TREE)
+ {
+ if (TREE_CODE (optpriority) == ERROR_MARK)
+ return;
+ if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE)
+ {
+ error ("PRIORITY in DELAY action must be of integer type.");
+ return;
+ }
+ }
+ else
+ {
+ /* issue a warning in case of -Wall */
+ if (extra_warnings)
+ {
+ warning ("DELAY action without priority.");
+ warning (" PRIORITY defaulted to 0.");
+ }
+ optpriority = integer_zero_node;
+ }
+ if (had_errors)
+ return;
+
+ {
+ tree descr_type;
+ tree array_type_node;
+ tree array_decl;
+ tree descr_init;
+ tree array_init;
+ tree event_length = max_queue_size (TREE_TYPE (event));
+ tree event_codes;
+ tree filename = force_addr_of (get_chill_filename ());
+ tree linenumber = get_chill_linenumber ();
+ tree actuallist;
+
+ to_loc = build_timeout_preface ();
+
+ descr_type = TREE_TYPE (lookup_name (get_identifier ("__tmp_DESCR_type")));
+
+ array_type_node =
+ build_chill_array_type (descr_type,
+ tree_cons (NULL_TREE,
+ build_chill_range_type (NULL_TREE, integer_one_node,
+ integer_one_node),
+ NULL_TREE),
+ 0, NULL_TREE);
+ if (event_length == NULL_TREE)
+ event_length = infinite_buffer_event_length_node;
+
+ descr_init =
+ tree_cons (NULL_TREE, force_addr_of (event),
+ tree_cons (NULL_TREE, event_length, NULL_TREE));
+ array_init =
+ tree_cons (NULL_TREE,
+ build_nt (CONSTRUCTOR, NULL_TREE, descr_init),
+ NULL_TREE);
+ array_decl =
+ decl_temp1 (get_unique_identifier ("event_codes_array"),
+ array_type_node, 0,
+ build_nt (CONSTRUCTOR, NULL_TREE, array_init),
+ 0, 0);
+
+ event_codes =
+ decl_temp1 (get_unique_identifier ("event_ptr"),
+ ptr_type_node, 0,
+ force_addr_of (array_decl),
+ 0, 0);
+
+ actuallist =
+ tree_cons (NULL_TREE, ev_got,
+ tree_cons (NULL_TREE, integer_one_node,
+ tree_cons (NULL_TREE, event_codes,
+ tree_cons (NULL_TREE, optpriority,
+ tree_cons (NULL_TREE, to_loc,
+ tree_cons (NULL_TREE, null_pointer_node,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE))))))));
+
+
+ build_timesupervised_call (
+ build_chill_function_call (
+ lookup_name (get_identifier ("__delay_event")),
+ actuallist), to_loc);
+ }
+}
+\f
+void
+expand_send_buffer (buffer, value, optpriority, optwith, optto)
+ tree buffer, value, optpriority, optwith, optto;
+{
+ tree filename, linenumber;
+ tree buffer_mode_decl = NULL_TREE;
+ tree buffer_ptr, value_ptr;
+ int had_errors = 0;
+ tree timeout_value, fcall;
+
+ /* check buffer location */
+ if (buffer == NULL_TREE || TREE_CODE (buffer) == ERROR_MARK)
+ {
+ buffer = NULL_TREE;
+ had_errors = 1;
+ }
+ if (buffer != NULL_TREE)
+ {
+ if (! CH_IS_BUFFER_MODE (TREE_TYPE (buffer)) || ! CH_REFERABLE (buffer))
+ {
+ error ("send buffer action requires a BUFFER location.");
+ had_errors = 1;
+ }
+ else
+ buffer_mode_decl = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (buffer)));
+ }
+
+ /* check value and type */
+ if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK)
+ {
+ had_errors = 1;
+ value = NULL_TREE;
+ }
+ if (value != NULL_TREE)
+ {
+ if (TREE_CHAIN (value) != NULL_TREE)
+ {
+ error ("there must be only 1 value for send buffer action.");
+ had_errors = 1;
+ }
+ else
+ {
+ value = TREE_VALUE (value);
+ if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK)
+ {
+ had_errors = 1;
+ value = NULL_TREE;
+ }
+ if (value != NULL_TREE && buffer_mode_decl != NULL_TREE)
+ {
+ if (TREE_TYPE (buffer_mode_decl) != NULL_TREE &&
+ TREE_CODE (TREE_TYPE (buffer_mode_decl)) == ERROR_MARK)
+ had_errors = 1;
+ else if (CH_COMPATIBLE (value, TREE_TYPE (buffer_mode_decl)))
+ {
+ value = convert (TREE_TYPE (buffer_mode_decl), value);
+ if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK)
+ {
+ error ("convert failed for send buffer action.");
+ had_errors = 1;
+ }
+ }
+ else
+ {
+ error ("incompatible modes in send buffer action.");
+ had_errors = 1;
+ }
+ }
+ }
+ }
+
+ /* check the presence of priority */
+ if (optpriority == NULL_TREE)
+ {
+ if (send_buffer_prio == NULL_TREE)
+ {
+ /* issue a warning in case of -Wall */
+ if (extra_warnings)
+ {
+ warning ("Buffer sent without priority");
+ warning (" and no default priority was set.");
+ warning (" PRIORITY defaulted to 0.");
+ }
+ optpriority = integer_zero_node;
+ }
+ else
+ optpriority = send_buffer_prio;
+ }
+ else if (TREE_CODE (optpriority) == ERROR_MARK)
+ had_errors = 1;
+ else if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE)
+ {
+ error ("PRIORITY must be of integer type.");
+ had_errors = 1;
+ }
+
+ if (optwith != NULL_TREE)
+ {
+ error ("WITH not allowed for send buffer action.");
+ had_errors = 1;
+ }
+ if (optto != NULL_TREE)
+ {
+ error ("TO not allowed for send buffer action.");
+ had_errors = 1;
+ }
+ if (had_errors)
+ return;
+
+ {
+ tree descr_type;
+ tree buffer_descr, buffer_init, buffer_length;
+ tree val;
+
+ /* process timeout */
+ timeout_value = build_timeout_preface ();
+
+ descr_type = lookup_name (get_identifier ("__tmp_DESCR_type"));
+
+ /* build descr for buffer */
+ buffer_length = max_queue_size (TREE_TYPE (buffer));
+ if (buffer_length == NULL_TREE)
+ buffer_length = infinite_buffer_event_length_node;
+ buffer_init = build_nt (CONSTRUCTOR, NULL_TREE,
+ tree_cons (NULL_TREE, force_addr_of (buffer),
+ tree_cons (NULL_TREE, buffer_length, NULL_TREE)));
+ buffer_descr = decl_temp1 (get_unique_identifier ("buffer_descr"),
+ TREE_TYPE (descr_type), 0, buffer_init,
+ 0, 0);
+ buffer_ptr = decl_temp1 (get_unique_identifier ("buffer_ptr"),
+ ptr_type_node, 0,
+ force_addr_of (buffer_descr),
+ 0, 0);
+
+ /* build descr for value */
+ if (! CH_REFERABLE (value))
+ val = decl_temp1 (get_identifier ("buffer_value"),
+ TREE_TYPE (value), 0,
+ value, 0, 0);
+ else
+ val = value;
+
+ value_ptr = build_chill_descr (val);
+
+ }
+
+ /* get filename and linenumber */
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+
+ /* Now, we can call the runtime */
+ fcall = build_chill_function_call (
+ lookup_name (get_identifier ("__send_buffer")),
+ tree_cons (NULL_TREE, buffer_ptr,
+ tree_cons (NULL_TREE, value_ptr,
+ tree_cons (NULL_TREE, optpriority,
+ tree_cons (NULL_TREE, timeout_value,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE)))))));
+ build_timesupervised_call (fcall, timeout_value);
+}
+# if 0
+\f
+void
+process_buffer_decls (namelist, mode, optstatic)
+ tree namelist, mode;
+ int optstatic;
+{
+ tree names;
+ int quasi_flag = current_module->is_spec_module;
+
+ if (pass < 2)
+ return;
+
+ for (names = namelist; names != NULL_TREE; names = TREE_CHAIN (names))
+ {
+ tree name = TREE_VALUE (names);
+ tree bufdecl = lookup_name (name);
+ tree code_decl =
+ decl_tasking_code_variable (name, &buffer_code, quasi_flag);
+
+ /* remember the code variable in the buffer decl */
+ DECL_TASKING_CODE_DECL (bufdecl) = (struct lang_decl *)code_decl;
+
+ add_taskstuff_to_list (code_decl, "_TT_Buffer",
+ quasi_flag ? NULL_TREE : buffer_code,
+ bufdecl);
+ }
+}
+#endif
+\f
+/*
+ * if no queue size was specified, QUEUESIZE is integer_zero_node.
+ */
+tree
+build_buffer_type (element_type, queuesize)
+ tree element_type, queuesize;
+{
+ tree type, field;
+ if (element_type == NULL_TREE || TREE_CODE (element_type) == ERROR_MARK)
+ return error_mark_node;
+ if (queuesize != NULL_TREE && TREE_CODE (queuesize) == ERROR_MARK)
+ return error_mark_node;
+
+ type = make_node (RECORD_TYPE);
+ field = build_decl (FIELD_DECL, get_identifier("__buffer_data"),
+ ptr_type_node);
+ TYPE_FIELDS (type) = field;
+ TREE_CHAIN (field)
+ = build_lang_decl (TYPE_DECL, get_identifier ("__element_mode"),
+ element_type);
+ field = TREE_CHAIN (field);
+ if (queuesize)
+ {
+ tree size_field = build_decl (CONST_DECL, get_identifier("__queue_max"),
+ integer_type_node);
+ DECL_INITIAL (size_field) = queuesize;
+ TREE_CHAIN (field) = size_field;
+ }
+ CH_IS_BUFFER_MODE (type) = 1;
+ CH_TYPE_NONVALUE_P (type) = 1;
+ if (pass == 2)
+ type = layout_chill_struct_type (type);
+ return type;
+}
+\f
+#if 0
+tree
+build_buffer_descriptor (bufname, expr, optpriority)
+ tree bufname, expr, optpriority;
+{
+ tree bufdecl;
+
+ if (bufname == NULL_TREE
+ || TREE_CODE (bufname) == ERROR_MARK)
+ return error_mark_node;
+
+ if (expr != NULL_TREE
+ && TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+#if 0
+/* FIXME: is this what we really want to test? */
+ bufdecl = lookup_name (bufname);
+ if (TREE_CODE (bufdecl) != TYPE_DECL
+ || ! CH_IS_BUFFER_MODE (TREE_TYPE (bufdecl)))
+ {
+ error ("SEND requires a BUFFER; `%s' is not a BUFFER name",
+ bufname);
+ return error_mark_node;
+ }
+#endif
+ {
+ /* build buffer/signal data structure */
+ tree bufdataname = get_unique_identifier (IDENTIFIER_POINTER (bufname));
+ tree dataptr;
+
+ if (expr == NULL_TREE)
+ dataptr = null_pointer_node;
+ else
+ {
+ tree decl =
+ decl_temp1 (bufdataname, TREE_TYPE (bufdecl), 0,
+ expr, 0, 0);
+ /* prevent granting of this variable */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ dataptr = force_addr_of (decl);
+ }
+
+ /* build descriptor pointing to buffer data */
+ {
+ tree tasking_message_var = get_unique_identifier (IDENTIFIER_POINTER (bufname));
+ tree data_len = (expr == NULL_TREE) ? integer_zero_node :
+ size_in_bytes (TREE_TYPE (bufdecl));
+ tree tasking_code = (tree)DECL_TASKING_CODE_DECL (bufdecl);
+ tree tuple = build_nt (CONSTRUCTOR, NULL_TREE,
+ tree_cons (NULL_TREE,
+ build1 (ADDR_EXPR,
+ build_chill_pointer_type (chill_integer_type_node),
+ tasking_code),
+ tree_cons (NULL_TREE, data_len,
+ tree_cons (NULL_TREE, dataptr, NULL_TREE))));
+
+ tree decl = decl_temp1 (tasking_message_var,
+ TREE_TYPE (tasking_message_type), 0,
+ tuple, 0, 0);
+ mark_addressable (tasking_code);
+ /* prevent granting of this variable */
+ DECL_SOURCE_LINE (decl) = 0;
+
+ tuple = force_addr_of (decl);
+ return tuple;
+ }
+ }
+}
+#endif
+\f
+#if 0
+void
+process_event_decls (namelist, mode, optstatic)
+ tree namelist, mode;
+ int optstatic;
+{
+ tree names;
+ int quasi_flag = current_module->is_spec_module;
+
+ if (pass < 2)
+ return;
+
+ for (names = namelist; names != NULL_TREE; names = TREE_CHAIN (names))
+ {
+ tree name = TREE_VALUE (names);
+ tree eventdecl = lookup_name (name);
+ tree code_decl =
+ decl_tasking_code_variable (name, &event_code, quasi_flag);
+
+ /* remember the code variable in the event decl */
+ DECL_TASKING_CODE_DECL (eventdecl) = (struct lang_decl *)code_decl;
+
+ add_taskstuff_to_list (code_decl, "_TT_Event",
+ quasi_flag ? NULL_TREE : event_code,
+ eventdecl);
+ }
+}
+#endif
+\f
+/* Return the buffer or event length of a buffer or event mode.
+ (NULL_TREE means unlimited.) */
+
+tree
+max_queue_size (mode)
+ tree mode;
+{
+ tree field = TYPE_FIELDS (mode);
+ for ( ; field != NULL_TREE ; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == CONST_DECL)
+ return DECL_INITIAL (field);
+ }
+ return NULL_TREE;
+}
+
+/* Return the buffer element mode of a buffer mode. */
+
+tree
+buffer_element_mode (bufmode)
+ tree bufmode;
+{
+ tree field = TYPE_FIELDS (bufmode);
+ for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == TYPE_DECL)
+ return TREE_TYPE (field);
+ }
+ return NULL_TREE;
+}
+
+/* invalidate buffer element mode in case we detect, that the
+ elelment mode has the non-value property */
+
+void
+invalidate_buffer_element_mode (bufmode)
+ tree bufmode;
+{
+ tree field = TYPE_FIELDS (bufmode);
+ for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == TYPE_DECL)
+ {
+ TREE_TYPE (field) = error_mark_node;
+ return;
+ }
+ }
+}
+
+/* For an EVENT or BUFFER mode TYPE, with a give maximum queue size QSIZE,
+ perform various error checks. Return a new queue size. */
+
+tree
+check_queue_size (type, qsize)
+ tree type, qsize;
+{
+ if (qsize == NULL_TREE || TREE_CODE (qsize) == ERROR_MARK)
+ return qsize;
+ if (TREE_TYPE (qsize) == NULL_TREE
+ || !CH_SIMILAR (TREE_TYPE (qsize), integer_type_node))
+ {
+ error ("non-integral max queue size for EVENT/BUFFER mode");
+ return integer_one_node;
+ }
+ if (TREE_CODE (qsize) != INTEGER_CST)
+ {
+ error ("non-constant max queue size for EVENT/BUFFER mode");
+ return integer_one_node;
+ }
+ if (compare_int_csts (pedantic ? LE_EXPR : LT_EXPR,
+ qsize,
+ integer_zero_node))
+ {
+ error ("max queue_size for EVENT/BUFFER is not positive");
+ return integer_one_node;
+ }
+ return qsize;
+}
+
+/*
+ * An EVENT type is modelled as a boolean type, which should
+ * allocate the minimum amount of space.
+ */
+tree
+build_event_type (queuesize)
+ tree queuesize;
+{
+ tree type = make_node (RECORD_TYPE);
+ tree field = build_decl (FIELD_DECL, get_identifier("__event_data"),
+ ptr_type_node);
+ TYPE_FIELDS (type) = field;
+ if (queuesize)
+ {
+ tree size_field = build_decl (CONST_DECL, get_identifier("__queue_max"),
+ integer_type_node);
+ DECL_INITIAL (size_field) = queuesize;
+ TREE_CHAIN (field) = size_field;
+ }
+ CH_IS_EVENT_MODE (type) = 1;
+ CH_TYPE_NONVALUE_P (type) = 1;
+ if (pass == 2)
+ type = layout_chill_struct_type (type);
+ return type;
+}
+\f
+/*
+ * Initialize the various types of tasking data.
+ */
+void
+tasking_init ()
+{
+ extern int ignore_case;
+ extern int special_UC;
+ extern tree chill_predefined_function_type;
+ tree temp, ins_ftype_void;
+ tree endlink = void_list_node;
+ tree int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int;
+ tree void_ftype_ptr;
+ tree void_ftype_ptr_ins_int_int_ptr_ptr_int;
+ tree int_ftype_ptr_ptr_int_ptr_ptr_int;
+ tree void_ftype_int_int_int_ptr_ptr_ptr_int;
+ tree int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int;
+ tree int_ftype_ptr_int;
+
+ /* type of tasking code variables */
+ chill_taskingcode_type_node = short_unsigned_type_node;
+
+ void_ftype_void =
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE, void_type_node, NULL_TREE));
+
+ build_instance_type ();
+ ins_ftype_void
+ = build_function_type (instance_type_node,
+ tree_cons (NULL_TREE, void_type_node,
+ build_tree_list (NULL_TREE, void_type_node)));
+
+ builtin_function ("__whoami", ins_ftype_void,
+ NOT_BUILT_IN, NULL_PTR);
+
+ build_tasking_message_type ();
+
+ temp = build_decl (TYPE_DECL,
+ get_identifier ("__tmp_TaskingStruct"),
+ build_tasking_struct ());
+ pushdecl (temp);
+ DECL_SOURCE_LINE (temp) = 0;
+
+ /* any SIGNAL will be compatible with this one */
+ generic_signal_type_node = copy_node (boolean_type_node);
+
+ builtin_function ((ignore_case || ! special_UC) ? "copy_number" : "COPY_NUMBER",
+ chill_predefined_function_type,
+ BUILT_IN_COPY_NUMBER, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "gen_code" : "GEN_CODE",
+ chill_predefined_function_type,
+ BUILT_IN_GEN_CODE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "gen_inst" : "GEN_INST",
+ chill_predefined_function_type,
+ BUILT_IN_GEN_INST, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "gen_ptype" : "GEN_PTYPE",
+ chill_predefined_function_type,
+ BUILT_IN_GEN_PTYPE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "proc_type" : "PROC_TYPE",
+ chill_predefined_function_type,
+ BUILT_IN_PROC_TYPE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "queue_length" : "QUEUE_LENGTH",
+ chill_predefined_function_type,
+ BUILT_IN_QUEUE_LENGTH, NULL_PTR);
+
+ int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))))))));
+ void_ftype_ptr
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node, endlink));
+
+ int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))))));
+
+ void_ftype_ptr_ins_int_int_ptr_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, instance_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))))));
+ int_ftype_ptr_ptr_int_ptr_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))))));
+
+ void_ftype_int_int_int_ptr_ptr_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))))));
+
+ int_ftype_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)));
+
+ builtin_function ("__delay_event", int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__queue_length", int_ftype_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__register_tasking", void_ftype_ptr,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__send_signal", void_ftype_ptr_ins_int_int_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__send_buffer", int_ftype_ptr_ptr_int_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__start_process", void_ftype_int_int_int_ptr_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__stop_process", void_ftype_void, NOT_BUILT_IN,
+ NULL_PTR);
+ builtin_function ("__wait_buffer", int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__wait_signal_timed", int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+
+ infinite_buffer_event_length_node = build_int_2 (-1, 0);
+ TREE_TYPE (infinite_buffer_event_length_node) = long_integer_type_node;
+ TREE_UNSIGNED (infinite_buffer_event_length_node) = 1;
+}
--- /dev/null
+/* Implement timing-related actions for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+#include <limits.h>
+#include <string.h>
+#include "config.h"
+#include "tree.h"
+#include "rtl.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "input.h"
+#include "obstack.h"
+#include "lex.h"
+
+#ifndef LONG_TYPE_SIZE
+#define LONG_TYPE_SIZE BITS_PER_WORD
+#endif
+
+/* set non-zero if input text is forced to lowercase */
+extern int ignore_case;
+
+/* set non-zero if special words are to be entered in uppercase */
+extern int special_UC;
+
+/* timing modes */
+tree abs_timing_type_node;
+tree duration_timing_type_node;
+
+/* rts time type */
+static tree rtstime_type_node = NULL_TREE;
+
+/* the stack for AFTER primval [ DELAY ] IN
+ and has following layout
+
+ TREE_VALUE (TREE_VALUE (after_stack)) = current time or NULL_TREE (if DELAY specified)
+ TREE_PURPOSE (TREE_VALUE (after_stack)) = the duration location
+ TREE_VALUE (TREE_PURPOSE (after_stack)) = label at TIMEOUT
+ TREE_PURPOSE (TREE_PURPOSE (after_stack)) = label at the end of AFTER action
+*/
+tree after_stack = NULL_TREE;
+
+/* in pass 1 we need a seperate list for the labels */
+static tree after_stack_pass_1 = NULL_TREE;
+static tree after_help;
+
+void
+timing_init ()
+{
+ tree ptr_ftype_durt_ptr_int;
+ tree int_ftype_abst_ptr_int;
+ tree void_ftype_ptr;
+ tree long_ftype_int_int_int_int_int_int_int_ptr_int;
+ tree void_ftype_abstime_ptr;
+ tree int_ftype_ptr_durt_ptr;
+ tree void_ftype_durt_ptr;
+ tree void_ftype_ptr_durt_ptr_int;
+ tree temp;
+ tree endlink;
+ tree ulong_type;
+
+ ulong_type = TREE_TYPE (lookup_name (
+ get_identifier ((ignore_case || ! special_UC ) ?
+ "ulong" : "ULONG")));
+
+ /* build modes for TIME and DURATION */
+ duration_timing_type_node = make_unsigned_type (LONG_TYPE_SIZE);
+ temp = pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_DURATION],
+ duration_timing_type_node));
+ SET_CH_NOVELTY_NONNIL (duration_timing_type_node, temp);
+ abs_timing_type_node = make_unsigned_type (LONG_TYPE_SIZE);
+ temp = pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_TIME],
+ abs_timing_type_node));
+ SET_CH_NOVELTY_NONNIL (abs_timing_type_node, temp);
+
+ /* the mode of time the runtimesystem returns */
+ if (rtstime_type_node == NULL_TREE)
+ {
+ tree decl1, decl2, result;
+
+ decl1 = build_decl (FIELD_DECL,
+ get_identifier ("secs"),
+ ulong_type);
+ DECL_INITIAL (decl1) = NULL_TREE;
+ decl2 = build_decl (FIELD_DECL,
+ get_identifier ("nsecs"),
+ ulong_type);
+ DECL_INITIAL (decl2) = NULL_TREE;
+ TREE_CHAIN (decl2) = NULL_TREE;
+ TREE_CHAIN (decl1) = decl2;
+
+ result = build_chill_struct_type (decl1);
+ pushdecl (temp = build_decl (TYPE_DECL,
+ get_identifier ("__tmp_rtstime"), result));
+ DECL_SOURCE_LINE (temp) = 0;
+ satisfy_decl (temp, 0);
+ rtstime_type_node = TREE_TYPE (temp);
+ }
+
+ endlink = void_list_node;
+
+ ptr_ftype_durt_ptr_int
+ = build_function_type (ptr_type_node,
+ tree_cons (NULL_TREE, duration_timing_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+
+ int_ftype_abst_ptr_int
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, abs_timing_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))));
+
+ void_ftype_ptr
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ endlink));
+
+ long_ftype_int_int_int_int_int_int_int_ptr_int
+ = build_function_type (abs_timing_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink))))))))));
+
+ void_ftype_abstime_ptr
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, abs_timing_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ endlink)));
+
+ int_ftype_ptr_durt_ptr
+ = build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, duration_timing_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ endlink))));
+
+ void_ftype_durt_ptr
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, duration_timing_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ endlink)));
+
+ void_ftype_ptr_durt_ptr_int
+ = build_function_type (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, duration_timing_type_node,
+ tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ endlink)))));
+
+ builtin_function ("_abstime", long_ftype_int_int_int_int_int_int_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__check_cycle", void_ftype_ptr_durt_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__convert_duration_rtstime", void_ftype_durt_ptr,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__define_timeout", ptr_ftype_durt_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("_inttime", void_ftype_abstime_ptr,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__remaintime", int_ftype_ptr_durt_ptr,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__rtstime", void_ftype_ptr,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__wait_until", int_ftype_abst_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+}
+
+#if 0
+ *
+ * build AT action
+ *
+ * AT primval IN
+ * ok-actionlist
+ * TIMEOUT
+ * to-actionlist
+ * END;
+ *
+ * gets translated to
+ *
+ * if (__wait_until (primval) == 0)
+ * ok-actionlist
+ * else
+ * to-action-list
+ *
+#endif
+
+void
+build_at_action (t)
+ tree t;
+{
+ tree abstime, expr, filename, fcall;
+
+ if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK)
+ abstime = convert (abs_timing_type_node, build_int_2 (0, 0));
+ else
+ abstime = t;
+
+ if (TREE_TYPE (abstime) != abs_timing_type_node)
+ {
+ error ("absolute time value must be of mode TIME.");
+ abstime = convert (abs_timing_type_node, build_int_2 (0, 0));
+ }
+ filename = force_addr_of (get_chill_filename ());
+ fcall = build_chill_function_call (
+ lookup_name (get_identifier ("__wait_until")),
+ tree_cons (NULL_TREE, abstime,
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
+ expr = build (EQ_EXPR, integer_type_node, fcall, integer_zero_node);
+ expand_start_cond (expr, 0);
+ emit_line_note (input_filename, lineno);
+}
+
+#if 0
+ *
+ * build CYCLE action
+ *
+ * CYCLE primval IN
+ * actionlist
+ * END;
+ *
+ * gets translated to
+ *
+ * {
+ * RtsTime now;
+ * label:
+ * __rtstime (&now);
+ * actionlist
+ * __check_cycle (&now, primval, filename, lineno);
+ * goto label;
+ * }
+ *
+#endif
+
+tree
+build_cycle_start (t)
+ tree t;
+{
+ tree purpose = build_tree_list (NULL_TREE, NULL_TREE);
+ tree toid = build_tree_list (purpose, NULL_TREE);
+
+ /* define the label. Note: define_label needs to be called in
+ pass 1 and pass 2. */
+ TREE_VALUE (toid) = define_label (input_filename, lineno,
+ get_unique_identifier ("CYCLE_label"));
+ if (! ignoring)
+ {
+ tree duration_value, now_location;
+
+ if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK)
+ duration_value = convert (duration_timing_type_node, build_int_2 (0,0));
+ else
+ duration_value = t;
+
+ if (TREE_TYPE (duration_value) != duration_timing_type_node)
+ {
+ error ("duration primitive value must be of mode DURATION.");
+ duration_value = convert (duration_timing_type_node, build_int_2 (0,0));
+ }
+ TREE_PURPOSE (TREE_PURPOSE (toid)) = duration_value;
+ /* define the variable */
+ now_location = decl_temp1 (get_unique_identifier ("CYCLE_var"),
+ rtstime_type_node, 0,
+ NULL_TREE, 0, 0);
+ TREE_VALUE (TREE_PURPOSE (toid)) = force_addr_of (now_location);
+
+ /* build the call to __rtstime */
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (get_identifier ("__rtstime")),
+ build_tree_list (NULL_TREE, TREE_VALUE (TREE_PURPOSE (toid)))));
+ }
+
+ return toid;
+}
+
+void
+build_cycle_end (toid)
+ tree toid;
+{
+ tree filename, linenumber;
+
+ /* here we call __check_cycle and then jump to beginning of this
+ action */
+ filename = force_addr_of (get_chill_filename ());
+ linenumber = get_chill_linenumber ();
+ expand_expr_stmt (
+ build_chill_function_call (
+ lookup_name (get_identifier ("__check_cycle")),
+ tree_cons (NULL_TREE, TREE_VALUE (TREE_PURPOSE (toid)),
+ tree_cons (NULL_TREE, TREE_PURPOSE (TREE_PURPOSE (toid)),
+ tree_cons (NULL_TREE, filename,
+ tree_cons (NULL_TREE, linenumber, NULL_TREE))))));
+ expand_goto (TREE_VALUE (toid));
+}
+
+#if 0
+ *
+ * build AFTER ACTION
+ *
+ * AFTER primval [ DELAY ] IN
+ * action-list
+ * TIMEOUT
+ * to-action-list
+ * END
+ *
+ * gets translated to
+ *
+ * {
+ * struct chill_time __now;
+ * duration dur = primval;
+ * if (! delay_spceified)
+ * __rts_time (&__now);
+ * .
+ * .
+ * goto end-label;
+ * to-label:
+ * .
+ * .
+ * end-label:
+ * }
+ *
+#endif
+
+void
+build_after_start (duration, delay_flag)
+ tree duration;
+ int delay_flag;
+{
+ tree value, purpose;
+
+ if (! ignoring)
+ {
+ value = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
+ purpose = after_stack_pass_1;
+ after_stack_pass_1 = TREE_CHAIN (after_stack_pass_1);
+ after_stack = tree_cons (purpose, value, after_stack);
+
+ if (TREE_TYPE (duration) != duration_timing_type_node)
+ {
+ error ("duration primitive value must be of mode DURATION.");
+ duration = convert (duration_timing_type_node, build_int_2 (0,0));
+ }
+ TREE_PURPOSE (value) = decl_temp1 (get_identifier ("AFTER_duration"),
+ duration_timing_type_node, 0,
+ duration, 0, 0);
+
+ if (! delay_flag)
+ {
+ /* in this case we have to get the current time */
+ TREE_VALUE (value) = decl_temp1 (get_unique_identifier ("AFTER_now"),
+ rtstime_type_node, 0,
+ NULL_TREE, 0, 0);
+ /* build the function call to initialize the variable */
+ expand_expr_stmt (
+ build_chill_function_call (lookup_name (get_identifier ("__rtstime")),
+ build_tree_list (NULL_TREE, force_addr_of (TREE_VALUE (value)))));
+ }
+ }
+ else
+ {
+ /* in pass 1 we just save the labels */
+ after_help = tree_cons (NULL_TREE, NULL_TREE, after_help);
+ after_stack_pass_1 = chainon (after_stack_pass_1, after_help);
+ }
+}
+
+void
+build_after_timeout_start ()
+{
+ tree label_name, goto_where;
+
+ if (! ignoring)
+ {
+ /* jump to the end of AFTER action */
+ lookup_and_expand_goto (TREE_PURPOSE (TREE_PURPOSE (after_stack)));
+ label_name = TREE_VALUE (TREE_PURPOSE (after_stack));
+ /* mark we are in TIMEOUT part of AFTER action */
+ TREE_VALUE (TREE_PURPOSE (after_stack)) = NULL_TREE;
+ }
+ else
+ {
+ label_name = get_unique_identifier ("AFTER_tolabel");
+ TREE_VALUE (after_help) = label_name;
+ }
+ define_label (input_filename, lineno, label_name);
+}
+
+void
+build_after_end ()
+{
+ tree label_name;
+
+ /* define the end label */
+ if (! ignoring)
+ {
+ label_name = TREE_PURPOSE (TREE_PURPOSE (after_stack));
+ after_stack = TREE_CHAIN (after_stack);
+ }
+ else
+ {
+ label_name = get_unique_identifier ("AFTER_endlabel");
+ TREE_PURPOSE (after_help) = label_name;
+ after_help = TREE_CHAIN (after_help);
+ }
+ define_label (input_filename, lineno, label_name);
+}
+
+tree
+build_timeout_preface ()
+{
+ tree timeout_value = null_pointer_node;
+
+ if (after_stack != NULL_TREE &&
+ TREE_VALUE (TREE_PURPOSE (after_stack)) != NULL_TREE)
+ {
+ tree to_loc;
+
+ to_loc = decl_temp1 (get_unique_identifier ("TOloc"),
+ rtstime_type_node, 0, NULL_TREE, 0, 0);
+ timeout_value = force_addr_of (to_loc);
+
+ if (TREE_VALUE (TREE_VALUE (after_stack)) == NULL_TREE)
+ {
+ /* DELAY specified -- just call __convert_duration_rtstime for
+ given duration value */
+ expand_expr_stmt (
+ build_chill_function_call (
+ lookup_name (get_identifier ("__convert_duration_rtstime")),
+ tree_cons (NULL_TREE, TREE_PURPOSE (TREE_VALUE (after_stack)),
+ tree_cons (NULL_TREE, timeout_value, NULL_TREE))));
+ }
+ else
+ {
+ /* delay not specified -- call __remaintime which returns the
+ remaining time of duration in rtstime format and check the
+ result */
+ tree fcall =
+ build_chill_function_call (
+ lookup_name (get_identifier ("__remaintime")),
+ tree_cons (NULL_TREE, force_addr_of (TREE_VALUE (TREE_VALUE (after_stack))),
+ tree_cons (NULL_TREE, TREE_PURPOSE (TREE_VALUE (after_stack)),
+ tree_cons (NULL_TREE, timeout_value, NULL_TREE))));
+ tree expr = build (NE_EXPR, integer_type_node,
+ fcall, integer_zero_node);
+ expand_start_cond (expr, 0);
+ lookup_and_expand_goto (TREE_VALUE (TREE_PURPOSE (after_stack)));
+ expand_end_cond ();
+ }
+ }
+ return timeout_value;
+}
+
+void
+build_timesupervised_call (fcall, to_loc)
+ tree fcall;
+ tree to_loc;
+{
+ if (to_loc == null_pointer_node)
+ expand_expr_stmt (fcall);
+ else
+ {
+ tree expr = build (NE_EXPR, integer_type_node, fcall, integer_zero_node);
+ expand_start_cond (expr, 0);
+ lookup_and_expand_goto (TREE_VALUE (TREE_PURPOSE (after_stack)));
+ expand_end_cond ();
+ }
+}
--- /dev/null
+/* Build expressions with type checking for CHILL compiler.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+/* This file is part of the CHILL front end.
+ It contains routines to build C expressions given their operands,
+ including computing the modes of the result, C-specific error checks,
+ and some optimization.
+
+ There are also routines to build RETURN_STMT nodes and CASE_STMT nodes,
+ and to process initializations in declarations (since they work
+ like a strange sort of assignment). */
+
+#include "config.h"
+#include <stdio.h>
+#include "tree.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "rtl.h"
+#include "expr.h"
+#include "lex.h"
+
+extern tree build_chill_compound_expr PROTO((tree));
+extern tree build_component_ref PROTO((tree, tree));
+extern void c_expand_return PROTO((tree));
+extern int ch_singleton_set PROTO((tree));
+extern void error PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern int mark_addressable PROTO((tree));
+extern void pedwarn PROTO((char *, ...));
+extern void pedwarn_with_decl PROTO((tree, char *, ...));
+extern tree require_complete_type PROTO((tree));
+extern void sorry PROTO((char *, ...));
+extern void warning PROTO((char *, ...));
+extern int get_type_precision PROTO((tree, tree));
+
+extern tree intQI_type_node;
+extern tree intHI_type_node;
+extern tree intSI_type_node;
+extern tree intDI_type_node;
+extern tree intTI_type_node;
+
+extern tree unsigned_intQI_type_node;
+extern tree unsigned_intHI_type_node;
+extern tree unsigned_intSI_type_node;
+extern tree unsigned_intDI_type_node;
+extern tree unsigned_intTI_type_node;
+
+/* forward declarations */
+tree chill_expand_tuple PROTO((tree, tree));
+static int chill_l_equivalent PROTO((tree, tree, struct mode_chain*));
+extern tree extract_constant_from_buffer();
+\f
+/*
+ * This function checks an array access.
+ * It calls error (ERROR_MESSAGE) if the condition (index <= domain max value
+ * index >= domain min value)
+ * is not met at compile time,
+ * If a runtime test is required and permitted,
+ * check_expression is used to do so.
+ * the global RANGE_CHECKING flags controls the
+ * generation of runtime checking code.
+ */
+tree
+valid_array_index_p (array, idx, error_message, is_varying_lhs)
+ tree array, idx;
+ char *error_message;
+ int is_varying_lhs;
+{
+ tree cond, low_limit, high_cond, atype, domain;
+ tree orig_index = idx;
+ enum chill_tree_code condition;
+
+ if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
+ || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (idx) == TYPE_DECL
+ || TREE_CODE_CLASS (TREE_CODE (idx)) == 't')
+ {
+ error ("array or string index is a mode (instead of a value)");
+ return error_mark_node;
+ }
+
+ atype = TREE_TYPE (array);
+
+ if (chill_varying_type_p (atype))
+ {
+ domain = TYPE_DOMAIN (CH_VARYING_ARRAY_TYPE (atype));
+ high_cond = build_component_ref (array, var_length_id);
+ if (chill_varying_string_type_p (atype))
+ {
+ if (is_varying_lhs)
+ condition = GT_EXPR;
+ else
+ condition = GE_EXPR;
+ }
+ else
+ condition = GT_EXPR;
+ }
+ else
+ {
+ domain = TYPE_DOMAIN (atype);
+ high_cond = TYPE_MAX_VALUE (domain);
+ condition = GT_EXPR;
+ }
+
+ if (CH_STRING_TYPE_P (atype))
+ {
+ if (! CH_SIMILAR (TREE_TYPE (orig_index), integer_type_node))
+ {
+ error ("index is not an integer expression");
+ return error_mark_node;
+ }
+ }
+ else
+ {
+ if (! CH_COMPATIBLE (orig_index, domain))
+ {
+ error ("index not compatible with index mode");
+ return error_mark_node;
+ }
+ }
+
+ /* Convert BOOLS(1) to BOOL and CHARS(1) to CHAR. */
+ if (flag_old_strings)
+ {
+ idx = convert_to_discrete (idx);
+ if (idx == NULL) /* should never happen */
+ error ("index is not discrete");
+ }
+
+ /* we know we'll refer to this value twice */
+ if (range_checking)
+ idx = save_expr (idx);
+
+ low_limit = TYPE_MIN_VALUE (domain);
+ high_cond = build_compare_discrete_expr (condition, idx, high_cond);
+
+ /* an invalid index expression meets this condition */
+ cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_compare_discrete_expr (LT_EXPR, idx, low_limit),
+ high_cond));
+
+ /* strip a redundant NOP_EXPR */
+ if (TREE_CODE (cond) == NOP_EXPR
+ && TREE_TYPE (cond) == boolean_type_node
+ && TREE_CODE (TREE_OPERAND (cond, 0)) == INTEGER_CST)
+ cond = TREE_OPERAND (cond, 0);
+
+ idx = convert (CH_STRING_TYPE_P (atype) ? integer_type_node : domain,
+ idx);
+
+ if (TREE_CODE (cond) == INTEGER_CST)
+ {
+ if (tree_int_cst_equal (cond, boolean_false_node))
+ return idx; /* condition met at compile time */
+ error (error_message); /* condition failed at compile time */
+ return error_mark_node;
+ }
+ else if (range_checking)
+ {
+ /* FIXME: often, several of these conditions will
+ be generated for the same source file and line number.
+ A great optimization would be to share the
+ cause_exception function call among them rather
+ than generating a cause_exception call for each. */
+ return check_expression (idx, cond,
+ ridpointers[(int) RID_RANGEFAIL]);
+ }
+ else
+ return idx; /* don't know at compile time */
+}
+\f
+/*
+ * Extract a slice from an array, which could look like a
+ * SET_TYPE if it's a bitstring. The array could also be VARYING
+ * if the element type is CHAR. The min_value and length values
+ * must have already been checked with valid_array_index_p. No
+ * checking is done here.
+ */
+tree
+build_chill_slice (array, min_value, length)
+ tree array, min_value, length;
+{
+ tree result;
+ tree array_type = TREE_TYPE (array);
+
+ if (!CH_REFERABLE (array) && TREE_CODE (array) != SAVE_EXPR
+ && (TREE_CODE (array) != COMPONENT_REF
+ || TREE_CODE (TREE_OPERAND (array, 0)) != SAVE_EXPR))
+ {
+ if (!TREE_CONSTANT (array))
+ warning ("possible internal error - slice argument is neither referable nor constant");
+ else
+ {
+ /* Force to storage.
+ NOTE: This could mean multiple identical copies of
+ the same constant. FIXME. */
+ tree mydecl = decl_temp1 (get_unique_identifier("SLICEE"),
+ array_type, 1, array, 0, 0);
+ TREE_READONLY (mydecl) = 1;
+ /* mark_addressable (mydecl); FIXME: necessary? */
+ array = mydecl;
+ }
+ }
+
+ /*
+ The code-generation which uses a slice tree needs not only to
+ know the dynamic upper and lower limits of that slice, but the
+ original static allocation, to use to build temps where one or both
+ of the dynamic limits must be calculated at runtime.. We pass the
+ dynamic size by building a new array_type whose limits are the
+ min_value and min_value + length values passed to us.
+
+ The static allocation info is passed by using the parent array's
+ limits to compute a temp_size, which is passed in the lang_specific
+ field of the slice_type.
+ */
+
+ if (TREE_CODE (array_type) == ARRAY_TYPE)
+ {
+ tree domain_type = TYPE_DOMAIN (array_type);
+ tree index_domain
+ = TREE_CODE (length) != INTEGER_CST || integer_zerop (length)
+ ? sizetype
+ : domain_type;
+ tree domain_min = convert (index_domain, TYPE_MIN_VALUE (domain_type));
+ tree domain_max = fold (build (PLUS_EXPR, index_domain,
+ domain_min,
+ convert (index_domain,
+ size_binop (MINUS_EXPR,
+ length,
+ integer_one_node))));
+ tree index_type = build_chill_range_type (domain_type,
+ domain_min,
+ domain_max);
+
+ tree element_type = TREE_TYPE (array_type);
+ tree slice_type = build_simple_array_type (element_type, index_type, NULL_TREE);
+ tree slice_pointer_type;
+ int is_static;
+ tree max_size;
+
+ if (CH_CHARS_TYPE_P (array_type))
+ MARK_AS_STRING_TYPE (slice_type);
+ else
+ TYPE_PACKED (slice_type) = TYPE_PACKED (array_type);
+
+ SET_CH_NOVELTY (slice_type, CH_NOVELTY (array_type));
+
+ if (TREE_CONSTANT (array) && TREE_CODE (min_value) == INTEGER_CST
+ && TREE_CODE (length) == INTEGER_CST)
+ {
+ int type_size = int_size_in_bytes (array_type);
+ unsigned char *buffer = (unsigned char*) alloca (type_size);
+ int delta = int_size_in_bytes (element_type)
+ * (TREE_INT_CST_LOW (min_value) - TREE_INT_CST_LOW (domain_min));
+ bzero (buffer, type_size);
+ if (expand_constant_to_buffer (array, buffer, type_size))
+ {
+ result = extract_constant_from_buffer (slice_type,
+ buffer + delta,
+ type_size - delta);
+ if (result)
+ return result;
+ }
+ }
+
+ /* Kludge used by case CONCAT_EXPR in chill_expand_expr.
+ Set TYPE_ARRAY_MAX_SIZE to a constant upper bound on the
+ bytes needed. */
+ max_size = size_in_bytes (slice_type);
+ if (TREE_CODE (max_size) != INTEGER_CST)
+ {
+ max_size = TYPE_ARRAY_MAX_SIZE (array_type);
+ if (max_size == NULL_TREE)
+ max_size = size_in_bytes (array_type);
+ }
+ TYPE_ARRAY_MAX_SIZE (slice_type) = max_size;
+
+ mark_addressable (array);
+ /* Contruct a SLICE_EXPR to represent a slice of a packed array of bits. */
+ if (TYPE_PACKED (array_type))
+ {
+ if (pass == 2 && TREE_CODE (length) != INTEGER_CST)
+ {
+ sorry ("bit array slice with non-constant length");
+ return error_mark_node;
+ }
+ if (domain_min && ! integer_zerop (domain_min))
+ min_value = size_binop (MINUS_EXPR, min_value,
+ convert (sizetype, domain_min));
+ result = build (SLICE_EXPR, slice_type, array, min_value, length);
+ TREE_READONLY (result)
+ = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type));
+ return result;
+ }
+
+ slice_pointer_type = build_chill_pointer_type (slice_type);
+ if (TREE_CODE (min_value) == INTEGER_CST
+ && domain_min && TREE_CODE (domain_min) == INTEGER_CST
+ && compare_int_csts (EQ_EXPR, min_value, domain_min))
+ result = fold (build1 (ADDR_EXPR, slice_pointer_type, array));
+ else
+ {
+ min_value = convert (sizetype, min_value);
+ if (domain_min && ! integer_zerop (domain_min))
+ min_value = size_binop (MINUS_EXPR, min_value,
+ convert (sizetype, domain_min));
+ min_value = size_binop (MULT_EXPR, min_value,
+ size_in_bytes (element_type));
+ result = fold (build (PLUS_EXPR, slice_pointer_type,
+ build1 (ADDR_EXPR, slice_pointer_type,
+ array),
+ convert (slice_pointer_type, min_value)));
+ }
+ /* Return the final array value. */
+ result = fold (build1 (INDIRECT_REF, slice_type, result));
+ TREE_READONLY (result)
+ = TREE_READONLY (array) | TYPE_READONLY (element_type);
+ return result;
+ }
+ else if (TREE_CODE (array_type) == SET_TYPE) /* actually a bitstring */
+ {
+ if (pass == 2 && TREE_CODE (length) != INTEGER_CST)
+ {
+ sorry ("bitstring slice with non-constant length");
+ return error_mark_node;
+ }
+ result = build (SLICE_EXPR, build_bitstring_type (length),
+ array, min_value, length);
+ TREE_READONLY (result)
+ = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type));
+ return result;
+ }
+ else if (chill_varying_type_p (array_type))
+ return build_chill_slice (varying_to_slice (array), min_value, length);
+ else
+ {
+ error ("slice operation on non-array, non-bitstring value not supported");
+ return error_mark_node;
+ }
+}
+\f
+static tree
+build_empty_string (type)
+ tree type;
+{
+ int orig_pass = pass;
+ tree range, result;
+
+ range = build_chill_range_type (type, integer_zero_node,
+ integer_minus_one_node);
+ result = build_chill_array_type (type,
+ tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE);
+ pass = 2;
+ range = build_chill_range_type (type, integer_zero_node,
+ integer_minus_one_node);
+ result = build_chill_array_type (type,
+ tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE);
+ pass = orig_pass;
+
+ return decl_temp1 (get_unique_identifier ("EMPTY_STRING"),
+ result, 0, NULL_TREE, 0, 0);
+}
+\f
+/* We build the runtime range-checking as a separate list
+ * rather than making a compound_expr with min_value
+ * (for example), to control when that comparison gets
+ * generated. We cannot allow it in a TYPE_MAX_VALUE or
+ * TYPE_MIN_VALUE expression, for instance, because that code
+ * will get generated when the slice is laid out, which would
+ * put it outside the scope of an exception handler for the
+ * statement we're generating. I.e. we would be generating
+ * cause_exception calls which might execute before the
+ * necessary ch_link_handler call.
+ */
+tree
+build_chill_slice_with_range (array, min_value, max_value)
+ tree array, min_value, max_value;
+{
+ if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
+ || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK
+ || max_value == NULL_TREE || TREE_CODE(max_value) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_TYPE (array) == NULL_TREE
+ || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (array)) != SET_TYPE
+ && !chill_varying_type_p (TREE_TYPE (array))))
+ {
+ error ("can only take slice of array or string");
+ return error_mark_node;
+ }
+
+ array = save_if_needed (array);
+
+ /* FIXME: test here for max_value >= min_value, except
+ for max_value == -1, min_value == 0 (empty string) */
+ min_value = valid_array_index_p (array, min_value,
+ "slice lower limit out-of-range", 0);
+ if (TREE_CODE (min_value) == ERROR_MARK)
+ return min_value;
+
+ /* FIXME: suppress this test if max_value is the LENGTH of a
+ varying array, which has presumably already been checked. */
+ max_value = valid_array_index_p (array, max_value,
+ "slice upper limit out-of-range", 0);
+ if (TREE_CODE (max_value) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_CODE (min_value) == INTEGER_CST
+ && TREE_CODE (max_value) == INTEGER_CST
+ && tree_int_cst_lt (max_value, min_value))
+ return build_empty_string (TREE_TYPE (TREE_TYPE (array)));
+
+ return build_chill_slice (array, min_value,
+ save_expr (size_binop (PLUS_EXPR,
+ size_binop (MINUS_EXPR, max_value, min_value),
+ integer_one_node)));
+}
+
+
+tree
+build_chill_slice_with_length (array, min_value, length)
+ tree array, min_value, length;
+{
+ tree max_index;
+ tree cond, high_cond, atype;
+
+ if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
+ || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK
+ || length == NULL_TREE || TREE_CODE(length) == ERROR_MARK)
+ return error_mark_node;
+
+ if (TREE_TYPE (array) == NULL_TREE
+ || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (array)) != SET_TYPE
+ && !chill_varying_type_p (TREE_TYPE (array))))
+ {
+ error ("can only take slice of array or string");
+ return error_mark_node;
+ }
+
+ if (TREE_CONSTANT (length)
+ && tree_int_cst_lt (length, integer_zero_node))
+ return build_empty_string (TREE_TYPE (TREE_TYPE (array)));
+
+ array = save_if_needed (array);
+ min_value = save_expr (min_value);
+ length = save_expr (length);
+
+ if (! CH_SIMILAR (TREE_TYPE (length), integer_type_node))
+ {
+ error ("slice length is not an integer");
+ length = integer_one_node;
+ }
+
+ max_index = size_binop (MINUS_EXPR,
+ size_binop (PLUS_EXPR, length, min_value),
+ integer_one_node);
+ max_index = convert_to_class (chill_expr_class (min_value), max_index);
+
+ min_value = valid_array_index_p (array, min_value,
+ "slice start index out-of-range", 0);
+ if (TREE_CODE (min_value) == ERROR_MARK)
+ return error_mark_node;
+
+ atype = TREE_TYPE (array);
+
+ if (chill_varying_type_p (atype))
+ high_cond = build_component_ref (array, var_length_id);
+ else
+ high_cond = TYPE_MAX_VALUE (TYPE_DOMAIN (atype));
+
+ /* an invalid index expression meets this condition */
+ cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_compare_discrete_expr (LT_EXPR,
+ length, integer_zero_node),
+ build_compare_discrete_expr (GT_EXPR,
+ max_index, high_cond)));
+
+ if (TREE_CODE (cond) == INTEGER_CST)
+ {
+ if (! tree_int_cst_equal (cond, boolean_false_node))
+ {
+ error ("slice length out-of-range");
+ return error_mark_node;
+ }
+
+ }
+ else if (range_checking)
+ {
+ min_value = check_expression (min_value, cond,
+ ridpointers[(int) RID_RANGEFAIL]);
+ }
+
+ return build_chill_slice (array, min_value, length);
+}
+\f
+tree
+build_chill_array_ref (array, indexlist)
+ tree array, indexlist;
+{
+ tree idx;
+
+ if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK)
+ return error_mark_node;
+ if (indexlist == NULL_TREE || TREE_CODE (indexlist) == ERROR_MARK)
+ return error_mark_node;
+
+ idx = TREE_VALUE (indexlist); /* handle first index */
+
+ idx = valid_array_index_p (array, idx,
+ "array index out-of-range", 0);
+ if (TREE_CODE (idx) == ERROR_MARK)
+ return error_mark_node;
+
+ array = build_chill_array_ref_1 (array, idx);
+
+ if (array && TREE_CODE (array) != ERROR_MARK
+ && TREE_CHAIN (indexlist))
+ {
+ /* Z.200 (1988) section 4.2.8 says that:
+ <array> '(' <expression {',' <expression> }* ')'
+ is derived syntax (i.e. syntactic sugar) for:
+ <array> '(' <expression ')' { '(' <expression> ')' }*
+ The intent is clear if <array> has mode: ARRAY (...) ARRAY (...) XXX.
+ But what if <array> has mode: ARRAY (...) CHARS (N)
+ or: ARRAY (...) BOOLS (N).
+ Z.200 doesn't explicitly prohibit it, but the intent is unclear.
+ We'll allow it, since it seems reasonable and useful.
+ However, we won't allow it if <array> is:
+ ARRAY (...) PROC (...).
+ (The latter would make sense if we allowed general
+ Currying, which Chill doesn't.) */
+ if (TREE_CODE (TREE_TYPE (array)) == ARRAY_TYPE
+ || chill_varying_type_p (TREE_TYPE (array))
+ || CH_BOOLS_TYPE_P (TREE_TYPE (array)))
+ array = build_generalized_call (array, TREE_CHAIN (indexlist));
+ else
+ error ("too many index expressions");
+ }
+ return array;
+}
+
+/*
+ * Don't error check the index in here. It's supposed to be
+ * checked by the caller.
+ */
+tree
+build_chill_array_ref_1 (array, idx)
+ tree array, idx;
+{
+ tree type;
+ tree domain;
+ tree rval;
+
+ if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
+ || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK)
+ return error_mark_node;
+
+ if (chill_varying_type_p (TREE_TYPE (array)))
+ array = varying_to_slice (array);
+
+ domain = TYPE_DOMAIN (TREE_TYPE (array));
+
+#if 0
+ if (! integer_zerop (TYPE_MIN_VALUE (domain)))
+ {
+ /* The C part of the compiler doesn't understand how to do
+ arithmetic with dissimilar enum types. So we check compatability
+ here, and perform the math in INTEGER_TYPE. */
+ if (TREE_CODE (TREE_TYPE (idx)) == ENUMERAL_TYPE
+ && chill_comptypes (TREE_TYPE (idx), domain, 0))
+ idx = convert (TREE_TYPE (TYPE_MIN_VALUE (domain)), idx);
+ idx = build_binary_op (MINUS_EXPR, idx, TYPE_MIN_VALUE (domain), 0);
+ }
+#endif
+
+ if (CH_STRING_TYPE_P (TREE_TYPE (array)))
+ {
+ /* Could be bitstring or char string. */
+ if (TREE_TYPE (TREE_TYPE (array)) == boolean_type_node)
+ {
+ rval = build (SET_IN_EXPR, boolean_type_node, idx, array);
+ TREE_READONLY (rval) = TREE_READONLY (array);
+ return rval;
+ }
+ }
+
+ if (!discrete_type_p (TREE_TYPE (idx)))
+ {
+ error ("array index is not discrete");
+ return error_mark_node;
+ }
+
+ /* An array that is indexed by a non-constant
+ cannot be stored in a register; we must be able to do
+ address arithmetic on its address.
+ Likewise an array of elements of variable size. */
+ if (TREE_CODE (idx) != INTEGER_CST
+ || (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))) != 0
+ && TREE_CODE (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array)))) != INTEGER_CST))
+ {
+ if (mark_addressable (array) == 0)
+ return error_mark_node;
+ }
+
+ type = TREE_TYPE (TREE_TYPE (array));
+
+ /* Do constant folding */
+ if (TREE_CODE (idx) == INTEGER_CST && TREE_CONSTANT (array))
+ {
+ struct ch_class class;
+ class.kind = CH_VALUE_CLASS;
+ class.mode = type;
+
+ if (TREE_CODE (array) == CONSTRUCTOR)
+ {
+ tree list = CONSTRUCTOR_ELTS (array);
+ for ( ; list != NULL_TREE; list = TREE_CHAIN (list))
+ {
+ if (tree_int_cst_equal (TREE_PURPOSE (list), idx))
+ return convert_to_class (class, TREE_VALUE (list));
+ }
+ }
+ else if (TREE_CODE (array) == STRING_CST
+ && CH_CHARS_TYPE_P (TREE_TYPE (array)))
+ {
+ HOST_WIDE_INT i = TREE_INT_CST_LOW (idx);
+ if (i >= 0 && i < TREE_STRING_LENGTH (array))
+ {
+ char ch = TREE_STRING_POINTER (array) [i];
+ return convert_to_class (class,
+ build_int_2 ((unsigned char)ch, 0));
+ }
+ }
+ }
+
+ if (TYPE_PACKED (TREE_TYPE (array)))
+ rval = build (PACKED_ARRAY_REF, type, array, idx);
+ else
+ rval = build (ARRAY_REF, type, array, idx);
+
+ /* Array ref is const/volatile if the array elements are
+ or if the array is. */
+ TREE_READONLY (rval) = TREE_READONLY (array) | TYPE_READONLY (type);
+ TREE_SIDE_EFFECTS (rval)
+ |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array)))
+ | TREE_SIDE_EFFECTS (array));
+ TREE_THIS_VOLATILE (rval)
+ |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array)))
+ /* This was added by rms on 16 Nov 91.
+ It fixes vol struct foo *a; a->elts[1]
+ in an inline function.
+ Hope it doesn't break something else. */
+ | TREE_THIS_VOLATILE (array));
+ return fold (rval);
+}
+\f
+tree
+build_chill_bitref (bitstring, indexlist)
+ tree bitstring, indexlist;
+{
+ if (TREE_CODE (bitstring) == ERROR_MARK)
+ return bitstring;
+ if (TREE_CODE (indexlist) == ERROR_MARK)
+ return indexlist;
+
+ if (TREE_CHAIN (indexlist) != NULL_TREE)
+ {
+ error ("invalid compound index for bitstring mode");
+ return error_mark_node;
+ }
+
+ if (TREE_CODE (indexlist) == TREE_LIST)
+ {
+ tree result = build (SET_IN_EXPR, boolean_type_node,
+ TREE_VALUE (indexlist), bitstring);
+ TREE_READONLY (result) = TREE_READONLY (bitstring);
+ return result;
+ }
+ else abort ();
+}
+
+\f
+int
+discrete_type_p (type)
+ tree type;
+{
+ return INTEGRAL_TYPE_P (type);
+}
+
+/* Checks that EXP has discrete type, or can be converted to discrete.
+ Otherwise, returns NULL_TREE.
+ Normally returns the (possibly-converted) EXP. */
+
+tree
+convert_to_discrete (exp)
+ tree exp;
+{
+ if (! discrete_type_p (TREE_TYPE (exp)))
+ {
+ if (flag_old_strings)
+ {
+ if (CH_CHARS_ONE_P (TREE_TYPE (exp)))
+ return convert (char_type_node, exp);
+ if (CH_BOOLS_ONE_P (TREE_TYPE (exp)))
+ return convert (boolean_type_node, exp);
+ }
+ return NULL_TREE;
+ }
+ return exp;
+}
+\f
+/* Write into BUFFER the target-machine representation of VALUE.
+ Returns 1 on success, or 0 on failure. (Either the VALUE was
+ not constant, or we don't know how to do the conversion.) */
+
+int
+expand_constant_to_buffer (value, buffer, buf_size)
+ tree value;
+ unsigned char *buffer;
+ int buf_size;
+{
+ tree type = TREE_TYPE (value);
+ int size = int_size_in_bytes (type);
+ int i;
+ if (size < 0 || size > buf_size)
+ return 0;
+ switch (TREE_CODE (value))
+ {
+ case INTEGER_CST:
+ {
+ HOST_WIDE_INT lo = TREE_INT_CST_LOW (value);
+ HOST_WIDE_INT hi = TREE_INT_CST_HIGH (value);
+ for (i = 0; i < size; i++)
+ {
+ /* Doesn't work if host and target BITS_PER_UNIT differ. */
+ unsigned char byte = lo & ((1 << BITS_PER_UNIT) - 1);
+ if (BYTES_BIG_ENDIAN)
+ buffer[size - i - 1] = byte;
+ else
+ buffer[i] = byte;
+ rshift_double (lo, hi, BITS_PER_UNIT, BITS_PER_UNIT * size,
+ &lo, &hi, 0);
+ }
+ }
+ break;
+ case STRING_CST:
+ {
+ size = TREE_STRING_LENGTH (value);
+ if (size > buf_size)
+ return 0;
+ bcopy (TREE_STRING_POINTER (value), buffer, size);
+ break;
+ }
+ case CONSTRUCTOR:
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ {
+ tree element_type = TREE_TYPE (type);
+ int element_size = int_size_in_bytes (element_type);
+ tree list = CONSTRUCTOR_ELTS (value);
+ HOST_WIDE_INT next_index;
+ HOST_WIDE_INT min_index = 0;
+ if (element_size < 0)
+ return 0;
+
+ if (TYPE_DOMAIN (type) != 0)
+ {
+ tree min_val = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+ if (min_val)
+ if (TREE_CODE (min_val) != INTEGER_CST)
+ return 0;
+ else
+ min_index = TREE_INT_CST_LOW (min_val);
+ }
+
+ next_index = min_index;
+
+ for (; list != NULL_TREE; list = TREE_CHAIN (list))
+ {
+ HOST_WIDE_INT offset;
+ HOST_WIDE_INT last_index;
+ tree purpose = TREE_PURPOSE (list);
+ if (purpose)
+ {
+ if (TREE_CODE (purpose) == INTEGER_CST)
+ last_index = next_index = TREE_INT_CST_LOW (purpose);
+ else if (TREE_CODE (purpose) == RANGE_EXPR)
+ {
+ next_index = TREE_INT_CST_LOW (TREE_OPERAND(purpose, 0));
+ last_index = TREE_INT_CST_LOW (TREE_OPERAND(purpose, 1));
+ }
+ else
+ return 0;
+ }
+ else
+ last_index = next_index;
+ for ( ; next_index <= last_index; next_index++)
+ {
+ offset = (next_index - min_index) * element_size;
+ if (!expand_constant_to_buffer (TREE_VALUE (list),
+ buffer + offset,
+ buf_size - offset))
+ return 0;
+ }
+ }
+ break;
+ }
+ else if (TREE_CODE (type) == RECORD_TYPE)
+ {
+ tree list = CONSTRUCTOR_ELTS (value);
+ for (; list != NULL_TREE; list = TREE_CHAIN (list))
+ {
+ tree field = TREE_PURPOSE (list);
+ HOST_WIDE_INT offset;
+ if (field == NULL_TREE || TREE_CODE (field) != FIELD_DECL)
+ return 0;
+ if (DECL_BIT_FIELD (field))
+ return 0;
+ offset = TREE_INT_CST_LOW (DECL_FIELD_BITPOS (field))
+ / BITS_PER_UNIT;
+ if (!expand_constant_to_buffer (TREE_VALUE (list),
+ buffer + offset,
+ buf_size - offset))
+ return 0;
+ }
+ break;
+ }
+ else if (TREE_CODE (type) == SET_TYPE)
+ {
+ if (get_set_constructor_bytes (value, buffer, buf_size)
+ != NULL_TREE)
+ return 0;
+ }
+ break;
+ default:
+ return 0;
+ }
+ return 1;
+}
+
+/* Given that BUFFER contains a target-machine representation of
+ a value of type TYPE, return that value as a tree.
+ Returns NULL_TREE on failure. (E.g. the TYPE might be variable size,
+ or perhaps we don't know how to do the conversion.) */
+
+tree
+extract_constant_from_buffer (type, buffer, buf_size)
+ tree type;
+ unsigned char *buffer;
+ int buf_size;
+{
+ tree value;
+ int size = int_size_in_bytes (type);
+ int i;
+ if (size < 0 || size > buf_size)
+ return 0;
+ switch (TREE_CODE (type))
+ {
+ case INTEGER_TYPE:
+ case CHAR_TYPE:
+ case BOOLEAN_TYPE:
+ case ENUMERAL_TYPE:
+ case POINTER_TYPE:
+ {
+ HOST_WIDE_INT lo = 0, hi = 0;
+ /* Accumulate (into (lo,hi) the bytes (from buffer). */
+ for (i = size; --i >= 0; )
+ {
+ unsigned char byte;
+ /* Get next byte (in big-endian order). */
+ if (BYTES_BIG_ENDIAN)
+ byte = buffer[size - i - 1];
+ else
+ byte = buffer[i];
+ lshift_double (lo, hi, BITS_PER_UNIT, TYPE_PRECISION (type),
+ &lo, &hi, 0);
+ add_double (lo, hi, byte, 0, &lo, &hi);
+ }
+ value = build_int_2 (lo, hi);
+ TREE_TYPE (value) = type;
+ return value;
+ }
+ case ARRAY_TYPE:
+ {
+ tree element_type = TREE_TYPE (type);
+ int element_size = int_size_in_bytes (element_type);
+ tree list = NULL_TREE;
+ HOST_WIDE_INT min_index = 0, max_index, cur_index;
+ if (element_size == 1 && CH_CHARS_TYPE_P (type))
+ {
+ value = build_string (size, buffer);
+ CH_DERIVED_FLAG (value) = 1;
+ TREE_TYPE (value) = type;
+ return value;
+ }
+ if (TYPE_DOMAIN (type) == 0)
+ return 0;
+ value = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+ if (value)
+ if (TREE_CODE (value) != INTEGER_CST)
+ return 0;
+ else
+ min_index = TREE_INT_CST_LOW (value);
+ value = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+ if (value == NULL_TREE || TREE_CODE (value) != INTEGER_CST)
+ return 0;
+ else
+ max_index = TREE_INT_CST_LOW (value);
+ for (cur_index = max_index; cur_index >= min_index; cur_index--)
+ {
+ HOST_WIDE_INT offset = (cur_index - min_index) * element_size;
+ value = extract_constant_from_buffer (element_type,
+ buffer + offset,
+ buf_size - offset);
+ if (value == NULL_TREE)
+ return NULL_TREE;
+ list = tree_cons (build_int_2 (cur_index, 0), value, list);
+ }
+ value = build (CONSTRUCTOR, type, NULL_TREE, list);
+ TREE_CONSTANT (value) = 1;
+ TREE_STATIC (value) = 1;
+ return value;
+ }
+ case RECORD_TYPE:
+ {
+ tree list = NULL_TREE;
+ tree field = TYPE_FIELDS (type);
+ for (; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ HOST_WIDE_INT offset
+ = TREE_INT_CST_LOW (DECL_FIELD_BITPOS (field)) / BITS_PER_UNIT;
+ if (DECL_BIT_FIELD (field))
+ return 0;
+ value = extract_constant_from_buffer (TREE_TYPE (field),
+ buffer + offset,
+ buf_size - offset);
+ if (value == NULL_TREE)
+ return NULL_TREE;
+ list = tree_cons (field, value, list);
+ }
+ value = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list));
+ TREE_CONSTANT (value) = 1;
+ TREE_STATIC (value) = 1;
+ return value;
+ }
+
+ case UNION_TYPE:
+ {
+ tree longest_variant = NULL_TREE;
+ int longest_size = 0;
+ tree field = TYPE_FIELDS (type);
+
+ /* This is a kludge. We assume that converting the data to te
+ longest variant will provide valid data for the "correct"
+ variant. This is usually the case, but is not guaranteed.
+ For example, the longest variant may include holes.
+ Also incorrect interpreting the given value as the longest
+ variant may confuse the compiler if that should happen
+ to yield invalid values. ??? */
+
+ for (; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ int size = TREE_INT_CST_LOW (size_in_bytes (TREE_TYPE (field)));
+
+ if (size > longest_size)
+ {
+ longest_size = size;
+ longest_variant = field;
+ }
+ }
+ if (longest_variant == NULL_TREE)
+ return NULL_TREE;
+ return extract_constant_from_buffer (TREE_TYPE (longest_variant), buffer, buf_size);
+ }
+
+ case SET_TYPE:
+ {
+ tree list = NULL_TREE;
+ int i;
+ HOST_WIDE_INT min_index, max_index;
+ if (TYPE_DOMAIN (type) == 0)
+ return 0;
+ value = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+ if (value == NULL_TREE)
+ min_index = 0;
+ else if (TREE_CODE (value) != INTEGER_CST)
+ return 0;
+ else
+ min_index = TREE_INT_CST_LOW (value);
+ value = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+ if (value == NULL_TREE)
+ max_index = 0;
+ else if (TREE_CODE (value) != INTEGER_CST)
+ return 0;
+ else
+ max_index = TREE_INT_CST_LOW (value);
+ for (i = max_index + 1 - min_index; --i >= 0; )
+ {
+ unsigned char byte = (unsigned char)buffer[i / BITS_PER_UNIT];
+ unsigned bit_pos = (unsigned)i % (unsigned)BITS_PER_UNIT;
+ if (BYTES_BIG_ENDIAN
+ ? (byte & (1 << (BITS_PER_UNIT - 1 - bit_pos)))
+ : (byte & (1 << bit_pos)))
+ list = tree_cons (NULL_TREE,
+ build_int_2 (i + min_index, 0), list);
+ }
+ value = build (CONSTRUCTOR, type, NULL_TREE, list);
+ TREE_CONSTANT (value) = 1;
+ TREE_STATIC (value) = 1;
+ return value;
+ }
+
+ default:
+ return NULL_TREE;
+ }
+}
+
+tree
+build_chill_cast (type, expr)
+ tree type, expr;
+{
+ tree expr_type;
+ int expr_type_size;
+ int type_size;
+ int type_is_discrete;
+ int expr_type_is_discrete;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return error_mark_node;
+
+ /* if expression was untyped because of its context (an
+ if_expr or case_expr in a tuple, perhaps) just apply
+ the type */
+ expr_type = TREE_TYPE (expr);
+ if (expr_type == NULL_TREE
+ || TREE_CODE (expr_type) == ERROR_MARK)
+ return convert (type, expr);
+
+ if (expr_type == type)
+ return expr;
+
+ expr_type_size = int_size_in_bytes (expr_type);
+ type_size = int_size_in_bytes (type);
+
+ if (expr_type_size == -1)
+ {
+ error ("conversions from variable_size value");
+ return error_mark_node;
+ }
+ if (type_size == -1)
+ {
+ error ("conversions to variable_size mode");
+ return error_mark_node;
+ }
+
+ /* FIXME: process REAL ==> INT && INT ==> REAL && REAL ==> REAL. I hope this is correct. */
+ if ((TREE_CODE (expr_type) == INTEGER_TYPE && TREE_CODE (type) == REAL_TYPE) ||
+ (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == INTEGER_TYPE) ||
+ (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == REAL_TYPE))
+ return convert (type, expr);
+
+ /* FIXME: Don't know if this is correct */
+ /* Don't allow conversions to or from REAL with others then integer */
+ if (TREE_CODE (type) == REAL_TYPE)
+ {
+ error ("cannot convert to float");
+ return error_mark_node;
+ }
+ else if (TREE_CODE (expr_type) == REAL_TYPE)
+ {
+ error ("cannot convert float to this mode");
+ return error_mark_node;
+ }
+
+ if (expr_type_size == type_size && CH_REFERABLE (expr))
+ goto do_location_conversion;
+
+ type_is_discrete
+ = discrete_type_p (type) || TREE_CODE (type) == POINTER_TYPE;
+ expr_type_is_discrete
+ = discrete_type_p (expr_type) || TREE_CODE (expr_type) == POINTER_TYPE;
+ if (expr_type_is_discrete && type_is_discrete)
+ {
+ /* do an overflow check
+ FIXME: is this always neccessary ??? */
+ /* FIXME: don't do range chacking when target type is PTR.
+ PTR doesn't have MIN and MAXVALUE. result is sigsegv. */
+ if (range_checking && type != ptr_type_node)
+ {
+ tree tmp = expr;
+
+ STRIP_NOPS (tmp);
+ if (TREE_CONSTANT (tmp) && TREE_CODE (tmp) != ADDR_EXPR)
+ {
+ if (compare_int_csts (LT_EXPR, tmp, TYPE_MIN_VALUE (type)) ||
+ compare_int_csts (GT_EXPR, tmp, TYPE_MAX_VALUE (type)))
+ {
+ error ("OVERFLOW in expression conversion");
+ return error_mark_node;
+ }
+ }
+ else
+ {
+ int cond1 = tree_int_cst_lt (TYPE_SIZE (type),
+ TYPE_SIZE (expr_type));
+ int cond2 = TREE_UNSIGNED (type) && (! TREE_UNSIGNED (expr_type));
+ int cond3 = (! TREE_UNSIGNED (type))
+ && TREE_UNSIGNED (expr_type)
+ && tree_int_cst_equal (TYPE_SIZE (type),
+ TYPE_SIZE (expr_type));
+ int cond4 = TREE_TYPE (type) && type_is_discrete;
+
+ if (cond1 || cond2 || cond3 || cond4)
+ {
+ tree type_min = TYPE_MIN_VALUE (type);
+ tree type_max = TYPE_MAX_VALUE (type);
+
+ expr = save_if_needed (expr);
+ if (expr && type_min && type_max)
+ {
+ tree check = test_range (expr, type_min, type_max);
+ if (!integer_zerop (check))
+ {
+ if (current_function_decl == NULL_TREE)
+ {
+ if (TREE_CODE (check) == INTEGER_CST)
+ error ("overflow (not inside function)");
+ else
+ warning ("possible overflow (not inside function)");
+ }
+ else
+ {
+ if (TREE_CODE (check) == INTEGER_CST)
+ warning ("expression will always cause OVERFLOW");
+ expr = check_expression (expr, check,
+ ridpointers[(int) RID_OVERFLOW]);
+ }
+ }
+ }
+ }
+ }
+ }
+ return convert (type, expr);
+ }
+
+ if (TREE_CODE (expr) == INTEGER_CST && expr_type_size != type_size)
+ {
+ /* There should probably be a pedwarn here ... */
+ tree itype = type_for_size (type_size * BITS_PER_UNIT, 1);
+ if (itype)
+ {
+ expr = convert (itype, expr);
+ expr_type = TREE_TYPE (expr);
+ expr_type_size= type_size;
+ }
+ }
+
+ /* If expr is a constant of the right size, use it to to
+ initialize a static variable. */
+ if (expr_type_size == type_size && TREE_CONSTANT (expr) && !pedantic)
+ {
+ unsigned char *buffer = (unsigned char*) alloca (type_size);
+ tree value;
+ bzero (buffer, type_size);
+ if (!expand_constant_to_buffer (expr, buffer, type_size))
+ {
+ error ("not implemented: constant conversion from that kind of expression");
+ return error_mark_node;
+ }
+ value = extract_constant_from_buffer (type, buffer, type_size);
+ if (value == NULL_TREE)
+ {
+ error ("not implemented: constant conversion to that kind of mode");
+ return error_mark_node;
+ }
+ return value;
+ }
+
+ if (!CH_REFERABLE (expr) && expr_type_size == type_size)
+ {
+ tree temp = decl_temp1 (get_unique_identifier ("CAST"),
+ TREE_TYPE (expr), 0, 0, 0, 0);
+ tree convert1 = build_chill_modify_expr (temp, expr);
+ pedwarn ("non-standard, non-portable value conversion");
+ return build (COMPOUND_EXPR, type, convert1,
+ build_chill_cast (type, temp));
+ }
+
+ if (CH_REFERABLE (expr) && expr_type_size != type_size)
+ error ("location conversion between differently-sized modes");
+ else
+ error ("unsupported value conversion");
+ return error_mark_node;
+
+ do_location_conversion:
+ /* To avoid confusing other parts of gcc,
+ represent this as the C expression: *(TYPE*)EXPR. */
+ mark_addressable (expr);
+ expr = build1 (INDIRECT_REF, type,
+ build1 (NOP_EXPR, build_pointer_type (type),
+ build1 (ADDR_EXPR, build_pointer_type (expr_type),
+ expr)));
+ TREE_READONLY (expr) == TYPE_READONLY (type);
+ return expr;
+}
+\f
+/*
+ * given a set_type, build an integer array from it that C will grok.
+ */
+tree
+build_array_from_set (type)
+ tree type;
+{
+ tree bytespint, bit_array_size, int_array_count;
+
+ if (type == NULL_TREE || type == error_mark_node || TREE_CODE (type) != SET_TYPE)
+ return error_mark_node;
+
+ bytespint = build_int_2 (HOST_BITS_PER_INT / HOST_BITS_PER_CHAR, 0);
+ bit_array_size = size_in_bytes (type);
+ int_array_count = fold (size_binop (TRUNC_DIV_EXPR, bit_array_size,
+ bytespint));
+ if (integer_zerop (int_array_count))
+ int_array_count = size_one_node;
+ type = build_array_type (integer_type_node,
+ build_index_type (int_array_count));
+ return type;
+}
+
+
+tree
+build_chill_bin_type (size)
+ tree size;
+{
+#if 0
+ int isize;
+
+ if (TREE_CODE (size) != INTEGER_CST
+ || (isize = TREE_INT_CST_LOW (size), isize <= 0))
+ {
+ error ("operand to bin must be a non-negative integer literal");
+ return error_mark_node;
+ }
+ if (isize <= TYPE_PRECISION (unsigned_char_type_node))
+ return unsigned_char_type_node;
+ if (isize <= TYPE_PRECISION (short_unsigned_type_node))
+ return short_unsigned_type_node;
+ if (isize <= TYPE_PRECISION (unsigned_type_node))
+ return unsigned_type_node;
+ if (isize <= TYPE_PRECISION (long_unsigned_type_node))
+ return long_unsigned_type_node;
+ if (isize <= TYPE_PRECISION (long_long_unsigned_type_node))
+ return long_long_unsigned_type_node;
+ error ("size %d of BIN too big - no such integer mode", isize);
+ return error_mark_node;
+#endif
+ tree bintype;
+
+ if (pass == 1)
+ {
+ bintype = make_node (INTEGER_TYPE);
+ TREE_TYPE (bintype) = ridpointers[(int) RID_BIN];
+ TYPE_MIN_VALUE (bintype) = size;
+ TYPE_MAX_VALUE (bintype) = size;
+ }
+ else
+ {
+ error ("BIN in pass 2");
+ return error_mark_node;
+ }
+ return bintype;
+}
+\f
+tree
+chill_expand_tuple (type, constructor)
+ tree type, constructor;
+{
+ char *name;
+ tree nonreft = type;
+
+ if (TYPE_NAME (type) != NULL_TREE)
+ {
+ if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE)
+ name = IDENTIFIER_POINTER (TYPE_NAME (type));
+ else
+ name = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type)));
+ }
+ else
+ name = "";
+
+ /* get to actual underlying type for digest_init */
+ while (nonreft && TREE_CODE (nonreft) == REFERENCE_TYPE)
+ nonreft = TREE_TYPE (nonreft);
+
+ if (TREE_CODE (nonreft) == ARRAY_TYPE
+ || TREE_CODE (nonreft) == RECORD_TYPE
+ || TREE_CODE (nonreft) == SET_TYPE)
+ return convert (nonreft, constructor);
+ else
+ {
+ error ("mode of tuple is neither ARRAY, STRUCT, nor POWERSET");
+ return error_mark_node;
+ }
+}
+\f
+/* This function classifies an expr into the Null class,
+ the All class, the M-Value, the M-derived, or the M-reference class.
+ It probably has some inaccuracies. */
+
+struct ch_class
+chill_expr_class (expr)
+ tree expr;
+{
+ struct ch_class class;
+ /* The Null class contains the NULL pointer constant (only). */
+ if (expr == null_pointer_node)
+ {
+ class.kind = CH_NULL_CLASS;
+ class.mode = NULL_TREE;
+ return class;
+ }
+
+ /* The All class contains the <undefined value> "*". */
+ if (TREE_CODE (expr) == UNDEFINED_EXPR)
+ {
+ class.kind = CH_ALL_CLASS;
+ class.mode = NULL_TREE;
+ return class;
+ }
+
+ if (CH_DERIVED_FLAG (expr))
+ {
+ class.kind = CH_DERIVED_CLASS;
+ class.mode = TREE_TYPE (expr);
+ return class;
+ }
+
+ /* The M-Reference contains <references location> (address-of) expressions.
+ Note that something that's been converted to a reference doesn't count. */
+ if (TREE_CODE (expr) == ADDR_EXPR
+ && TREE_CODE (TREE_TYPE (expr)) != REFERENCE_TYPE)
+ {
+ class.kind = CH_REFERENCE_CLASS;
+ class.mode = TREE_TYPE (TREE_TYPE (expr));
+ return class;
+ }
+
+ /* The M-Value class contains expressions with a known, specific mode M. */
+ class.kind = CH_VALUE_CLASS;
+ class.mode = TREE_TYPE (expr);
+ return class;
+}
+
+/* Returns >= 1 iff REF is a location. Return 2 if it is referable. */
+
+int chill_location (ref)
+ tree ref;
+{
+ register enum tree_code code = TREE_CODE (ref);
+
+ switch (code)
+ {
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ case ARRAY_REF:
+ case PACKED_ARRAY_REF:
+ case COMPONENT_REF:
+ case NOP_EXPR: /* RETYPE_EXPR */
+ return chill_location (TREE_OPERAND (ref, 0));
+ case COMPOUND_EXPR:
+ return chill_location (TREE_OPERAND (ref, 1));
+
+ case BIT_FIELD_REF:
+ case SLICE_EXPR:
+ /* A bit-string slice is nor referable. */
+ return chill_location (TREE_OPERAND (ref, 0)) == 0 ? 0 : 1;
+
+ case CONSTRUCTOR:
+ case STRING_CST:
+ return 0;
+
+ case INDIRECT_REF:
+ case VAR_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ case ERROR_MARK:
+ if (TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE
+ && TREE_CODE (TREE_TYPE (ref)) != METHOD_TYPE)
+ return 2;
+ break;
+
+ default:
+ break;
+ }
+ return 0;
+}
+
+int
+chill_referable (val)
+ tree val;
+{
+ return chill_location (val) > 1;
+}
+
+/* Make a copy of MODE, but with the given NOVELTY. */
+
+tree
+copy_novelty (novelty, mode)
+ tree novelty, mode;
+{
+ if (CH_NOVELTY (mode) != novelty)
+ {
+ mode = copy_node (mode);
+ TYPE_MAIN_VARIANT (mode) = mode;
+ TYPE_NEXT_VARIANT (mode) = 0;
+ TYPE_POINTER_TO (mode) = 0;
+ TYPE_REFERENCE_TO (mode) = 0;
+ SET_CH_NOVELTY (mode, novelty);
+ }
+ return mode;
+}
+
+
+struct mode_chain
+{
+ struct mode_chain *prev;
+ tree mode1, mode2;
+};
+
+/* Tests if MODE1 and MODE2 are SIMILAR.
+ This is more or less as defined in the Blue Book, though
+ see FIXME for parts that are unfinished.
+ CHAIN is used to catch infinite recursion: It is a list of pairs
+ of mode arguments to calls to chill_similar "outer" to this call. */
+
+int
+chill_similar (mode1, mode2, chain)
+ tree mode1, mode2;
+ struct mode_chain *chain;
+{
+ int varying1, varying2;
+ tree t1, t2;
+ struct mode_chain *link, node;
+ if (mode1 == NULL_TREE || mode2 == NULL_TREE)
+ return 0;
+
+ while (TREE_CODE (mode1) == REFERENCE_TYPE)
+ mode1 = TREE_TYPE (mode1);
+ while (TREE_CODE (mode2) == REFERENCE_TYPE)
+ mode2 = TREE_TYPE (mode2);
+
+ /* Range modes are similar to their parent types. */
+ while (TREE_CODE (mode1) == INTEGER_TYPE && TREE_TYPE (mode1) != NULL_TREE)
+ mode1 = TREE_TYPE (mode1);
+ while (TREE_CODE (mode2) == INTEGER_TYPE && TREE_TYPE (mode2) != NULL_TREE)
+ mode2 = TREE_TYPE (mode2);
+
+
+ /* see Z.200 sections 12.1.2.2 and 13.2 - all integer precisions
+ are similar to INT and to each other */
+ if (mode1 == mode2 ||
+ (TREE_CODE (mode1) == INTEGER_TYPE && TREE_CODE (mode2) == INTEGER_TYPE))
+ return 1;
+
+ /* This guards against certain kinds of recursion.
+ For example:
+ SYNMODE a = STRUCT ( next REF a );
+ SYNMODE b = STRUCT ( next REF b );
+ These moes are similar, but will get an infite recursion trying
+ to prove that. So, if we are recursing, assume the moes are similar.
+ If they are not, we'll find some other discrepancy. */
+ for (link = chain; link != NULL; link = link->prev)
+ {
+ if (link->mode1 == mode1 && link->mode2 == mode2)
+ return 1;
+ }
+
+ node.mode1 = mode1;
+ node.mode2 = mode2;
+ node.prev = chain;
+
+ varying1 = chill_varying_type_p (mode1);
+ varying2 = chill_varying_type_p (mode2);
+ /* FIXME: This isn't quite strict enough. */
+ if ((varying1 && varying2)
+ || (varying1 && TREE_CODE (mode2) == ARRAY_TYPE)
+ || (varying2 && TREE_CODE (mode1) == ARRAY_TYPE))
+ return 1;
+
+ if (TREE_CODE(mode1) != TREE_CODE(mode2))
+ {
+ if (flag_old_strings)
+ {
+ /* The recursion is to handle varying strings. */
+ if ((TREE_CODE (mode1) == CHAR_TYPE
+ && CH_SIMILAR (mode2, string_one_type_node))
+ || (TREE_CODE (mode2) == CHAR_TYPE
+ && CH_SIMILAR (mode1, string_one_type_node)))
+ return 1;
+ if ((TREE_CODE (mode1) == BOOLEAN_TYPE
+ && CH_SIMILAR (mode2, bitstring_one_type_node))
+ || (TREE_CODE (mode2) == BOOLEAN_TYPE
+ && CH_SIMILAR (mode1, bitstring_one_type_node)))
+ return 1;
+ }
+ if (TREE_CODE (mode1) == FUNCTION_TYPE
+ && TREE_CODE (mode2) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (mode2)) == FUNCTION_TYPE)
+ mode2 = TREE_TYPE (mode2);
+ else if (TREE_CODE (mode2) == FUNCTION_TYPE
+ && TREE_CODE (mode1) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE)
+ mode1 = TREE_TYPE (mode1);
+ else
+ return 0;
+ }
+
+ if (CH_IS_BUFFER_MODE (mode1) && CH_IS_BUFFER_MODE (mode2))
+ {
+ tree len1 = max_queue_size (mode1);
+ tree len2 = max_queue_size (mode2);
+ return tree_int_cst_equal (len1, len2);
+ }
+ else if (CH_IS_EVENT_MODE (mode1) && CH_IS_EVENT_MODE (mode2))
+ {
+ tree len1 = max_queue_size (mode1);
+ tree len2 = max_queue_size (mode2);
+ return tree_int_cst_equal (len1, len2);
+ }
+ else if (CH_IS_ACCESS_MODE (mode1) && CH_IS_ACCESS_MODE (mode2))
+ {
+ tree index1 = access_indexmode (mode1);
+ tree index2 = access_indexmode (mode2);
+ tree record1 = access_recordmode (mode1);
+ tree record2 = access_recordmode (mode2);
+ if (! chill_read_compatible (index1, index2))
+ return 0;
+ return chill_read_compatible (record1, record2);
+ }
+ switch ((enum chill_tree_code)TREE_CODE (mode1))
+ {
+ case INTEGER_TYPE:
+ case BOOLEAN_TYPE:
+ case CHAR_TYPE:
+ return 1;
+ case ENUMERAL_TYPE:
+ if (TYPE_VALUES (mode1) == TYPE_VALUES (mode2))
+ return 1;
+ else
+ {
+ /* FIXME: This is more strict than z.200, which seems to
+ allow the elements to be reordered, as long as they
+ have the same values. */
+
+ tree field1 = TYPE_VALUES (mode1);
+ tree field2 = TYPE_VALUES (mode2);
+
+ while (field1 != NULL_TREE && field2 != NULL_TREE)
+ {
+ tree value1, value2;
+ /* Check that the names are equal. */
+ if (TREE_PURPOSE (field1) != TREE_PURPOSE (field2))
+ break;
+
+ value1 = TREE_VALUE (field1);
+ value2 = TREE_VALUE (field2);
+ /* This isn't quite sufficient in general, but will do ... */
+ /* Note that proclaim_decl can cause the SET modes to be
+ compared BEFORE they are satisfied, but otherwise
+ chill_similar is mostly called after satisfaction. */
+ if (TREE_CODE (value1) == CONST_DECL)
+ value1 = DECL_INITIAL (value1);
+ if (TREE_CODE (value2) == CONST_DECL)
+ value2 = DECL_INITIAL (value2);
+ /* Check that the values are equal or both NULL. */
+ if (!(value1 == NULL_TREE && value2 == NULL_TREE)
+ && (value1 == NULL_TREE || value2 == NULL_TREE
+ || ! tree_int_cst_equal (value1, value2)))
+ break;
+ field1 = TREE_CHAIN (field1);
+ field2 = TREE_CHAIN (field2);
+ }
+ return field1 == NULL_TREE && field2 == NULL_TREE;
+ }
+ case SET_TYPE:
+ /* check for bit strings */
+ if (CH_BOOLS_TYPE_P (mode1))
+ return CH_BOOLS_TYPE_P (mode2);
+ if (CH_BOOLS_TYPE_P (mode2))
+ return CH_BOOLS_TYPE_P (mode1);
+ /* both are powerset modes */
+ return CH_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2));
+
+ case POINTER_TYPE:
+ /* Are the referenced modes equivalent? */
+ return !integer_zerop (chill_equivalent (TREE_TYPE (mode1),
+ TREE_TYPE (mode2),
+ &node));
+
+ case ARRAY_TYPE:
+ /* char for char strings */
+ if (CH_CHARS_TYPE_P (mode1))
+ return CH_CHARS_TYPE_P (mode2);
+ if (CH_CHARS_TYPE_P (mode2))
+ return CH_CHARS_TYPE_P (mode1);
+ /* array modes */
+ if (CH_V_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2))
+ /* Are the elements modes equivalent? */
+ && !integer_zerop (chill_equivalent (TREE_TYPE (mode1),
+ TREE_TYPE (mode2),
+ &node)))
+ {
+ /* FIXME: Check that element layouts are equivalent */
+
+ tree count1 = fold (build (MINUS_EXPR, sizetype,
+ TYPE_MAX_VALUE (TYPE_DOMAIN (mode1)),
+ TYPE_MIN_VALUE (TYPE_DOMAIN (mode1))));
+ tree count2 = fold (build (MINUS_EXPR, sizetype,
+ TYPE_MAX_VALUE (TYPE_DOMAIN (mode2)),
+ TYPE_MIN_VALUE (TYPE_DOMAIN (mode2))));
+ tree cond = build_compare_discrete_expr (EQ_EXPR, count1, count2);
+ if (TREE_CODE (cond) == INTEGER_CST)
+ return !integer_zerop (cond);
+ else
+ {
+#if 0
+ extern int ignoring;
+ if (!ignoring
+ && range_checking
+ && current_function_decl)
+ return cond;
+#endif
+ return 1;
+ }
+ }
+ return 0;
+
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ for (t1 = TYPE_FIELDS (mode1), t2 = TYPE_FIELDS (mode2);
+ t1 && t2; t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2))
+ {
+ if (TREE_CODE (t1) != TREE_CODE (t2))
+ return 0;
+ /* Are the field modes equivalent? */
+ if (integer_zerop (chill_equivalent (TREE_TYPE (t1),
+ TREE_TYPE (t2),
+ &node)))
+ return 0;
+ }
+ return t1 == t2;
+
+ case FUNCTION_TYPE:
+ if (!chill_l_equivalent (TREE_TYPE (mode1), TREE_TYPE (mode2), &node))
+ return 0;
+ for (t1 = TYPE_ARG_TYPES (mode1), t2 = TYPE_ARG_TYPES (mode2);
+ t1 != NULL_TREE && t2 != NULL_TREE;
+ t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2))
+ {
+ tree attr1 = TREE_PURPOSE (t1)
+ ? TREE_PURPOSE (t1) : ridpointers[(int) RID_IN];
+ tree attr2 = TREE_PURPOSE (t2)
+ ? TREE_PURPOSE (t2) : ridpointers[(int) RID_IN];
+ if (attr1 != attr2)
+ return 0;
+ if (!chill_l_equivalent (TREE_VALUE (t1), TREE_VALUE (t2), &node))
+ return 0;
+ }
+ if (t1 != t2) /* Both NULL_TREE */
+ return 0;
+ /* check list of exception names */
+ t1 = TYPE_RAISES_EXCEPTIONS (mode1);
+ t2 = TYPE_RAISES_EXCEPTIONS (mode2);
+ if (t1 == NULL_TREE && t2 != NULL_TREE)
+ return 0;
+ if (t1 != NULL_TREE && t2 == NULL_TREE)
+ return 0;
+ if (list_length (t1) != list_length (t2))
+ return 0;
+ while (t1 != NULL_TREE)
+ {
+ if (value_member (TREE_VALUE (t1), t2) == NULL_TREE)
+ return 0;
+ t1 = TREE_CHAIN (t1);
+ }
+ /* FIXME: Should also check they have the same RECURSIVITY */
+ return 1;
+
+ default:
+ ;
+#if 0
+ /* Need to handle row modes, instance modes,
+ association modes, access modes, text modes,
+ duration modes, absolute time modes, structure modes,
+ parameterized structure modes */
+#endif
+ }
+ return 1;
+}
+
+/* Return a node that is true iff MODE1 and MODE2 are equivalent.
+ This is normally boolean_true_node or boolean_false_node,
+ but can be dynamic for dynamic types.
+ CHAIN is as for chill_similar. */
+
+tree
+chill_equivalent (mode1, mode2, chain)
+ tree mode1, mode2;
+ struct mode_chain *chain;
+{
+ int varying1, varying2;
+ int is_string1, is_string2;
+ tree base_mode1, base_mode2;
+
+ /* Are the modes v-equivalent? */
+#if 0
+ if (!chill_similar (mode1, mode2, chain)
+ || CH_NOVELTY(mode1) != CH_NOVELTY(mode2))
+ return boolean_false_node;
+#endif
+ if (!chill_similar (mode1, mode2, chain))
+ return boolean_false_node;
+ else if (TREE_CODE (mode2) == FUNCTION_TYPE
+ && TREE_CODE (mode1) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE)
+ /* don't check novelty in this case to avoid error in case of
+ NEWMODE'd proceduremode gets assigned a function */
+ return boolean_true_node;
+ else if (CH_NOVELTY(mode1) != CH_NOVELTY(mode2))
+ return boolean_false_node;
+
+ varying1 = chill_varying_type_p (mode1);
+ varying2 = chill_varying_type_p (mode2);
+
+ if (varying1 != varying2)
+ return boolean_false_node;
+ base_mode1 = varying1 ? CH_VARYING_ARRAY_TYPE (mode1) : mode1;
+ base_mode2 = varying2 ? CH_VARYING_ARRAY_TYPE (mode2) : mode2;
+ is_string1 = CH_STRING_TYPE_P (base_mode1);
+ is_string2 = CH_STRING_TYPE_P (base_mode2);
+ if (is_string1 || is_string2)
+ {
+ if (is_string1 != is_string2)
+ return boolean_false_node;
+ return fold (build (EQ_EXPR, boolean_type_node,
+ TYPE_SIZE (base_mode1),
+ TYPE_SIZE (base_mode2)));
+ }
+
+ /* && some more stuff FIXME! */
+ if (TREE_CODE(mode1) == INTEGER_TYPE || TREE_CODE(mode2) == INTEGER_TYPE)
+ {
+ if (TREE_CODE(mode1) != INTEGER_TYPE || TREE_CODE(mode2) != INTEGER_TYPE)
+ return boolean_false_node;
+ /* If one is a range, the other has to be a range. */
+ if ((TREE_TYPE (mode1) != NULL_TREE) != (TREE_TYPE (mode2) != NULL_TREE))
+ return boolean_false_node;
+ if (TYPE_PRECISION (mode1) != TYPE_PRECISION (mode2))
+ return boolean_false_node;
+ if (!tree_int_cst_equal (TYPE_MIN_VALUE (mode1), TYPE_MIN_VALUE (mode2)))
+ return boolean_false_node;
+ if (!tree_int_cst_equal (TYPE_MAX_VALUE (mode1), TYPE_MAX_VALUE (mode2)))
+ return boolean_false_node;
+ }
+ return boolean_true_node;
+}
+
+static int
+chill_l_equivalent (mode1, mode2, chain)
+ tree mode1, mode2;
+ struct mode_chain *chain;
+{
+ /* Are the modes equivalent? */
+ if (integer_zerop (chill_equivalent (mode1, mode2, chain)))
+ return 0;
+ if (TYPE_READONLY (mode1) != TYPE_READONLY (mode2))
+ return 0;
+#if 0
+ ... other conditions ...;
+#endif
+ return 1;
+}
+
+/* See Z200 12.1.2.12 */
+
+int
+chill_read_compatible (modeM, modeN)
+ tree modeM, modeN;
+{
+ while (TREE_CODE (modeM) == REFERENCE_TYPE)
+ modeM = TREE_TYPE (modeM);
+ while (TREE_CODE (modeN) == REFERENCE_TYPE)
+ modeN = TREE_TYPE (modeN);
+
+ if (!CH_EQUIVALENT (modeM, modeN))
+ return 0;
+ if (TYPE_READONLY (modeN))
+ {
+ if (!TYPE_READONLY (modeM))
+ return 0;
+ if (CH_IS_BOUND_REFERENCE_MODE (modeM)
+ && CH_IS_BOUND_REFERENCE_MODE (modeN))
+ {
+ return chill_l_equivalent (TREE_TYPE (modeM), TREE_TYPE (modeN), 0);
+ }
+#if 0
+ ...;
+#endif
+ }
+ return 1;
+}
+
+/* Tests if MODE is compatible with the class of EXPR.
+ Cfr. Chill Blue Book 12.1.2.15. */
+
+int
+chill_compatible (expr, mode)
+ tree expr, mode;
+{
+ struct ch_class class;
+
+ if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+ return 0;
+ if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK)
+ return 0;
+
+ while (TREE_CODE (mode) == REFERENCE_TYPE)
+ mode = TREE_TYPE (mode);
+
+ if (TREE_TYPE (expr) == NULL_TREE)
+ if (TREE_CODE (expr) == CONSTRUCTOR)
+ return TREE_CODE (mode) == RECORD_TYPE
+ || ((TREE_CODE (mode) == SET_TYPE || TREE_CODE (mode) == ARRAY_TYPE)
+ && ! TYPE_STRING_FLAG (mode));
+ else
+ return TREE_CODE (expr) == CASE_EXPR || TREE_CODE (expr) == COND_EXPR;
+
+ class = chill_expr_class (expr);
+ switch (class.kind)
+ {
+ case CH_ALL_CLASS:
+ return 1;
+ case CH_NULL_CLASS:
+ return CH_IS_REFERENCE_MODE (mode) || CH_IS_PROCEDURE_MODE (mode)
+ || CH_IS_INSTANCE_MODE (mode);
+ case CH_VALUE_CLASS:
+ if (CH_HAS_REFERENCING_PROPERTY (mode))
+ return CH_RESTRICTABLE_TO(mode, class.mode);
+ else
+ return CH_V_EQUIVALENT(mode, class.mode);
+ case CH_DERIVED_CLASS:
+ return CH_SIMILAR (class.mode, mode);
+ case CH_REFERENCE_CLASS:
+ if (!CH_IS_REFERENCE_MODE (mode))
+ return 0;
+#if 0
+ /* FIXME! */
+ if (class.mode is a row mode)
+ ...;
+ else if (class.mode is not a static mode)
+ return 0; /* is this possible? FIXME */
+#endif
+ return !CH_IS_BOUND_REFERENCE_MODE(mode)
+ || CH_READ_COMPATIBLE (TREE_TYPE (mode), class.mode);
+ }
+ return 0; /* ERROR! */
+}
+
+/* Tests if the class of of EXPR1 and EXPR2 are compatible.
+ Cfr. Chill Blue Book 12.1.2.16. */
+
+int
+chill_compatible_classes (expr1, expr2)
+ tree expr1, expr2;
+{
+ struct ch_class temp;
+ struct ch_class class1, class2;
+ class1 = chill_expr_class (expr1);
+ class2 = chill_expr_class (expr2);
+
+ switch (class1.kind)
+ {
+ case CH_ALL_CLASS:
+ return 1;
+ case CH_NULL_CLASS:
+ switch (class2.kind)
+ {
+ case CH_ALL_CLASS:
+ case CH_NULL_CLASS:
+ case CH_REFERENCE_CLASS:
+ return 1;
+ case CH_VALUE_CLASS:
+ case CH_DERIVED_CLASS:
+ goto rule4;
+ }
+ case CH_REFERENCE_CLASS:
+ switch (class2.kind)
+ {
+ case CH_ALL_CLASS:
+ case CH_NULL_CLASS:
+ return 1;
+ case CH_REFERENCE_CLASS:
+ return CH_EQUIVALENT (class1.mode, class2.mode);
+ case CH_VALUE_CLASS:
+ goto rule6;
+ case CH_DERIVED_CLASS:
+ return 0;
+ }
+ case CH_DERIVED_CLASS:
+ switch (class2.kind)
+ {
+ case CH_ALL_CLASS:
+ return 1;
+ case CH_VALUE_CLASS:
+ case CH_DERIVED_CLASS:
+ return CH_SIMILAR (class1.mode, class2.mode);
+ case CH_NULL_CLASS:
+ class2 = class1;
+ goto rule4;
+ case CH_REFERENCE_CLASS:
+ return 0;
+ }
+ case CH_VALUE_CLASS:
+ switch (class2.kind)
+ {
+ case CH_ALL_CLASS:
+ return 1;
+ case CH_DERIVED_CLASS:
+ return CH_SIMILAR (class1.mode, class2.mode);
+ case CH_VALUE_CLASS:
+ return CH_V_EQUIVALENT (class1.mode, class2.mode);
+ case CH_NULL_CLASS:
+ class2 = class1;
+ goto rule4;
+ case CH_REFERENCE_CLASS:
+ temp = class1; class1 = class2; class2 = temp;
+ goto rule6;
+ }
+ }
+ rule4:
+ /* The Null class is Compatible with the M-derived class or M-value class
+ if and only if M is a reference mdoe, procedure mode or instance mode.*/
+ return CH_IS_REFERENCE_MODE (class2.mode)
+ || CH_IS_PROCEDURE_MODE (class2.mode)
+ || CH_IS_INSTANCE_MODE (class2.mode);
+
+ rule6:
+ /* The M-reference class is compatible with the N-value class if and
+ only if N is a reference mode and ... */
+ if (!CH_IS_REFERENCE_MODE (class2.mode))
+ return 0;
+ if (1) /* If M is a static mode - FIXME */
+ {
+ if (!CH_IS_BOUND_REFERENCE_MODE (class2.mode))
+ return 1;
+ if (CH_EQUIVALENT (TREE_TYPE (class2.mode), class1.mode))
+ return 1;
+ }
+ /* If N is a row mode whose .... FIXME */
+ return 0;
+}
+
+/* Cfr. Blue Book 12.1.1.6, with some "extensions." */
+
+tree
+chill_root_mode (mode)
+ tree mode;
+{
+ /* Reference types are not user-visible types.
+ This seems like a good place to get rid of them. */
+ if (TREE_CODE (mode) == REFERENCE_TYPE)
+ mode = TREE_TYPE (mode);
+
+ while (TREE_CODE (mode) == INTEGER_TYPE && TREE_TYPE (mode) != NULL_TREE)
+ mode = TREE_TYPE (mode); /* a sub-range */
+
+ /* This extension in not in the Blue Book - which only has a
+ single Integer type.
+ We should probably use chill_integer_type_node rather
+ than integer_type_node, but that is likely to bomb.
+ At some point, these will become the same, I hope. FIXME */
+ if (TREE_CODE (mode) == INTEGER_TYPE
+ && TYPE_PRECISION (mode) < TYPE_PRECISION (integer_type_node)
+ && CH_NOVELTY (mode) == NULL_TREE)
+ mode = integer_type_node;
+
+ if (TREE_CODE (mode) == FUNCTION_TYPE)
+ return build_pointer_type (mode);
+
+ return mode;
+}
+
+/* Cfr. Blue Book 12.1.1.7. */
+
+tree
+chill_resulting_mode (mode1, mode2)
+ tree mode1, mode2;
+{
+ mode1 = CH_ROOT_MODE (mode1);
+ mode2 = CH_ROOT_MODE (mode2);
+ if (chill_varying_type_p (mode1))
+ return mode1;
+ if (chill_varying_type_p (mode2))
+ return mode2;
+ return mode1;
+}
+
+/* Cfr. Blue Book (z200, 1988) 12.1.1.7 Resulting class. */
+
+struct ch_class
+chill_resulting_class (class1, class2)
+ struct ch_class class1, class2;
+{
+ struct ch_class class;
+ switch (class1.kind)
+ {
+ case CH_VALUE_CLASS:
+ switch (class2.kind)
+ {
+ case CH_DERIVED_CLASS:
+ case CH_ALL_CLASS:
+ class.kind = CH_VALUE_CLASS;
+ class.mode = CH_ROOT_MODE (class1.mode);
+ return class;
+ case CH_VALUE_CLASS:
+ class.kind = CH_VALUE_CLASS;
+ class.mode
+ = CH_ROOT_MODE (CH_RESULTING_MODE (class1.mode, class2.mode));
+ return class;
+ }
+ case CH_DERIVED_CLASS:
+ switch (class2.kind)
+ {
+ case CH_VALUE_CLASS:
+ class.kind = CH_VALUE_CLASS;
+ class.mode = CH_ROOT_MODE (class2.mode);
+ return class;
+ case CH_DERIVED_CLASS:
+ class.kind = CH_DERIVED_CLASS;
+ class.mode = CH_RESULTING_MODE (class1.mode, class2.mode);
+ return class;
+ case CH_ALL_CLASS:
+ class.kind = CH_DERIVED_CLASS;
+ class.mode = CH_ROOT_MODE (class1.mode);
+ return class;
+ }
+ case CH_ALL_CLASS:
+ switch (class2.kind)
+ {
+ case CH_VALUE_CLASS:
+ class.kind = CH_VALUE_CLASS;
+ class.mode = CH_ROOT_MODE (class2.mode);
+ return class;
+ case CH_ALL_CLASS:
+ class.kind = CH_ALL_CLASS;
+ class.mode = NULL_TREE;
+ return class;
+ case CH_DERIVED_CLASS:
+ class.kind = CH_DERIVED_CLASS;
+ class.mode = CH_ROOT_MODE (class2.mode);
+ return class;
+ }
+ }
+ error ("internal error in chill_root_resulting_mode");
+ class.kind = CH_VALUE_CLASS;
+ class.mode = CH_ROOT_MODE (class1.mode);
+ return class;
+}
+\f
+
+/*
+ * See Z.200, section 6.3, static conditions. This function
+ * returns bool_false_node if the condition is not met at compile time,
+ * bool_true_node if the condition is detectably met at compile time
+ * an expression if a runtime check would be required or was generated.
+ * It should only be called with string modes and values.
+ */
+tree
+string_assignment_condition (lhs_mode, rhs_value)
+ tree lhs_mode, rhs_value;
+{
+ tree lhs_size, rhs_size, cond;
+ tree rhs_mode = TREE_TYPE (rhs_value);
+ int lhs_varying = chill_varying_type_p (lhs_mode);
+
+ if (lhs_varying)
+ lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode));
+ else if (CH_BOOLS_TYPE_P (lhs_mode))
+ lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode));
+ else
+ lhs_size = size_in_bytes (lhs_mode);
+ lhs_size = convert (chill_unsigned_type_node, lhs_size);
+
+ if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE)
+ rhs_mode = TREE_TYPE (rhs_mode);
+ if (rhs_mode == NULL_TREE)
+ {
+ /* actually, count constructor's length */
+ abort ();
+ }
+ else if (chill_varying_type_p (rhs_mode))
+ rhs_size = build_component_ref (rhs_value, var_length_id);
+ else if (CH_BOOLS_TYPE_P (rhs_mode))
+ rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode));
+ else
+ rhs_size = size_in_bytes (rhs_mode);
+ rhs_size = convert (chill_unsigned_type_node, rhs_size);
+
+ /* validity condition */
+ cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR,
+ boolean_type_node, lhs_size, rhs_size));
+ return cond;
+}
+\f
+/*
+ * take a basic CHILL type and wrap it in a VARYING structure.
+ * Be sure the length field is initialized. Return the wrapper.
+ */
+tree
+build_varying_struct (type)
+ tree type;
+{
+ tree decl1, decl2, result;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+
+ decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node);
+ decl2 = build_decl (FIELD_DECL, var_data_id, type);
+ TREE_CHAIN (decl1) = decl2;
+ TREE_CHAIN (decl2) = NULL_TREE;
+ result = build_chill_struct_type (decl1);
+
+ /* mark this so we don't complain about missing initializers.
+ It's fine for a VARYING array to be partially initialized.. */
+ C_TYPE_VARIABLE_SIZE(type) = 1;
+ return result;
+}
+
+
+/*
+ * This is the struct type that forms the runtime initializer
+ * list. There's at least one of these generated per module.
+ * It's attached to the global initializer list by the module's
+ * 'constructor' code. Should only be called in pass 2.
+ */
+tree
+build_init_struct ()
+{
+ tree decl1, decl2, result;
+ /* We temporarily reset the maximum_field_alignment to zero so the
+ compiler's init data structures can be compatible with the
+ run-time system, even when we're compiling with -fpack. */
+ extern int maximum_field_alignment;
+ int save_maximum_field_alignment = maximum_field_alignment;
+ maximum_field_alignment = 0;
+
+ decl1 = build_decl (FIELD_DECL, get_identifier ("__INIT_ENTRY"),
+ build_chill_pointer_type (
+ build_function_type (void_type_node, NULL_TREE)));
+
+ decl2 = build_decl (FIELD_DECL, get_identifier ("__INIT_NEXT"),
+ build_chill_pointer_type (void_type_node));
+
+ TREE_CHAIN (decl1) = decl2;
+ TREE_CHAIN (decl2) = NULL_TREE;
+ result = build_chill_struct_type (decl1);
+ maximum_field_alignment = save_maximum_field_alignment;
+ return result;
+}
+\f
+\f
+/*
+ * Return 1 if the given type is a single-bit boolean set,
+ * in which the domain's min and max values
+ * are both zero,
+ * 0 if not. This can become a macro later..
+ */
+int
+ch_singleton_set (type)
+ tree type;
+{
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return 0;
+ if (TREE_CODE (type) != SET_TYPE)
+ return 0;
+ if (TREE_TYPE (type) == NULL_TREE
+ || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE)
+ return 0;
+ if (TYPE_DOMAIN (type) == NULL_TREE)
+ return 0;
+ if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
+ integer_zero_node))
+ return 0;
+ if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
+ integer_zero_node))
+ return 0;
+ return 1;
+}
+\f
+/* return non-zero if TYPE is a compiler-generated VARYING
+ array of some base type */
+int
+chill_varying_type_p (type)
+ tree type;
+{
+ if (type == NULL_TREE)
+ return 0;
+ if (TREE_CODE (type) != RECORD_TYPE)
+ return 0;
+ if (TYPE_FIELDS (type) == NULL_TREE
+ || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE)
+ return 0;
+ if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id)
+ return 0;
+ if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id)
+ return 0;
+ if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE)
+ return 0;
+ return 1;
+}
+
+/* return non-zero if TYPE is a compiler-generated VARYING
+ string record */
+int
+chill_varying_string_type_p (type)
+ tree type;
+{
+ tree var_data_type;
+
+ if (!chill_varying_type_p (type))
+ return 0;
+
+ var_data_type = CH_VARYING_ARRAY_TYPE (type);
+ return CH_CHARS_TYPE_P (var_data_type);
+}
+\f
+/* swiped from c-typeck.c */
+/* Build an assignment expression of lvalue LHS from value RHS. */
+
+tree
+build_chill_modify_expr (lhs, rhs)
+ tree lhs, rhs;
+{
+ register tree result;
+
+
+ tree lhstype = TREE_TYPE (lhs);
+
+ /* Avoid duplicate error messages from operands that had errors. */
+ if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
+ return error_mark_node;
+
+ /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */
+ /* Do not use STRIP_NOPS here. We do not want an enumerator
+ whose value is 0 to count as a null pointer constant. */
+ if (TREE_CODE (rhs) == NON_LVALUE_EXPR)
+ rhs = TREE_OPERAND (rhs, 0);
+
+#if 0
+ /* Handle a cast used as an "lvalue".
+ We have already performed any binary operator using the value as cast.
+ Now convert the result to the cast type of the lhs,
+ and then true type of the lhs and store it there;
+ then convert result back to the cast type to be the value
+ of the assignment. */
+
+ switch (TREE_CODE (lhs))
+ {
+ case NOP_EXPR:
+ case CONVERT_EXPR:
+ case FLOAT_EXPR:
+ case FIX_TRUNC_EXPR:
+ case FIX_FLOOR_EXPR:
+ case FIX_ROUND_EXPR:
+ case FIX_CEIL_EXPR:
+ {
+ tree inner_lhs = TREE_OPERAND (lhs, 0);
+ tree result;
+ result = build_chill_modify_expr (inner_lhs,
+ convert (TREE_TYPE (inner_lhs),
+ convert (lhstype, rhs)));
+ pedantic_lvalue_warning (CONVERT_EXPR);
+ return convert (TREE_TYPE (lhs), result);
+ }
+ }
+
+ /* Now we have handled acceptable kinds of LHS that are not truly lvalues.
+ Reject anything strange now. */
+
+ if (!lvalue_or_else (lhs, "assignment"))
+ return error_mark_node;
+#endif
+ /* FIXME: need to generate a RANGEFAIL if the RHS won't
+ fit into the LHS. */
+
+ if (TREE_CODE (lhs) != VAR_DECL
+ && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE &&
+ (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) ||
+ chill_varying_type_p (TREE_TYPE (lhs)) ||
+ chill_varying_type_p (TREE_TYPE (rhs))))
+ {
+ int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs));
+ int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs));
+
+ /* point at actual RHS data's type */
+ tree rhs_data_type = rhs_varying ?
+ CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) :
+ TREE_TYPE (rhs);
+ {
+ /* point at actual LHS data's type */
+ tree lhs_data_type = lhs_varying ?
+ CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) :
+ TREE_TYPE (lhs);
+
+ int lhs_bytes = int_size_in_bytes (lhs_data_type);
+ int rhs_bytes = int_size_in_bytes (rhs_data_type);
+
+ /* if both sides not varying, and sizes not dynamically
+ computed, sizes must *match* */
+ if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes
+ && lhs_bytes > 0 && rhs_bytes > 0)
+ {
+ error ("string lengths not equal");
+ return error_mark_node;
+ }
+ /* Must have enough space on LHS for static size of RHS */
+
+ if (lhs_bytes > 0 && rhs_bytes > 0
+ && lhs_bytes < rhs_bytes)
+ {
+ if (rhs_varying)
+ {
+ /* FIXME: generate runtime test for room */
+ ;
+ }
+ else
+ {
+ error ("can't do ARRAY assignment - too large");
+ return error_mark_node;
+ }
+ }
+ }
+
+ /* now we know the RHS will fit in LHS, build trees for the
+ emit_block_move parameters */
+
+ if (lhs_varying)
+ rhs = convert (TREE_TYPE (lhs), rhs);
+ else
+ {
+ if (rhs_varying)
+ rhs = build_component_ref (rhs, var_data_id);
+
+ if (! mark_addressable (rhs))
+ {
+ error ("rhs of array assignment is not addressable");
+ return error_mark_node;
+ }
+
+ lhs = force_addr_of (lhs);
+ rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs);
+ return
+ build_chill_function_call (lookup_name (get_identifier ("memmove")),
+ tree_cons (NULL_TREE, lhs,
+ tree_cons (NULL_TREE, rhs,
+ tree_cons (NULL_TREE, size_in_bytes (rhs_data_type),
+ NULL_TREE))));
+ }
+ }
+
+ result = build (MODIFY_EXPR, lhstype, lhs, rhs);
+ TREE_SIDE_EFFECTS (result) = 1;
+
+ return result;
+}
+\f
+/* Constructors for pointer, array and function types.
+ (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are
+ constructed by language-dependent code, not here.) */
+
+/* Construct, lay out and return the type of pointers to TO_TYPE.
+ If such a type has already been constructed, reuse it. */
+
+tree
+make_chill_pointer_type (to_type, code)
+ tree to_type;
+ enum tree_code code; /* POINTER_TYPE or REFERENCE_TYPE */
+{
+ extern struct obstack *current_obstack;
+ extern struct obstack *saveable_obstack;
+ extern struct obstack permanent_obstack;
+ tree t;
+ register struct obstack *ambient_obstack = current_obstack;
+ register struct obstack *ambient_saveable_obstack = saveable_obstack;
+
+ /* If TO_TYPE is permanent, make this permanent too. */
+ if (TREE_PERMANENT (to_type))
+ {
+ current_obstack = &permanent_obstack;
+ saveable_obstack = &permanent_obstack;
+ }
+
+ t = make_node (code);
+ TREE_TYPE (t) = to_type;
+
+ current_obstack = ambient_obstack;
+ saveable_obstack = ambient_saveable_obstack;
+ return t;
+}
+
+
+tree
+build_chill_pointer_type (to_type)
+ tree to_type;
+{
+ int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't';
+ register tree t = is_type_node ? TYPE_POINTER_TO (to_type) : NULL_TREE;
+
+ /* First, if we already have a type for pointers to TO_TYPE, use it. */
+
+ if (t)
+ return t;
+
+ /* We need a new one. */
+ t = make_chill_pointer_type (to_type, POINTER_TYPE);
+
+ /* Lay out the type. This function has many callers that are concerned
+ with expression-construction, and this simplifies them all.
+ Also, it guarantees the TYPE_SIZE is permanent if the type is. */
+ if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE))
+ || pass == 2)
+ {
+ /* Record this type as the pointer to TO_TYPE. */
+ TYPE_POINTER_TO (to_type) = t;
+ layout_type (t);
+ }
+
+ return t;
+}
+
+tree
+build_chill_reference_type (to_type)
+ tree to_type;
+{
+ int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't';
+ register tree t = is_type_node ? TYPE_REFERENCE_TO (to_type) : NULL_TREE;
+
+ /* First, if we already have a type for references to TO_TYPE, use it. */
+
+ if (t)
+ return t;
+
+ /* We need a new one. */
+ t = make_chill_pointer_type (to_type, REFERENCE_TYPE);
+
+ /* Lay out the type. This function has many callers that are concerned
+ with expression-construction, and this simplifies them all.
+ Also, it guarantees the TYPE_SIZE is permanent if the type is. */
+ if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE))
+ || pass == 2)
+ {
+ /* Record this type as the reference to TO_TYPE. */
+ TYPE_REFERENCE_TO (to_type) = t;
+ layout_type (t);
+ CH_NOVELTY (t) = CH_NOVELTY (to_type);
+ }
+
+ return t;
+}
+\f
+tree
+make_chill_range_type (type, lowval, highval)
+ tree type, lowval, highval;
+{
+ register tree itype = make_node (INTEGER_TYPE);
+ TREE_TYPE (itype) = type;
+ TYPE_MIN_VALUE (itype) = lowval;
+ TYPE_MAX_VALUE (itype) = highval;
+ return itype;
+}
+
+tree
+layout_chill_range_type (rangetype, must_be_const)
+ tree rangetype;
+ int must_be_const;
+{
+ tree type = TREE_TYPE (rangetype);
+ tree lowval = TYPE_MIN_VALUE (rangetype);
+ tree highval = TYPE_MAX_VALUE (rangetype);
+ int bad_limits = 0;
+
+ if (TYPE_SIZE (rangetype) != NULL_TREE)
+ return rangetype;
+
+ /* process BIN */
+ if (type == ridpointers[(int) RID_BIN])
+ {
+ int binsize;
+
+ /* make a range out of it */
+ if (TREE_CODE (highval) != INTEGER_CST)
+ {
+ error ("non-constant expression for BIN");
+ return error_mark_node;
+ }
+ binsize = TREE_INT_CST_LOW (highval);
+ if (binsize < 0)
+ {
+ error ("expression for BIN must not be negative");
+ return error_mark_node;
+ }
+ if (binsize > 32)
+ {
+ error ("cannot process BIN (>32)");
+ return error_mark_node;
+ }
+ type = ridpointers [(int) RID_RANGE];
+ lowval = integer_zero_node;
+ highval = build_int_2 ((1 << binsize) - 1, 0);
+ }
+
+ if (TREE_CODE (lowval) == ERROR_MARK ||
+ TREE_CODE (highval) == ERROR_MARK)
+ return error_mark_node;
+
+ if (!CH_COMPATIBLE_CLASSES (lowval, highval))
+ {
+ error ("bounds of range are not compatible");
+ return error_mark_node;
+ }
+
+ if (type == string_index_type_dummy)
+ {
+ if (TREE_CODE (highval) == INTEGER_CST
+ && compare_int_csts (LT_EXPR, highval, integer_minus_one_node))
+ {
+ error ("negative string length");
+ highval = integer_minus_one_node;
+ }
+ if (compare_int_csts (EQ_EXPR, highval, integer_minus_one_node))
+ type = integer_type_node;
+ else
+ type = sizetype;
+ TREE_TYPE (rangetype) = type;
+ }
+ else if (type == ridpointers[(int) RID_RANGE])
+ {
+ /* This isn't 100% right, since the Blue Book definition
+ uses Resulting Class, rather than Resulting Mode,
+ but it's close enough. */
+ type = CH_ROOT_RESULTING_CLASS (lowval, highval).mode;
+
+ /* The default TYPE is the type of the constants -
+ except if the constants are integers, we choose an
+ integer type that fits. */
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && TREE_CODE (lowval) == INTEGER_CST
+ && TREE_CODE (highval) == INTEGER_CST)
+ {
+ /* The logic of this code has been copied from finish_enum
+ in c-decl.c. FIXME duplication! */
+ int precision = 0;
+ HOST_WIDE_INT maxvalue = TREE_INT_CST_LOW (highval);
+ HOST_WIDE_INT minvalue = TREE_INT_CST_LOW (lowval);
+ if (TREE_INT_CST_HIGH (lowval) >= 0
+ ? tree_int_cst_lt (TYPE_MAX_VALUE (unsigned_type_node), highval)
+ : (tree_int_cst_lt (lowval, TYPE_MIN_VALUE (integer_type_node))
+ || tree_int_cst_lt (TYPE_MAX_VALUE (integer_type_node), highval)))
+ precision = TYPE_PRECISION (long_long_integer_type_node);
+ else
+ {
+ if (maxvalue > 0)
+ precision = floor_log2 (maxvalue) + 1;
+ if (minvalue < 0)
+ {
+ /* Compute number of bits to represent magnitude of a
+ negative value. Add one to MINVALUE since range of
+ negative numbers includes the power of two. */
+ unsigned negprecision = floor_log2 (-minvalue - 1) + 1;
+ if (negprecision > precision)
+ precision = negprecision;
+ precision += 1; /* room for sign bit */
+ }
+
+ if (!precision)
+ precision = 1;
+ }
+ type = type_for_size (precision, minvalue >= 0);
+
+ }
+ TREE_TYPE (rangetype) = type;
+ }
+ else
+ {
+ if (!CH_COMPATIBLE (lowval, type))
+ {
+ error ("range's lower bound and parent mode don't match");
+ return integer_type_node; /* an innocuous fake */
+ }
+ if (!CH_COMPATIBLE (highval, type))
+ {
+ error ("range's upper bound and parent mode don't match");
+ return integer_type_node; /* an innocuous fake */
+ }
+ }
+
+ if (TREE_CODE (type) == ERROR_MARK)
+ return type;
+ else if (TREE_CODE_CLASS (TREE_CODE (type)) != 't')
+ {
+ error ("making range from non-mode");
+ return error_mark_node;
+ }
+
+ if (TREE_CODE (lowval) == REAL_CST || TREE_CODE (highval) == REAL_CST)
+ {
+ sorry ("floating point ranges");
+ return integer_type_node; /* another fake */
+ }
+
+ if (TREE_CODE (lowval) != INTEGER_CST || TREE_CODE (highval) != INTEGER_CST)
+ {
+ if (must_be_const)
+ {
+ error ("range mode has non-constant limits");
+ bad_limits = 1;
+ }
+ }
+ else if (tree_int_cst_equal (lowval, integer_zero_node)
+ && tree_int_cst_equal (highval, integer_minus_one_node))
+ ; /* do nothing - this is the index type for an empty string */
+ else if (compare_int_csts (LT_EXPR, highval, TYPE_MIN_VALUE (type)))
+ {
+ error ("range's high bound < mode's low bound");
+ bad_limits = 1;
+ }
+ else if (compare_int_csts (GT_EXPR, highval, TYPE_MAX_VALUE (type)))
+ {
+ error ("range's high bound > mode's high bound");
+ bad_limits = 1;
+ }
+ else if (compare_int_csts (LT_EXPR, highval, lowval))
+ {
+ error ("range mode high bound < range mode low bound");
+ bad_limits = 1;
+ }
+ else if (compare_int_csts (LT_EXPR, lowval, TYPE_MIN_VALUE (type)))
+ {
+ error ("range's low bound < mode's low bound");
+ bad_limits = 1;
+ }
+ else if (compare_int_csts (GT_EXPR, lowval, TYPE_MAX_VALUE (type)))
+ {
+ error ("range's low bound > mode's high bound");
+ bad_limits = 1;
+ }
+
+ if (bad_limits)
+ {
+ lowval = TYPE_MIN_VALUE (type);
+ highval = lowval;
+ }
+
+ highval = convert (type, highval);
+ lowval = convert (type, lowval);
+ TYPE_MIN_VALUE (rangetype) = lowval;
+ TYPE_MAX_VALUE (rangetype) = highval;
+ TYPE_PRECISION (rangetype) = TYPE_PRECISION (type);
+ TYPE_MODE (rangetype) = TYPE_MODE (type);
+ TYPE_SIZE (rangetype) = TYPE_SIZE (type);
+ TYPE_ALIGN (rangetype) = TYPE_ALIGN (type);
+ TREE_UNSIGNED (rangetype) = TREE_UNSIGNED (type);
+ CH_NOVELTY (rangetype) = CH_NOVELTY (type);
+ return rangetype;
+}
+
+/* Build a _TYPE node that has range bounds associated with its values.
+ TYPE is the base type for the range type. */
+tree
+build_chill_range_type (type, lowval, highval)
+ tree type, lowval, highval;
+{
+ tree rangetype;
+
+ if (type == NULL_TREE)
+ type = ridpointers[(int) RID_RANGE];
+ else if (TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+
+ rangetype = make_chill_range_type (type, lowval, highval);
+ if (pass != 1)
+ rangetype = layout_chill_range_type (rangetype, 0);
+
+ return rangetype;
+}
+
+/* Build a CHILL array type, but with minimal checking etc. */
+
+tree
+build_simple_array_type (type, idx, layout)
+ tree type, idx, layout;
+{
+ tree array_type = make_node (ARRAY_TYPE);
+ TREE_TYPE (array_type) = type;
+ TYPE_DOMAIN (array_type) = idx;
+ TYPE_ATTRIBUTES (array_type) = layout;
+ if (pass != 1)
+ array_type = layout_chill_array_type (array_type);
+ return array_type;
+}
+
+static void
+apply_chill_array_layout (array_type)
+ tree array_type;
+{
+ tree layout, temp, what, element_type;
+ int stepsize, word, start_bit, offset, length, natural_length;
+ int stepsize_specified;
+ int start_bit_error = 0;
+ int length_error = 0;
+
+ layout = TYPE_ATTRIBUTES (array_type);
+ if (layout == NULL_TREE)
+ return;
+
+ if (layout == integer_zero_node) /* NOPACK */
+ {
+ TYPE_PACKED (array_type) = 0;
+ return;
+ }
+
+ /* Allow for the packing of 1 bit discrete modes at the bit level. */
+ element_type = TREE_TYPE (array_type);
+ if (discrete_type_p (element_type)
+ && get_type_precision (TYPE_MIN_VALUE (element_type),
+ TYPE_MAX_VALUE (element_type)) == 1)
+ natural_length = 1;
+ else
+ natural_length = TREE_INT_CST_LOW (TYPE_SIZE (element_type));
+
+ if (layout == integer_one_node) /* PACK */
+ {
+ if (natural_length == 1)
+ TYPE_PACKED (array_type) = 1;
+ return;
+ }
+
+ /* The layout is a STEP (...).
+ The current implementation restricts STEP specifications to be of the form
+ STEP(POS(0,0,n),n) where n is the natural size of the element mode. */
+ stepsize_specified = 0;
+ temp = TREE_VALUE (layout);
+ if (TREE_VALUE (temp) != NULL_TREE)
+ {
+ if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
+ error ("Stepsize in STEP must be an integer constant");
+ else
+ {
+ stepsize = TREE_INT_CST_LOW (TREE_VALUE (temp));
+ if (stepsize <= 0)
+ error ("Stepsize in STEP must be > 0");
+ else
+ stepsize_specified = 1;
+
+ if (stepsize != natural_length)
+ sorry ("Stepsize in STEP must be the natural width of "
+ "the array element mode");
+ }
+ }
+
+ temp = TREE_PURPOSE (temp);
+ if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
+ error ("Starting word in POS must be an integer constant");
+ else
+ {
+ word = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
+ if (word < 0)
+ error ("Starting word in POS must be >= 0");
+ if (word != 0)
+ sorry ("Starting word in POS within STEP must be 0");
+ }
+
+ length = natural_length;
+ temp = TREE_VALUE (temp);
+ if (temp != NULL_TREE)
+ {
+ int wordsize = TYPE_PRECISION (chill_integer_type_node);
+ if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
+ {
+ error ("Starting bit in POS must be an integer constant");
+ start_bit_error = 1;
+ }
+ else
+ {
+ start_bit = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
+ if (start_bit != 0)
+ sorry ("Starting bit in POS within STEP must be 0");
+ if (start_bit < 0)
+ {
+ error ("Starting bit in POS must be >= 0");
+ start_bit = 0;
+ start_bit_error = 1;
+ }
+ else if (start_bit >= wordsize)
+ {
+ error ("Starting bit in POS must be < the width of a word");
+ start_bit = 0;
+ start_bit_error = 1;
+ }
+ }
+
+ temp = TREE_VALUE (temp);
+ if (temp != NULL_TREE)
+ {
+ what = TREE_PURPOSE (temp);
+ if (what == integer_zero_node)
+ {
+ if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
+ {
+ error ("Length in POS must be an integer constant");
+ length_error = 1;
+ }
+ else
+ {
+ length = TREE_INT_CST_LOW (TREE_VALUE (temp));
+ if (length <= 0)
+ error ("Length in POS must be > 0");
+ }
+ }
+ else
+ {
+ if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
+ {
+ error ("End bit in POS must be an integer constant");
+ length_error = 1;
+ }
+ else
+ {
+ int end_bit = TREE_INT_CST_LOW (TREE_VALUE (temp));
+ if (end_bit < start_bit)
+ {
+ error ("End bit in POS must be >= the start bit");
+ end_bit = wordsize - 1;
+ length_error = 1;
+ }
+ else if (end_bit >= wordsize)
+ {
+ error ("End bit in POS must be < the width of a word");
+ end_bit = wordsize - 1;
+ length_error = 1;
+ }
+ else if (start_bit_error)
+ length_error = 1;
+ else
+ length = end_bit - start_bit + 1;
+ }
+ }
+ if (! length_error && length != natural_length)
+ {
+ sorry ("The length specified on POS within STEP must be "
+ "the natural length of the array element type");
+ }
+ }
+ }
+
+ if (! length_error && stepsize_specified && stepsize < length)
+ error ("Step size in STEP must be >= the length in POS");
+
+ if (length == 1)
+ TYPE_PACKED (array_type) = 1;
+}
+
+tree
+layout_chill_array_type (array_type)
+ tree array_type;
+{
+ tree itype;
+ tree element_type = TREE_TYPE (array_type);
+
+ if (TREE_CODE (element_type) == ARRAY_TYPE
+ && TYPE_SIZE (element_type) == 0)
+ layout_chill_array_type (element_type);
+
+ itype = TYPE_DOMAIN (array_type);
+
+ if (TREE_CODE (itype) == ERROR_MARK
+ || TREE_CODE (element_type) == ERROR_MARK)
+ return error_mark_node;
+
+ /* do a lower/upper bound check. */
+ if (TREE_CODE (itype) == INTEGER_CST)
+ {
+ error ("array index must be a range, not a single integer");
+ return error_mark_node;
+ }
+ if (TREE_CODE_CLASS (TREE_CODE (itype)) != 't'
+ || !discrete_type_p (itype))
+ {
+ error ("array index is not a discrete mode");
+ return error_mark_node;
+ }
+
+ /* apply the array layout, if specified. */
+ apply_chill_array_layout (array_type);
+ TYPE_ATTRIBUTES (array_type) = NULL_TREE;
+
+ /* Make sure TYPE_POINTER_TO (element_type) is filled in. */
+ build_pointer_type (element_type);
+
+ if (TYPE_SIZE (array_type) == 0)
+ layout_type (array_type);
+
+ if (TYPE_READONLY_PROPERTY (element_type))
+ TYPE_FIELDS_READONLY (array_type) = 1;
+
+ TYPE_ARRAY_MAX_SIZE (array_type) = size_in_bytes (array_type);
+ return array_type;
+}
+
+/* Build a CHILL array type.
+
+ TYPE is the element type of the array.
+ IDXLIST is the list of dimensions of the array.
+ VARYING_P is non-zero if the array is a varying array.
+ LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
+ meaning (default, pack, nopack, STEP (...) ). */
+tree
+build_chill_array_type (type, idxlist, varying_p, layouts)
+ tree type, idxlist;
+ int varying_p;
+ tree layouts;
+{
+ tree array_type = type;
+
+ if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+ return error_mark_node;
+ if (idxlist == NULL_TREE || TREE_CODE (idxlist) == ERROR_MARK)
+ return error_mark_node;
+
+ /* We have to walk down the list of index decls, building inner
+ array types as we go. We need to reverse the list of layouts so that the
+ first layout applies to the last index etc. */
+ layouts = nreverse (layouts);
+ for ( ; idxlist; idxlist = TREE_CHAIN (idxlist))
+ {
+ if (layouts != NULL_TREE)
+ {
+ type = build_simple_array_type (
+ type, TREE_VALUE (idxlist), TREE_VALUE (layouts));
+ layouts = TREE_CHAIN (layouts);
+ }
+ else
+ type = build_simple_array_type (type, TREE_VALUE (idxlist), NULL_TREE);
+ }
+ array_type = type;
+ if (varying_p)
+ array_type = build_varying_struct (array_type);
+ return array_type;
+}
+
+/* Function to help qsort sort FIELD_DECLs by name order. */
+
+static int
+field_decl_cmp (x, y)
+ tree *x, *y;
+{
+ return (long)DECL_NAME (*x) - (long)DECL_NAME (*y);
+}
+
+tree
+make_chill_struct_type (fieldlist)
+ tree fieldlist;
+{
+ tree t, x;
+ if (TREE_UNION_ELEM (fieldlist))
+ t = make_node (UNION_TYPE);
+ else
+ t = make_node (RECORD_TYPE);
+ /* Install struct as DECL_CONTEXT of each field decl. */
+ for (x = fieldlist; x; x = TREE_CHAIN (x))
+ {
+ DECL_CONTEXT (x) = t;
+ DECL_FIELD_SIZE (x) = 0;
+ }
+
+ /* Delete all duplicate fields from the fieldlist */
+ for (x = fieldlist; x && TREE_CHAIN (x);)
+ /* Anonymous fields aren't duplicates. */
+ if (DECL_NAME (TREE_CHAIN (x)) == 0)
+ x = TREE_CHAIN (x);
+ else
+ {
+ register tree y = fieldlist;
+
+ while (1)
+ {
+ if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x)))
+ break;
+ if (y == x)
+ break;
+ y = TREE_CHAIN (y);
+ }
+ if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x)))
+ {
+ error_with_decl (TREE_CHAIN (x), "duplicate member `%s'");
+ TREE_CHAIN (x) = TREE_CHAIN (TREE_CHAIN (x));
+ }
+ else x = TREE_CHAIN (x);
+ }
+
+ TYPE_FIELDS (t) = fieldlist;
+
+ return t;
+}
+
+/* decl is a FIELD_DECL.
+ DECL_INIT (decl) is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
+ meaning (default, pack, nopack, POS (...) ).
+ The return value is a boolean: 1 if POS specified, 0 if not */
+static int
+apply_chill_field_layout (decl, next_struct_offset)
+ tree decl;
+ int* next_struct_offset;
+{
+ tree layout, type, temp, what;
+ int word, wordsize, start_bit, offset, length, natural_length;
+ int pos_error = 0;
+ int is_discrete;
+
+ type = TREE_TYPE (decl);
+ is_discrete = discrete_type_p (type);
+ if (is_discrete)
+ natural_length = get_type_precision (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
+ else
+ natural_length = TREE_INT_CST_LOW (TYPE_SIZE (type));
+
+ layout = DECL_INITIAL (decl);
+ if (layout == integer_zero_node) /* NOPACK */
+ {
+ DECL_PACKED (decl) = 0;
+ *next_struct_offset += natural_length;
+ return 0; /* not POS */
+ }
+
+ if (layout == integer_one_node) /* PACK */
+ {
+ if (is_discrete)
+ DECL_BIT_FIELD (decl) = 1;
+ else
+ {
+ DECL_BIT_FIELD (decl) = 0;
+ DECL_ALIGN (decl) = BITS_PER_UNIT;
+ }
+ DECL_PACKED (decl) = 1;
+ DECL_FIELD_SIZE (decl) = natural_length;
+ *next_struct_offset += natural_length;
+ return 0; /* not POS */
+ }
+
+ /* The layout is a POS (...). The current implementation restricts the use
+ of POS to monotonically increasing fields whose width must be the
+ natural width of the underlying type. */
+ temp = TREE_PURPOSE (layout);
+
+ if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
+ {
+ error ("Starting word in POS must be an integer constant");
+ pos_error = 1;
+ }
+ else
+ {
+ word = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
+ if (word < 0)
+ {
+ error ("Starting word in POS must be >= 0");
+ word = 0;
+ pos_error = 1;
+ }
+ }
+
+ wordsize = TYPE_PRECISION (chill_integer_type_node);
+ offset = word * wordsize;
+ length = natural_length;
+
+ temp = TREE_VALUE (temp);
+ if (temp != NULL_TREE)
+ {
+ if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
+ {
+ error ("Starting bit in POS must be an integer constant");
+ start_bit = *next_struct_offset - offset;
+ pos_error = 1;
+ }
+ else
+ {
+ start_bit = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
+ if (start_bit < 0)
+ {
+ error ("Starting bit in POS must be >= 0");
+ start_bit = *next_struct_offset - offset;
+ pos_error = 1;
+ }
+ else if (start_bit >= wordsize)
+ {
+ error ("Starting bit in POS must be < the width of a word");
+ start_bit = *next_struct_offset - offset;
+ pos_error = 1;
+ }
+ }
+
+ temp = TREE_VALUE (temp);
+ if (temp != NULL_TREE)
+ {
+ what = TREE_PURPOSE (temp);
+ if (what == integer_zero_node)
+ {
+ if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
+ {
+ error ("Length in POS must be an integer constant");
+ pos_error = 1;
+ }
+ else
+ {
+ length = TREE_INT_CST_LOW (TREE_VALUE (temp));
+ if (length <= 0)
+ {
+ error ("Length in POS must be > 0");
+ length = natural_length;
+ pos_error = 1;
+ }
+ }
+ }
+ else
+ {
+ if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
+ {
+ error ("End bit in POS must be an integer constant");
+ pos_error = 1;
+ }
+ else
+ {
+ int end_bit = TREE_INT_CST_LOW (TREE_VALUE (temp));
+ if (end_bit < start_bit)
+ {
+ error ("End bit in POS must be >= the start bit");
+ pos_error = 1;
+ }
+ else if (end_bit >= wordsize)
+ {
+ error ("End bit in POS must be < the width of a word");
+ pos_error = 1;
+ }
+ else
+ length = end_bit - start_bit + 1;
+ }
+ }
+ if (length != natural_length && ! pos_error)
+ {
+ sorry ("The length specified on POS must be the natural length "
+ "of the field type");
+ length = natural_length;
+ }
+ }
+
+ offset += start_bit;
+ }
+
+ if (offset != *next_struct_offset && ! pos_error)
+ sorry ("STRUCT fields must be layed out in monotonically increasing order");
+
+ DECL_PACKED (decl) = 1;
+ DECL_BIT_FIELD (decl) = is_discrete;
+ DECL_FIELD_SIZE (decl) = length;
+ *next_struct_offset += natural_length;
+
+ return 1; /* was POS */
+}
+
+tree
+layout_chill_struct_type (t)
+ tree t;
+{
+ tree fieldlist = TYPE_FIELDS (t);
+ tree x;
+ int old_momentary;
+ int was_pos;
+ int pos_seen = 0;
+ int pos_error = 0;
+ int next_struct_offset;
+
+ old_momentary = suspend_momentary ();
+
+ /* Process specified field sizes.
+ Set DECL_FIELD_SIZE to the specified size, or 0 if none specified.
+ The specified size is found in the DECL_INITIAL.
+ Store 0 there, except for ": 0" fields (so we can find them
+ and delete them, below). */
+
+ next_struct_offset = 0;
+ for (x = fieldlist; x; x = TREE_CHAIN (x))
+ {
+ /* An EVENT or BUFFER mode is implemented as a RECORD_TYPE
+ which may contain a CONST_DECL for the maximum queue size. */
+ if (TREE_CODE (x) == CONST_DECL)
+ continue;
+
+ /* If any field is const, the structure type is pseudo-const. */
+ /* A field that is pseudo-const makes the structure likewise. */
+ if (TREE_READONLY (x) || TYPE_READONLY_PROPERTY (TREE_TYPE (x)))
+ TYPE_FIELDS_READONLY (t) = 1;
+
+ /* Any field that is volatile means variables of this type must be
+ treated in some ways as volatile. */
+ if (TREE_THIS_VOLATILE (x))
+ C_TYPE_FIELDS_VOLATILE (t) = 1;
+
+ if (DECL_INITIAL (x) != NULL_TREE)
+ {
+ was_pos = apply_chill_field_layout (x, &next_struct_offset);
+ DECL_INITIAL (x) = NULL_TREE;
+ }
+ else
+ {
+ int min_align = TYPE_ALIGN (TREE_TYPE (x));
+ DECL_ALIGN (x) = MAX (DECL_ALIGN (x), min_align);
+ was_pos = 0;
+ }
+ if ((! was_pos && pos_seen) || (was_pos && ! pos_seen && x != fieldlist))
+ pos_error = 1;
+ pos_seen |= was_pos;
+ }
+
+ if (pos_error)
+ error ("If one field has a POS layout, then all fields must have a POS layout");
+
+ /* Now DECL_INITIAL is null on all fields. */
+
+ layout_type (t);
+
+ /* Now we have the truly final field list.
+ Store it in this type and in the variants. */
+
+ TYPE_FIELDS (t) = fieldlist;
+
+ /* If there are lots of fields, sort so we can look through them fast.
+ We arbitrarily consider 16 or more elts to be "a lot". */
+ {
+ int len = 0;
+
+ for (x = fieldlist; x; x = TREE_CHAIN (x))
+ {
+ if (len > 15)
+ break;
+ len += 1;
+ }
+ if (len > 15)
+ {
+ tree *field_array;
+ char *space;
+
+ len += list_length (x);
+ /* Use the same allocation policy here that make_node uses, to
+ ensure that this lives as long as the rest of the struct decl.
+ All decls in an inline function need to be saved. */
+ if (allocation_temporary_p ())
+ space = savealloc (sizeof (struct lang_type) + len * sizeof (tree));
+ else
+ space = oballoc (sizeof (struct lang_type) + len * sizeof (tree));
+
+ TYPE_LANG_SPECIFIC (t) = (struct lang_type *) space;
+ TYPE_LANG_SPECIFIC (t)->foo.rec.len = len;
+
+ field_array = &TYPE_LANG_SPECIFIC (t)->foo.rec.elts[0];
+ len = 0;
+ for (x = fieldlist; x; x = TREE_CHAIN (x))
+ field_array[len++] = x;
+
+ qsort (field_array, len, sizeof (tree), field_decl_cmp);
+ }
+ }
+
+ for (x = TYPE_MAIN_VARIANT (t); x; x = TYPE_NEXT_VARIANT (x))
+ {
+ TYPE_FIELDS (x) = TYPE_FIELDS (t);
+ TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (t);
+ TYPE_ALIGN (x) = TYPE_ALIGN (t);
+ }
+
+ resume_momentary (old_momentary);
+
+ return t;
+}
+
+/* Given a list of fields, FIELDLIST, return a structure
+ type that contains these fields. The returned type is
+ always a new type. */
+tree
+build_chill_struct_type (fieldlist)
+ tree fieldlist;
+{
+ register tree t;
+
+ if (fieldlist == NULL_TREE || TREE_CODE (fieldlist) == ERROR_MARK)
+ return error_mark_node;
+
+ t = make_chill_struct_type (fieldlist);
+ if (pass != 1)
+ t = layout_chill_struct_type (t);
+
+/* pushtag (NULL_TREE, t); */
+
+ return t;
+}
+
+/* Fix a LANG_TYPE. These are used for three different uses:
+ - representing a 'READ M' (in which case TYPE_READONLY is set);
+ - for a NEWMODE or SYNMODE (CH_NOVELTY is set for a NEWMODE); and
+ - for a parameterised type (TREE_TYPE points to base type,
+ while TYPE_DOMAIN is the parameter or parameter list).
+ Called from satisfy. */
+tree
+smash_dummy_type (type)
+ tree type;
+{
+ /* Save fields that we don't want to copy from ORIGIN. */
+ tree origin = TREE_TYPE (type);
+ tree main = TYPE_MAIN_VARIANT (origin);
+ int save_uid = TYPE_UID (type);
+ struct obstack *save_obstack = TYPE_OBSTACK (type);
+ tree save_name = TYPE_NAME (type);
+ int save_permanent = TREE_PERMANENT (type);
+ int save_readonly = TYPE_READONLY (type);
+ tree save_novelty = CH_NOVELTY (type);
+ tree save_domain = TYPE_DOMAIN (type);
+ struct lang_type *save_lang_specific = TYPE_LANG_SPECIFIC (type);
+
+ if (origin == NULL_TREE)
+ abort ();
+
+ if (save_domain)
+ {
+ if (TREE_CODE (save_domain) == ERROR_MARK)
+ return error_mark_node;
+ if (origin == char_type_node)
+ { /* Old-fashioned CHAR(N) declaration. */
+ origin = build_string_type (origin, save_domain);
+ }
+ else
+ { /* Handle parameterised modes. */
+ int is_varying = chill_varying_type_p (origin);
+ tree new_max = save_domain;
+ tree origin_novelty = CH_NOVELTY (origin);
+ if (is_varying)
+ origin = CH_VARYING_ARRAY_TYPE (origin);
+ if (CH_STRING_TYPE_P (origin))
+ {
+ tree oldindex = TYPE_DOMAIN (origin);
+ new_max = check_range (new_max, new_max, NULL_TREE,
+ size_binop (PLUS_EXPR,
+ TYPE_MAX_VALUE (oldindex),
+ integer_one_node));
+ origin = build_string_type (TREE_TYPE (origin), new_max);
+ }
+ else if (TREE_CODE (origin) == ARRAY_TYPE)
+ {
+ tree oldindex = TYPE_DOMAIN (origin);
+ tree upper = check_range (new_max, new_max, NULL_TREE,
+ TYPE_MAX_VALUE (oldindex));
+ tree newindex
+ = build_chill_range_type (TREE_TYPE (oldindex),
+ TYPE_MIN_VALUE (oldindex), upper);
+ origin = build_simple_array_type (TREE_TYPE (origin), newindex, NULL_TREE);
+ }
+ else if (TREE_CODE (origin) == RECORD_TYPE)
+ {
+ error ("parameterised structures not implemented");
+ return error_mark_node;
+ }
+ else
+ {
+ error ("invalid parameterised type");
+ return error_mark_node;
+ }
+
+ SET_CH_NOVELTY (origin, origin_novelty);
+ if (is_varying)
+ {
+ origin = build_varying_struct (origin);
+ SET_CH_NOVELTY (origin, origin_novelty);
+ }
+ }
+ save_domain = NULL_TREE;
+ }
+
+ if (TREE_CODE (origin) == ERROR_MARK)
+ return error_mark_node;
+
+ *(struct tree_type*)type = *(struct tree_type*)origin;
+ /* The following is so that the debug code for
+ the copy is different from the original type.
+ The two statements usually duplicate each other
+ (because they clear fields of the same union),
+ but the optimizer should catch that. */
+ TYPE_SYMTAB_POINTER (type) = 0;
+ TYPE_SYMTAB_ADDRESS (type) = 0;
+
+ /* Restore fields that we didn't want copied from ORIGIN. */
+ TYPE_UID (type) = save_uid;
+ TYPE_OBSTACK (type) = save_obstack;
+ TREE_PERMANENT (type) = save_permanent;
+ TYPE_NAME (type) = save_name;
+
+ TREE_CHAIN (type) = NULL_TREE;
+ TYPE_VOLATILE (type) = 0;
+ TYPE_POINTER_TO (type) = 0;
+ TYPE_REFERENCE_TO (type) = 0;
+
+ if (save_readonly)
+ { /* TYPE is READ ORIGIN.
+ Add this type to the chain of variants of TYPE. */
+ TYPE_NEXT_VARIANT (type) = TYPE_NEXT_VARIANT (main);
+ TYPE_NEXT_VARIANT (main) = type;
+ TYPE_READONLY (type) = save_readonly;
+ }
+ else
+ {
+ /* TYPE is the copy of the RHS in a NEWMODE or SYNMODE.
+ We also get here after old-fashioned CHAR(N) declaration (see above). */
+ TYPE_MAIN_VARIANT (type) = type;
+ TYPE_NEXT_VARIANT (type) = NULL_TREE;
+ if (save_name)
+ DECL_ORIGINAL_TYPE (save_name) = origin;
+
+ if (save_novelty != NULL_TREE) /* A NEWMODE declaration. */
+ {
+ CH_NOVELTY (type) = save_novelty;
+
+ /* Z.200: "If the DEFINING mode of the NEWMODE name is a range mode,
+ then the virtual mode &name is introduced as the PARENT mode
+ of the NEWMODE name. The DEFINING mode of &name is the PARENT
+ mode of the range mode, and the NOVELTY of &name is that of
+ the NEWMODE name." */
+
+ if (TREE_CODE (type) == INTEGER_TYPE && TREE_TYPE (type))
+ {
+ tree parent;
+ /* PARENT is the virtual mode &name mentioned above. */
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+ parent = copy_novelty (save_novelty,TREE_TYPE (type));
+ pop_obstacks ();
+
+ TREE_TYPE (type) = parent;
+ TYPE_MIN_VALUE (type) = convert (parent, TYPE_MIN_VALUE (type));
+ TYPE_MAX_VALUE (type) = convert (parent, TYPE_MAX_VALUE (type));
+ }
+ }
+ }
+ return type;
+}
+
+/* This generates a LANG_TYPE node that represents 'READ TYPE'. */
+
+tree
+build_readonly_type (type)
+ tree type;
+{
+ tree node = make_node (LANG_TYPE);
+ TREE_TYPE (node) = type;
+ TYPE_READONLY (node) = 1;
+ if (pass != 1)
+ node = smash_dummy_type (node);
+ return node;
+}
+
+\f
+/* Return an unsigned type the same as TYPE in other respects. */
+
+tree
+unsigned_type (type)
+ tree type;
+{
+ tree type1 = TYPE_MAIN_VARIANT (type);
+ if (type1 == signed_char_type_node || type1 == char_type_node)
+ return unsigned_char_type_node;
+ if (type1 == integer_type_node)
+ return unsigned_type_node;
+ if (type1 == short_integer_type_node)
+ return short_unsigned_type_node;
+ if (type1 == long_integer_type_node)
+ return long_unsigned_type_node;
+ if (type1 == long_long_integer_type_node)
+ return long_long_unsigned_type_node;
+
+ return signed_or_unsigned_type (1, type);
+}
+
+/* Return a signed type the same as TYPE in other respects. */
+
+tree
+signed_type (type)
+ tree type;
+{
+ tree type1 = TYPE_MAIN_VARIANT (type);
+ while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE)
+ type1 = TREE_TYPE (type1);
+ if (type1 == unsigned_char_type_node || type1 == char_type_node)
+ return signed_char_type_node;
+ if (type1 == unsigned_type_node)
+ return integer_type_node;
+ if (type1 == short_unsigned_type_node)
+ return short_integer_type_node;
+ if (type1 == long_unsigned_type_node)
+ return long_integer_type_node;
+ if (type1 == long_long_unsigned_type_node)
+ return long_long_integer_type_node;
+ if (TYPE_PRECISION (type1) == 1)
+ return signed_boolean_type_node;
+
+ return signed_or_unsigned_type (0, type);
+}
+
+/* Return a type the same as TYPE except unsigned or
+ signed according to UNSIGNEDP. */
+
+tree
+signed_or_unsigned_type (unsignedp, type)
+ int unsignedp;
+ tree type;
+{
+ if (! INTEGRAL_TYPE_P (type)
+ || TREE_UNSIGNED (type) == unsignedp)
+ return type;
+
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
+ return (unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node);
+ return type;
+}
+\f
+/* Mark EXP saying that we need to be able to take the
+ address of it; it should not be allocated in a register.
+ Value is 1 if successful. */
+
+int
+mark_addressable (exp)
+ tree exp;
+{
+ register tree x = exp;
+ while (1)
+ switch (TREE_CODE (x))
+ {
+ case ADDR_EXPR:
+ case COMPONENT_REF:
+ case ARRAY_REF:
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ x = TREE_OPERAND (x, 0);
+ break;
+
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case COMPOUND_EXPR:
+ x = TREE_OPERAND (x, 1);
+ break;
+
+ case COND_EXPR:
+ return mark_addressable (TREE_OPERAND (x, 1))
+ & mark_addressable (TREE_OPERAND (x, 2));
+
+ case CONSTRUCTOR:
+ TREE_ADDRESSABLE (x) = 1;
+ return 1;
+
+ case INDIRECT_REF:
+ /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode
+ incompatibility problems. Handle this case by marking FOO. */
+ if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR
+ && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR)
+ {
+ x = TREE_OPERAND (TREE_OPERAND (x, 0), 0);
+ break;
+ }
+ if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR)
+ {
+ x = TREE_OPERAND (x, 0);
+ break;
+ }
+ return 1;
+
+ case VAR_DECL:
+ case CONST_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
+ && DECL_NONLOCAL (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ error ("global register variable `%s' used in nested function",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ return 0;
+ }
+ pedwarn ("register variable `%s' used in nested function",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ }
+ else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ error ("address of global register variable `%s' requested",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ return 0;
+ }
+
+ /* If we are making this addressable due to its having
+ volatile components, give a different error message. Also
+ handle the case of an unnamed parameter by not trying
+ to give the name. */
+
+ else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
+ {
+ error ("cannot put object with volatile field into register");
+ return 0;
+ }
+
+ pedwarn ("address of register variable `%s' requested",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
+ }
+ put_var_into_stack (x);
+
+ /* drops through */
+ case FUNCTION_DECL:
+ TREE_ADDRESSABLE (x) = 1;
+#if 0 /* poplevel deals with this now. */
+ if (DECL_CONTEXT (x) == 0)
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
+#endif
+ /* drops through */
+ default:
+ return 1;
+ }
+}
+\f
+/* Return nonzero if VALUE is a valid constant-valued expression
+ for use in initializing a static variable; one that can be an
+ element of a "constant" initializer.
+
+ Return null_pointer_node if the value is absolute;
+ if it is relocatable, return the variable that determines the relocation.
+ We assume that VALUE has been folded as much as possible;
+ therefore, we do not need to check for such things as
+ arithmetic-combinations of integers. */
+
+tree
+initializer_constant_valid_p (value, endtype)
+ tree value;
+ tree endtype;
+{
+ switch (TREE_CODE (value))
+ {
+ case CONSTRUCTOR:
+ if (TREE_CODE (TREE_TYPE (value)) == UNION_TYPE
+ && TREE_CONSTANT (value))
+ return
+ initializer_constant_valid_p (TREE_VALUE (CONSTRUCTOR_ELTS (value)),
+ endtype);
+
+ return TREE_STATIC (value) ? null_pointer_node : 0;
+
+ case INTEGER_CST:
+ case REAL_CST:
+ case STRING_CST:
+ case COMPLEX_CST:
+ return null_pointer_node;
+
+ case ADDR_EXPR:
+ return TREE_OPERAND (value, 0);
+
+ case NON_LVALUE_EXPR:
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
+
+ case CONVERT_EXPR:
+ case NOP_EXPR:
+ /* Allow conversions between pointer types. */
+ if (TREE_CODE (TREE_TYPE (value)) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == POINTER_TYPE)
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
+
+ /* Allow conversions between real types. */
+ if (TREE_CODE (TREE_TYPE (value)) == REAL_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == REAL_TYPE)
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
+
+ /* Allow length-preserving conversions between integer types. */
+ if (TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == INTEGER_TYPE
+ && (TYPE_PRECISION (TREE_TYPE (value))
+ == TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (value, 0)))))
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
+
+ /* Allow conversions between other integer types only if
+ explicit value. */
+ if (TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == INTEGER_TYPE)
+ {
+ tree inner = initializer_constant_valid_p (TREE_OPERAND (value, 0),
+ endtype);
+ if (inner == null_pointer_node)
+ return null_pointer_node;
+ return 0;
+ }
+
+ /* Allow (int) &foo provided int is as wide as a pointer. */
+ if (TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == POINTER_TYPE
+ && (TYPE_PRECISION (TREE_TYPE (value))
+ >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (value, 0)))))
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0),
+ endtype);
+
+ /* Likewise conversions from int to pointers. */
+ if (TREE_CODE (TREE_TYPE (value)) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == INTEGER_TYPE
+ && (TYPE_PRECISION (TREE_TYPE (value))
+ <= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (value, 0)))))
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0),
+ endtype);
+
+ /* Allow conversions to union types if the value inside is okay. */
+ if (TREE_CODE (TREE_TYPE (value)) == UNION_TYPE)
+ return initializer_constant_valid_p (TREE_OPERAND (value, 0),
+ endtype);
+ return 0;
+
+ case PLUS_EXPR:
+ if (TREE_CODE (endtype) == INTEGER_TYPE
+ && TYPE_PRECISION (endtype) < POINTER_SIZE)
+ return 0;
+ {
+ tree valid0 = initializer_constant_valid_p (TREE_OPERAND (value, 0),
+ endtype);
+ tree valid1 = initializer_constant_valid_p (TREE_OPERAND (value, 1),
+ endtype);
+ /* If either term is absolute, use the other terms relocation. */
+ if (valid0 == null_pointer_node)
+ return valid1;
+ if (valid1 == null_pointer_node)
+ return valid0;
+ return 0;
+ }
+
+ case MINUS_EXPR:
+ if (TREE_CODE (endtype) == INTEGER_TYPE
+ && TYPE_PRECISION (endtype) < POINTER_SIZE)
+ return 0;
+ {
+ tree valid0 = initializer_constant_valid_p (TREE_OPERAND (value, 0),
+ endtype);
+ tree valid1 = initializer_constant_valid_p (TREE_OPERAND (value, 1),
+ endtype);
+ /* Win if second argument is absolute. */
+ if (valid1 == null_pointer_node)
+ return valid0;
+ /* Win if both arguments have the same relocation.
+ Then the value is absolute. */
+ if (valid0 == valid1)
+ return null_pointer_node;
+ return 0;
+ }
+ }
+
+ return 0;
+}
+\f
+/* Return an integer type with BITS bits of precision,
+ that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
+
+tree
+type_for_size (bits, unsignedp)
+ unsigned bits;
+ int unsignedp;
+{
+ if (bits == TYPE_PRECISION (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
+
+ if (bits == TYPE_PRECISION (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+
+ if (bits == TYPE_PRECISION (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+
+ if (bits == TYPE_PRECISION (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+
+ if (bits == TYPE_PRECISION (long_long_integer_type_node))
+ return (unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node);
+
+ if (bits <= TYPE_PRECISION (intQI_type_node))
+ return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
+
+ if (bits <= TYPE_PRECISION (intHI_type_node))
+ return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
+
+ if (bits <= TYPE_PRECISION (intSI_type_node))
+ return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
+
+ if (bits <= TYPE_PRECISION (intDI_type_node))
+ return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
+
+ if (bits <= TYPE_PRECISION (intTI_type_node))
+ return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
+
+ return 0;
+}
+
+/* Return a data type that has machine mode MODE.
+ If the mode is an integer,
+ then UNSIGNEDP selects between signed and unsigned types. */
+
+tree
+type_for_mode (mode, unsignedp)
+ enum machine_mode mode;
+ int unsignedp;
+{
+ if (mode == TYPE_MODE (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
+
+ if (mode == TYPE_MODE (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+
+ if (mode == TYPE_MODE (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+
+ if (mode == TYPE_MODE (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+
+ if (mode == TYPE_MODE (long_long_integer_type_node))
+ return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
+
+ if (mode == TYPE_MODE (intQI_type_node))
+ return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
+
+ if (mode == TYPE_MODE (intHI_type_node))
+ return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
+
+ if (mode == TYPE_MODE (intSI_type_node))
+ return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
+
+ if (mode == TYPE_MODE (intDI_type_node))
+ return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
+
+ if (mode == TYPE_MODE (intTI_type_node))
+ return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
+
+ if (mode == TYPE_MODE (float_type_node))
+ return float_type_node;
+
+ if (mode == TYPE_MODE (double_type_node))
+ return double_type_node;
+
+ if (mode == TYPE_MODE (long_double_type_node))
+ return long_double_type_node;
+
+ if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
+ return build_pointer_type (char_type_node);
+
+ if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
+ return build_pointer_type (integer_type_node);
+
+ return 0;
+}
projects / gcc.git / commitdiff