From 3c79b2da6ba52fe9ae2ec45f9ed6774f3366db93 Mon Sep 17 00:00:00 2001 From: Per Bothner Date: Thu, 27 Aug 1998 13:51:39 -0700 Subject: [PATCH] =?UTF-8?q?=EF=BF=BD=20Migrate=20from=20devo/gcc/ch.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit From-SVN: r22038 --- gcc/ch/README | 42 + gcc/ch/actions.c | 1820 +++++++++++ gcc/ch/chill.in | 130 + gcc/ch/config-lang.in | 34 + gcc/ch/configure | 644 ++++ gcc/ch/convert.c | 1231 ++++++++ gcc/ch/decl.c | 5176 ++++++++++++++++++++++++++++++++ gcc/ch/expr.c | 4493 +++++++++++++++++++++++++++ gcc/ch/lang-specs.h | 42 + gcc/ch/lang.c | 306 ++ gcc/ch/parse.c | 4237 ++++++++++++++++++++++++++ gcc/ch/runtime/allmem.c | 73 + gcc/ch/runtime/andps.c | 76 + gcc/ch/runtime/auxtypes.h | 45 + gcc/ch/runtime/basicio.c | 467 +++ gcc/ch/runtime/bitstring.h | 29 + gcc/ch/runtime/cause.c | 48 + gcc/ch/runtime/concatps.c | 93 + gcc/ch/runtime/copyps.c | 111 + gcc/ch/runtime/eqps.c | 88 + gcc/ch/runtime/fileio.h | 153 + gcc/ch/runtime/flsetps.c | 107 + gcc/ch/runtime/format.h | 71 + gcc/ch/runtime/getassoc.c | 37 + gcc/ch/runtime/gettextaccess.c | 31 + gcc/ch/runtime/getusage.c | 40 + gcc/ch/runtime/inps.c | 65 + gcc/ch/runtime/ioerror.c | 45 + gcc/ch/runtime/ioerror.h | 161 + gcc/ch/runtime/iomodes.h | 251 ++ gcc/ch/runtime/ltps.c | 86 + gcc/ch/runtime/ltstr.c | 55 + gcc/ch/runtime/rts.h | 52 + gcc/ch/runtime/sliceps.c | 65 + gcc/ch/runtime/unhex.c | 57 + gcc/ch/runtime/unhex1.c | 58 + gcc/ch/satisfy.c | 628 ++++ gcc/ch/tasking.c | 3423 +++++++++++++++++++++ gcc/ch/timing.c | 494 +++ gcc/ch/typeck.c | 3905 ++++++++++++++++++++++++ 40 files changed, 28969 insertions(+) create mode 100644 gcc/ch/README create mode 100644 gcc/ch/actions.c create mode 100644 gcc/ch/chill.in create mode 100644 gcc/ch/config-lang.in create mode 100755 gcc/ch/configure create mode 100644 gcc/ch/convert.c create mode 100644 gcc/ch/decl.c create mode 100644 gcc/ch/expr.c create mode 100644 gcc/ch/lang-specs.h create mode 100644 gcc/ch/lang.c create mode 100644 gcc/ch/parse.c create mode 100644 gcc/ch/runtime/allmem.c create mode 100644 gcc/ch/runtime/andps.c create mode 100644 gcc/ch/runtime/auxtypes.h create mode 100644 gcc/ch/runtime/basicio.c create mode 100644 gcc/ch/runtime/bitstring.h create mode 100644 gcc/ch/runtime/cause.c create mode 100644 gcc/ch/runtime/concatps.c create mode 100644 gcc/ch/runtime/copyps.c create mode 100644 gcc/ch/runtime/eqps.c create mode 100644 gcc/ch/runtime/fileio.h create mode 100644 gcc/ch/runtime/flsetps.c create mode 100644 gcc/ch/runtime/format.h create mode 100644 gcc/ch/runtime/getassoc.c create mode 100644 gcc/ch/runtime/gettextaccess.c create mode 100644 gcc/ch/runtime/getusage.c create mode 100644 gcc/ch/runtime/inps.c create mode 100644 gcc/ch/runtime/ioerror.c create mode 100644 gcc/ch/runtime/ioerror.h create mode 100644 gcc/ch/runtime/iomodes.h create mode 100644 gcc/ch/runtime/ltps.c create mode 100644 gcc/ch/runtime/ltstr.c create mode 100644 gcc/ch/runtime/rts.h create mode 100644 gcc/ch/runtime/sliceps.c create mode 100644 gcc/ch/runtime/unhex.c create mode 100644 gcc/ch/runtime/unhex1.c create mode 100644 gcc/ch/satisfy.c create mode 100644 gcc/ch/tasking.c create mode 100644 gcc/ch/timing.c create mode 100644 gcc/ch/typeck.c diff --git a/gcc/ch/README b/gcc/ch/README new file mode 100644 index 00000000000..3dba9773bd4 --- /dev/null +++ b/gcc/ch/README @@ -0,0 +1,42 @@ +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 or +Per Bothner . + +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. diff --git a/gcc/ch/actions.c b/gcc/ch/actions.c new file mode 100644 index 00000000000..79bacf04c4f --- /dev/null +++ b/gcc/ch/actions.c @@ -0,0 +1,1820 @@ +/* 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 +#include +#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; + +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"); + } +} + +/* 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 + +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; +} + +/* + * 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; +} + +/* 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); +} + +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)); +} + +/* + * 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); + } + } +} + +/* 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 +} + +/* 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; +} + + +/* 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)); +} + +/* 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)); +} + +void +push_action () +{ + push_handler (); + if (ignoring) + return; + emit_line_note (input_filename, lineno); +} diff --git a/gcc/ch/chill.in b/gcc/ch/chill.in new file mode 100644 index 00000000000..62b73d5f961 --- /dev/null +++ b/gcc/ch/chill.in @@ -0,0 +1,130 @@ +#!/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 diff --git a/gcc/ch/config-lang.in b/gcc/ch/config-lang.in new file mode 100644 index 00000000000..48be2d9488d --- /dev/null +++ b/gcc/ch/config-lang.in @@ -0,0 +1,34 @@ +# 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*" diff --git a/gcc/ch/configure b/gcc/ch/configure new file mode 100755 index 00000000000..1179770cd48 --- /dev/null +++ b/gcc/ch/configure @@ -0,0 +1,644 @@ +#!/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 < 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/ //" -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 diff --git a/gcc/ch/convert.c b/gcc/ch/convert.c new file mode 100644 index 00000000000..d865336bf6f --- /dev/null +++ b/gcc/ch/convert.c @@ -0,0 +1,1231 @@ +/* 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; + +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; + } +} + +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); + +} + +#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 ""; + + 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; +} + +/* 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; +} diff --git a/gcc/ch/decl.c b/gcc/ch/decl.c new file mode 100644 index 00000000000..57842b03984 --- /dev/null +++ b/gcc/ch/decl.c @@ -0,0 +1,5176 @@ +/* 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 +#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; + +/* 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 + +/* 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; + +/* 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 (); + +/* 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; + +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); +} + +/* 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 "); +} + +/* 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; +} + +/* 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]; + } +} + +/* 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; +} + +/* + * 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; +} + +/* + * 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; +} + + + +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); +} + +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); +} + +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 (); + } + } +} + +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 (); +} + + + +/* 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; +} + +/* 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; +} + +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); +} + +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; +} + +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; +} + +/* 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); +} + +/* + 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; +} + +/* 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; +} + +/* 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 + +/* + * 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 + +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; +} + +/* + * 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; +} + +/* 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; +} + +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; +} + +/* 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; +}; + +/* 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; + } +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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 + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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"); +} + + +/* 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; +} + +/* 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 (); +} + +/* 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; +} + +#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); +} + +/* 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; +} + +/* 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; +} + +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 +} + +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 +} + +/* 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; +} + +/* Function needed for CHILL interface. */ +tree +get_parm_decls () +{ + return current_function_parms; +} + +/* 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); +} + +/* 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. +*/ + +/* + * 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"); + } +} + +/* + * 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))); +} + +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; +} + +/* 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); +} diff --git a/gcc/ch/expr.c b/gcc/ch/expr.c new file mode 100644 index 00000000000..16b1e3c6a10 --- /dev/null +++ b/gcc/ch/expr.c @@ -0,0 +1,4493 @@ +/* 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 +#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; + + +/* 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; +} + +/* 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; + } + + /* 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; +} + +/* 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; +} + +/* + * 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); +} + +/* 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); +} + +/* + * 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); +} + +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); +} + +/* 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; +} + +/* 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); +} + +/* + * 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; + } +} + +/* 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; +} + +/* 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; +} + +/* + * 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; + } +} + +/* + * 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); +} + +/* 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; +} + +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; +} + +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; +} + +/* + * 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; + } +} + +/* + * 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; +} + +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; +} + +/* + * 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); +} + +/* 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; +} + +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))); +} diff --git a/gcc/ch/lang-specs.h b/gcc/ch/lang-specs.h new file mode 100644 index 00000000000..be02c117e5e --- /dev/null +++ b/gcc/ch/lang-specs.h @@ -0,0 +1,42 @@ +/* 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 }}"}, diff --git a/gcc/ch/lang.c b/gcc/ch/lang.c new file mode 100644 index 00000000000..b52bca657eb --- /dev/null +++ b/gcc/ch/lang.c @@ -0,0 +1,306 @@ +/* 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 +#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)); + +/* 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"); +} + +/* + * 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; +} diff --git a/gcc/ch/parse.c b/gcc/ch/parse.c new file mode 100644 index 00000000000..32f72e5d249 --- /dev/null +++ b/gcc/ch/parse.c @@ -0,0 +1,4237 @@ +/* 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 +#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 */ + +/* 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: + 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: ( "," )* + 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: "(" ")" ":". + 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: '(' ')' ':' */ + 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: or + 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 ='"); + 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: */ + +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: + 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: + 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: [ { "," }* ], + where = STRING '(' ')' + 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: (as in a ). */ + +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: '(' ')' ':'. + 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: '(' [ 'IN' ']' ')' ':' + or: '(' 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: '(' ')' 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 ! */ + 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: + 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: */ + 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 , + 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: */ + +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 is a superset of . It also includes + and untyped , 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 . */ + +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: */ + +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: '(' ':' ')' */ + 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: or , i.e.: + [ ]. + 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: [ { "," }* ] + 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: + 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 (which is or ). + 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: + A NAME will be assumed to be a , and thus a . + 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: '(' ':' ')' */ + 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 diff --git a/gcc/ch/runtime/allmem.c b/gcc/ch/runtime/allmem.c new file mode 100644 index 00000000000..8cf2be5c486 --- /dev/null +++ b/gcc/ch/runtime/allmem.c @@ -0,0 +1,73 @@ +/* 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 +#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; +} diff --git a/gcc/ch/runtime/andps.c b/gcc/ch/runtime/andps.c new file mode 100644 index 00000000000..fd7d609a930 --- /dev/null +++ b/gcc/ch/runtime/andps.c @@ -0,0 +1,76 @@ +/* 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 +#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); + } +} diff --git a/gcc/ch/runtime/auxtypes.h b/gcc/ch/runtime/auxtypes.h new file mode 100644 index 00000000000..627da113eea --- /dev/null +++ b/gcc/ch/runtime/auxtypes.h @@ -0,0 +1,45 @@ +/* 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 diff --git a/gcc/ch/runtime/basicio.c b/gcc/ch/runtime/basicio.c new file mode 100644 index 00000000000..b13b0b8debf --- /dev/null +++ b/gcc/ch/runtime/basicio.c @@ -0,0 +1,467 @@ +/* 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 +#include +#include +#include +#include +#include + +#include +#include + +#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; +} diff --git a/gcc/ch/runtime/bitstring.h b/gcc/ch/runtime/bitstring.h new file mode 100644 index 00000000000..0a8ce629c5d --- /dev/null +++ b/gcc/ch/runtime/bitstring.h @@ -0,0 +1,29 @@ +/* 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 diff --git a/gcc/ch/runtime/cause.c b/gcc/ch/runtime/cause.c new file mode 100644 index 00000000000..d4d0794409b --- /dev/null +++ b/gcc/ch/runtime/cause.c @@ -0,0 +1,48 @@ +/* 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; +{ +} diff --git a/gcc/ch/runtime/concatps.c b/gcc/ch/runtime/concatps.c new file mode 100644 index 00000000000..4dacda65029 --- /dev/null +++ b/gcc/ch/runtime/concatps.c @@ -0,0 +1,93 @@ +/* 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); +} diff --git a/gcc/ch/runtime/copyps.c b/gcc/ch/runtime/copyps.c new file mode 100644 index 00000000000..226f429356b --- /dev/null +++ b/gcc/ch/runtime/copyps.c @@ -0,0 +1,111 @@ +/* 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 +#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); + } +} diff --git a/gcc/ch/runtime/eqps.c b/gcc/ch/runtime/eqps.c new file mode 100644 index 00000000000..4ac002d8103 --- /dev/null +++ b/gcc/ch/runtime/eqps.c @@ -0,0 +1,88 @@ +/* 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 +#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; + } +} diff --git a/gcc/ch/runtime/fileio.h b/gcc/ch/runtime/fileio.h new file mode 100644 index 00000000000..fb15b8f6eb2 --- /dev/null +++ b/gcc/ch/runtime/fileio.h @@ -0,0 +1,153 @@ +/* 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 + +#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 diff --git a/gcc/ch/runtime/flsetps.c b/gcc/ch/runtime/flsetps.c new file mode 100644 index 00000000000..1a790768996 --- /dev/null +++ b/gcc/ch/runtime/flsetps.c @@ -0,0 +1,107 @@ +/* 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 +#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); +} diff --git a/gcc/ch/runtime/format.h b/gcc/ch/runtime/format.h new file mode 100644 index 00000000000..8b554f4c209 --- /dev/null +++ b/gcc/ch/runtime/format.h @@ -0,0 +1,71 @@ +/* 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_ diff --git a/gcc/ch/runtime/getassoc.c b/gcc/ch/runtime/getassoc.c new file mode 100644 index 00000000000..1bc92aacef4 --- /dev/null +++ b/gcc/ch/runtime/getassoc.c @@ -0,0 +1,37 @@ +/* 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; +} diff --git a/gcc/ch/runtime/gettextaccess.c b/gcc/ch/runtime/gettextaccess.c new file mode 100644 index 00000000000..28f976d6a27 --- /dev/null +++ b/gcc/ch/runtime/gettextaccess.c @@ -0,0 +1,31 @@ +/* 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; +} + diff --git a/gcc/ch/runtime/getusage.c b/gcc/ch/runtime/getusage.c new file mode 100644 index 00000000000..2fcaf77dd80 --- /dev/null +++ b/gcc/ch/runtime/getusage.c @@ -0,0 +1,40 @@ +/* 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; +} + diff --git a/gcc/ch/runtime/inps.c b/gcc/ch/runtime/inps.c new file mode 100644 index 00000000000..d01d76aff24 --- /dev/null +++ b/gcc/ch/runtime/inps.c @@ -0,0 +1,65 @@ +/* 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 +#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); +} diff --git a/gcc/ch/runtime/ioerror.c b/gcc/ch/runtime/ioerror.c new file mode 100644 index 00000000000..8c9fad469d7 --- /dev/null +++ b/gcc/ch/runtime/ioerror.c @@ -0,0 +1,45 @@ +/* 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 + +/* 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; diff --git a/gcc/ch/runtime/ioerror.h b/gcc/ch/runtime/ioerror.h new file mode 100644 index 00000000000..e2ddfe57c1e --- /dev/null +++ b/gcc/ch/runtime/ioerror.h @@ -0,0 +1,161 @@ +/* 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 + +/* 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 diff --git a/gcc/ch/runtime/iomodes.h b/gcc/ch/runtime/iomodes.h new file mode 100644 index 00000000000..8e254e25b00 --- /dev/null +++ b/gcc/ch/runtime/iomodes.h @@ -0,0 +1,251 @@ +/* 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 diff --git a/gcc/ch/runtime/ltps.c b/gcc/ch/runtime/ltps.c new file mode 100644 index 00000000000..747be42703e --- /dev/null +++ b/gcc/ch/runtime/ltps.c @@ -0,0 +1,86 @@ +/* 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 +#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; + } +} diff --git a/gcc/ch/runtime/ltstr.c b/gcc/ch/runtime/ltstr.c new file mode 100644 index 00000000000..683a9474541 --- /dev/null +++ b/gcc/ch/runtime/ltstr.c @@ -0,0 +1,55 @@ +/* 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); +} diff --git a/gcc/ch/runtime/rts.h b/gcc/ch/runtime/rts.h new file mode 100644 index 00000000000..27019e7c04f --- /dev/null +++ b/gcc/ch/runtime/rts.h @@ -0,0 +1,52 @@ +/* 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_ */ diff --git a/gcc/ch/runtime/sliceps.c b/gcc/ch/runtime/sliceps.c new file mode 100644 index 00000000000..939a0b8e37c --- /dev/null +++ b/gcc/ch/runtime/sliceps.c @@ -0,0 +1,65 @@ +/* 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 +#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); +} diff --git a/gcc/ch/runtime/unhex.c b/gcc/ch/runtime/unhex.c new file mode 100644 index 00000000000..3bd23dcf7d7 --- /dev/null +++ b/gcc/ch/runtime/unhex.c @@ -0,0 +1,57 @@ +/* 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 +#include +#include + +/* + * 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 */ diff --git a/gcc/ch/runtime/unhex1.c b/gcc/ch/runtime/unhex1.c new file mode 100644 index 00000000000..375f6a52497 --- /dev/null +++ b/gcc/ch/runtime/unhex1.c @@ -0,0 +1,58 @@ +/* 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 +#include +#include + +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 */ diff --git a/gcc/ch/satisfy.c b/gcc/ch/satisfy.c new file mode 100644 index 00000000000..a9f3c871fa7 --- /dev/null +++ b/gcc/ch/satisfy.c @@ -0,0 +1,628 @@ +/* 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 +#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; +} diff --git a/gcc/ch/tasking.c b/gcc/ch/tasking.c new file mode 100644 index 00000000000..95c81c6fd2e --- /dev/null +++ b/gcc/ch/tasking.c @@ -0,0 +1,3423 @@ +/* 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 +#include +#include +#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; + +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); +} + +/* + * 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; +} + +/* + * 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; +} + +/* 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); +} + +/* 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 (); +} + +/* 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; +{ +} + +/* + * 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 (); +} + +/* + * 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; +} + +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; +} + +/* + * 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)))); + } +} + +/* + * 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; + } +} + +/* + * 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; +} + +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; +} + +/* + * 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); +} + +#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; +} + +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; + } + } +} + +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))))))))); +} + +#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 + +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; +} + +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; +} + +/* + * 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); +} + +/* 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))))); +} + +#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 + +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; +} + +/* + 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); +} + +/* + * 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); +} + +#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); + } +} + +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 + +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 + +/* + * 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; +} + +#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 + +#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 + +/* 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; +} + +/* + * 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; +} diff --git a/gcc/ch/timing.c b/gcc/ch/timing.c new file mode 100644 index 00000000000..f96b7159f36 --- /dev/null +++ b/gcc/ch/timing.c @@ -0,0 +1,494 @@ +/* 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 +#include +#include +#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 (); + } +} diff --git a/gcc/ch/typeck.c b/gcc/ch/typeck.c new file mode 100644 index 00000000000..5f9749410e0 --- /dev/null +++ b/gcc/ch/typeck.c @@ -0,0 +1,3905 @@ +/* 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 +#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(); + +/* + * 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 */ +} + +/* + * 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; + } +} + +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); +} + +/* 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); +} + +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: + '(' }* ')' + is derived syntax (i.e. syntactic sugar) for: + '(' ')' }* + The intent is clear if has mode: ARRAY (...) ARRAY (...) XXX. + But what if 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 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); +} + +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 (); +} + + +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; +} + +/* 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; +} + +/* + * 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; +} + +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; + } +} + +/* 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 "*". */ + 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 (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; +} + + +/* + * 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; +} + +/* + * 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; +} + + +/* + * 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; +} + +/* 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); +} + +/* 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; +} + +/* 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; +} + +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; +} + + +/* 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; +} + +/* 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; + } +} + +/* 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; +} + +/* 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; +}