| /* Convert language-specific tree expression to rtl instructions, |
| for GNU CHILL compiler. |
| Copyright (C) 1992, 93, 1994, 1998, 1999 Free Software Foundation, Inc. |
| |
| This file is part of GNU CC. |
| |
| GNU CC is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 2, or (at your option) |
| any later version. |
| |
| GNU CC is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GNU CC; see the file COPYING. If not, write to |
| the Free Software Foundation, 59 Temple Place - Suite 330, |
| Boston, MA 02111-1307, USA. */ |
| |
| |
| #include "config.h" |
| #include "system.h" |
| #include "rtl.h" |
| #include "tree.h" |
| #include "flags.h" |
| #include "expr.h" |
| #include "ch-tree.h" |
| #include "assert.h" |
| #include "lex.h" |
| #include "convert.h" |
| #include "toplev.h" |
| |
| extern char **boolean_code_name; |
| extern int flag_old_strings; |
| extern tree long_unsigned_type_node; |
| extern int ignore_case; |
| extern int special_UC; |
| |
| /* 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 = NULL_RTX, size1 = NULL_RTX; |
| 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: |
| { |
| 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: |
| { |
| 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 ATTRIBUTE_UNUSED; |
| { |
| 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, 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; |
| |
| 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 |
| { |
| 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 = NULL, *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 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, 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 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; |
| default: |
| abort(); |
| } |
| 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 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); |
| default: |
| abort(); |
| } |
| } |
| 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 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); |
| 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; |
| } |
| |
| 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"); |
| 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; |
| |
| 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; |
| { |
| if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK) |
| return error_mark_node; |
| |
| return discrete_count (TYPE_DOMAIN (TREE_TYPE (powerset))); |
| } |